Merge pull request #84 from haskell-servant/wip-json-decode-eof

fix a bug in our `eitherDecodeLenient` function

servant/src/Servant/API/ContentTypes.hs

@@ -66,17 +66,19 @@ module Servant.API.ContentTypes
     ) where
 
 #if !MIN_VERSION_base(4,8,0)
-import           Control.Applicative        ((<*))
+import           Control.Applicative              ((*>), (<*))
 #endif
 import           Control.Arrow                    (left)
 import           Control.Monad
-import           Data.Aeson                 (FromJSON, ToJSON, Value,
+import           Data.Aeson                       (FromJSON, ToJSON, encode,
-                                             encode, parseJSON)
+                                                   parseJSON)
 import           Data.Aeson.Parser                (value)
 import           Data.Aeson.Types                 (parseEither)
-import           Data.Attoparsec.ByteString (endOfInput, parseOnly)
+import           Data.Attoparsec.ByteString.Char8 (endOfInput, parseOnly,
+                                                   skipSpace, (<?>))
 import qualified Data.ByteString                  as BS
-import           Data.ByteString.Lazy       (ByteString, fromStrict, toStrict)
+import           Data.ByteString.Lazy             (ByteString, fromStrict,
+                                                   toStrict)
 import qualified Data.ByteString.Lazy             as B
 import           Data.Monoid
 import           Data.String.Conversions          (cs)
@@ -87,8 +89,8 @@ import qualified Data.Text.Lazy.Encoding    as TextL
 import           Data.Typeable
 import           GHC.Exts                         (Constraint)
 import qualified Network.HTTP.Media               as M
-import           Network.URI                (escapeURIString, isUnreserved,
+import           Network.URI                      (escapeURIString,
-                                             unEscapeString)
+                                                   isUnreserved, unEscapeString)
 
 -- * Provided content types
 data JSON deriving Typeable
@@ -291,10 +293,22 @@ instance MimeRender OctetStream BS.ByteString where
 
 -- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
 -- objects and arrays.
+--
+-- Will handle trailing whitespace, but not trailing junk. ie.
+--
+-- >>> eitherDecodeLenient "1 " :: Either String Int
+-- Right 1
+--
+-- >>> eitherDecodeLenient "1 junk" :: Either String Int
+-- Left "trailing junk after valid JSON: endOfInput"
 eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
-eitherDecodeLenient input = do
+eitherDecodeLenient input =
-    v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
+    parseOnly parser (cs input) >>= parseEither parseJSON
-    parseEither parseJSON v
+  where
+    parser = skipSpace
+          *> Data.Aeson.Parser.value
+          <* skipSpace
+          <* (endOfInput <?> "trailing junk after valid JSON")
 
 -- | `eitherDecode`
 instance FromJSON a => MimeUnrender JSON a where

servant/test/Servant/API/ContentTypesSpec.hs

@@ -8,14 +8,15 @@ module Servant.API.ContentTypesSpec where
 
 #if !MIN_VERSION_base(4,8,0)
 import           Control.Applicative
+import           Data.Monoid
 #endif
 import           Control.Arrow
 import           Data.Aeson
 import           Data.Aeson.Parser          (jstring)
 import           Data.Attoparsec.ByteString (parseOnly)
+import           Data.Either
 import           Data.Function              (on)
 import           Data.Proxy
-
 import           Data.ByteString.Char8      (ByteString, append, pack)
 import qualified Data.ByteString.Lazy       as BSL
 import           Data.List                  (maximumBy)
@@ -36,54 +37,56 @@ spec :: Spec
 spec = describe "Servant.API.ContentTypes" $ do
 
     describe "The JSON Content-Type type" $ do
+        let p = Proxy :: Proxy JSON
+
+        it "handles whitespace at end of input" $ do
+            mimeUnrender p "[1] " `shouldBe` Right [1 :: Int]
+
+        it "handles whitespace at beginning of input" $ do
+            mimeUnrender p " [1] " `shouldBe` Right [1 :: Int]
+
+        it "does not like junk at end of input" $ do
+            mimeUnrender p "[1] this probably shouldn't work"
+              `shouldSatisfy` (isLeft :: Either a [Int] -> Bool)
 
         it "has mimeUnrender reverse mimeRender for valid top-level json ([Int]) " $ do
-            let p = Proxy :: Proxy JSON
             property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::[Int])
 
         it "has mimeUnrender reverse mimeRender for valid top-level json " $ do
-            let p = Proxy :: Proxy JSON
             property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::SomeData)
 
     describe "The FormUrlEncoded Content-Type type" $ do
-
+        let p = Proxy :: Proxy FormUrlEncoded
-        let isNonNull ("", "") = False
-            isNonNull _        = True
 
         it "has mimeUnrender reverse mimeRender" $ do
-            let p = Proxy :: Proxy FormUrlEncoded
+            property $ \x -> all (/= mempty) x
-            property $ \x -> all isNonNull x
                 ==> mimeUnrender p (mimeRender p x) == Right (x::[(TextS.Text,TextS.Text)])
 
         it "has mimeUnrender reverse exportParams (Network.URL)" $ do
-            let p = Proxy :: Proxy FormUrlEncoded
+            property $ \x -> all (/= mempty) x
-            property $ \x -> all isNonNull x
                 ==> (mimeUnrender p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
 
         it "has importParams (Network.URL) reverse mimeRender" $ do
-            let p = Proxy :: Proxy FormUrlEncoded
+            property $ \x -> all (/= mempty) x
-            property $ \x -> all isNonNull x
                 ==> (fmap (map (cs *** cs)) . importParams . cs . mimeRender p $ x) == Just (x::[(TextS.Text,TextS.Text)])
 
     describe "The PlainText Content-Type type" $ do
+        let p = Proxy :: Proxy PlainText
 
         it "has mimeUnrender reverse mimeRender (lazy Text)" $ do
-            let p = Proxy :: Proxy PlainText
             property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextL.Text)
 
         it "has mimeUnrender reverse mimeRender (strict Text)" $ do
-            let p = Proxy :: Proxy PlainText
             property $ \x -> mimeUnrender p (mimeRender p x) == Right (x::TextS.Text)
 
     describe "The OctetStream Content-Type type" $ do
+        let p = Proxy :: Proxy OctetStream
 
         it "is id (Lazy ByteString)" $ do
-            let p = Proxy :: Proxy OctetStream
             property $ \x -> mimeRender p x == (x :: BSL.ByteString)
                 && mimeUnrender p x == Right x
 
         it "is fromStrict/toStrict (Strict ByteString)" $ do
-            let p = Proxy :: Proxy OctetStream
             property $ \x -> mimeRender p x == BSL.fromStrict (x :: ByteString)
                 && mimeUnrender p (BSL.fromStrict x) == Right x