Merge pull request #18 from haskell-servant/jkarni/decodeLenient

Use lenient decoding for JSON.

servant.cabal

@@ -45,6 +45,7 @@ library
   build-depends:
       base >=4.7 && <5
     , aeson >= 0.7
+    , attoparsec >= 0.12
     , bytestring == 0.10.*
     , http-media >= 0.4 && < 0.7
     , http-types == 0.8.*
@@ -86,6 +87,7 @@ test-suite spec
   build-depends:
       base == 4.*
     , aeson
+    , attoparsec
     , bytestring
     , hspec == 2.*
     , QuickCheck

src/Servant/API/ContentTypes.hs

@@ -11,24 +11,28 @@
 {-# LANGUAGE UndecidableInstances  #-}
 module Servant.API.ContentTypes where
 
+import           Control.Applicative        ((<*))
 import           Control.Arrow              (left)
 import           Control.Monad
-import           Data.Aeson              (FromJSON, ToJSON, eitherDecode,
-                                          encode)
+import           Data.Aeson                 (FromJSON, ToJSON, Value,
+                                             encode, parseJSON)
+import           Data.Aeson.Parser          (value)
+import           Data.Aeson.Types           (parseEither)
+import           Data.Attoparsec.ByteString (endOfInput, parseOnly)
 import qualified Data.ByteString            as BS
 import           Data.ByteString.Lazy       (ByteString, fromStrict, toStrict)
 import qualified Data.ByteString.Lazy       as B
-import           Data.String.Conversions (cs)
 import           Data.Monoid
-import qualified Data.Text.Lazy          as TextL
-import qualified Data.Text.Lazy.Encoding as TextL
+import           Data.String.Conversions    (cs)
 import qualified Data.Text                  as TextS
 import qualified Data.Text.Encoding         as TextS
+import qualified Data.Text.Lazy             as TextL
+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             (unEscapeString, escapeURIString,
-                                          isUnreserved)
+import           Network.URI                (escapeURIString, isUnreserved,
+                                             unEscapeString)
 
 -- * Provided content types
 data JSON deriving Typeable
@@ -190,6 +194,8 @@ instance ToJSON a => MimeRender JSON a where
     toByteString _ = encode
 
 -- | `encodeFormUrlEncoded . toFormUrlEncoded`
+-- Note that the `fromByteString p (toByteString p x) == Right x` law only
+-- holds if every element of x is non-null (i.e., not `("", "")`)
 instance ToFormUrlEncoded a => MimeRender FormUrlEncoded a where
     toByteString _ = encodeFormUrlEncoded . toFormUrlEncoded
 
@@ -213,11 +219,20 @@ instance MimeRender OctetStream BS.ByteString where
 --------------------------------------------------------------------------
 -- * MimeUnrender Instances
 
+-- | Like 'Data.Aeson.eitherDecode' but allows all JSON values instead of just
+-- objects and arrays.
+eitherDecodeLenient :: FromJSON a => ByteString -> Either String a
+eitherDecodeLenient input = do
+    v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
+    parseEither parseJSON v
+
 -- | `eitherDecode`
 instance FromJSON a => MimeUnrender JSON a where
-    fromByteString _ = eitherDecode
+    fromByteString _ = eitherDecodeLenient
 
 -- | `decodeFormUrlEncoded >=> fromFormUrlEncoded`
+-- Note that the `fromByteString p (toByteString p x) == Right x` law only
+-- holds if every element of x is non-null (i.e., not `("", "")`)
 instance FromFormUrlEncoded a => MimeUnrender FormUrlEncoded a where
     fromByteString _ = decodeFormUrlEncoded >=> fromFormUrlEncoded
 

test/Servant/API/ContentTypesSpec.hs

@@ -8,6 +8,8 @@ module Servant.API.ContentTypesSpec where
 import           Control.Applicative
 import           Control.Arrow
 import           Data.Aeson
+import           Data.Aeson.Parser          (jstring)
+import           Data.Attoparsec.ByteString (parseOnly)
 import           Data.Function              (on)
 import           Data.Proxy
 
@@ -20,7 +22,7 @@ import           Data.String.Conversions  (cs)
 import qualified Data.Text                  as TextS
 import qualified Data.Text.Lazy             as TextL
 import           GHC.Generics
-import           Network.URL              (importParams, exportParams)
+import           Network.URL                (exportParams, importParams)
 import           Test.Hspec
 import           Test.QuickCheck
 import           Test.QuickCheck.Instances  ()
@@ -42,17 +44,23 @@ spec = describe "Servant.API.ContentTypes" $ do
 
     describe "The FormUrlEncoded Content-Type type" $ do
 
+        let isNonNull ("", "") = False
+            isNonNull _        = True
+
         it "has fromByteString reverse toByteString" $ do
             let p = Proxy :: Proxy FormUrlEncoded
-            property $ \x -> fromByteString p (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)])
+            property $ \x -> all isNonNull x
+                ==> fromByteString p (toByteString p x) == Right (x::[(TextS.Text,TextS.Text)])
 
         it "has fromByteString reverse exportParams (Network.URL)" $ do
             let p = Proxy :: Proxy FormUrlEncoded
-            property $ \x -> (fromByteString p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
+            property $ \x -> all isNonNull x
+                ==> (fromByteString p . cs . exportParams . map (cs *** cs) $ x) == Right (x::[(TextS.Text,TextS.Text)])
 
         it "has importParams (Network.URL) reverse toByteString" $ do
             let p = Proxy :: Proxy FormUrlEncoded
-            property $ \x -> (fmap (map (cs *** cs)) . importParams . cs . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)])
+            property $ \x -> all isNonNull x
+                ==> (fmap (map (cs *** cs)) . importParams . cs . toByteString p $ x) == Just (x::[(TextS.Text,TextS.Text)])
 
     describe "The PlainText Content-Type type" $ do
 
@@ -148,6 +156,14 @@ spec = describe "Servant.API.ContentTypes" $ do
                     (encode val)
                     `shouldBe` Just (Right val)
 
+    describe "eitherDecodeLenient" $ do
+
+        it "parses top-level strings" $ do
+            let toMaybe = either (const Nothing) Just
+            -- The Left messages differ, so convert to Maybe
+            property $ \x -> toMaybe (eitherDecodeLenient x)
+                `shouldBe` toMaybe (parseOnly jstring $ cs x)
+
 
 data SomeData = SomeData { record1 :: String, record2 :: Int }
     deriving (Generic, Eq, Show)