Merge pull request #589 from binarysunrise-io/embedded-json-string-helper

Add a helper for decoding embedded json strings

Author: bergmark

Data/Aeson.hs

@@ -111,6 +111,7 @@ module Data.Aeson
     , withNumber
     , withScientific
     , withBool
+    , withEmbeddedJSON
     -- * Constructors and accessors
     , Series
     , pairs

Data/Aeson/Compat.hs

@@ -0,0 +1,16 @@
+{-# LANGUAGE CPP #-}
+
+module Data.Aeson.Compat
+  (
+    fromStrict
+  ) where
+
+import qualified Data.ByteString      as S
+import qualified Data.ByteString.Lazy as L
+
+fromStrict :: S.ByteString -> L.ByteString
+#if MIN_VERSION_bytestring(0, 9, 2)
+fromStrict = L.fromChunks . (:[])
+#else
+fromStrict = L.fromStrict
+#endif

Data/Aeson/Types.hs

@@ -84,6 +84,7 @@ module Data.Aeson.Types
     , withNumber
     , withScientific
     , withBool
+    , withEmbeddedJSON
 
     , pairs
     , foldable

Data/Aeson/Types/Class.hs

@@ -73,6 +73,7 @@ module Data.Aeson.Types.Class
     , withNumber
     , withScientific
     , withBool
+    , withEmbeddedJSON
 
     -- * Functions
     , fromJSON

Data/Aeson/Types/FromJSON.hs

@@ -55,6 +55,7 @@ module Data.Aeson.Types.FromJSON
     , withNumber
     , withScientific
     , withBool
+    , withEmbeddedJSON
 
     -- * Functions
     , fromJSON
@@ -82,6 +83,7 @@ import Prelude.Compat
 import Control.Applicative ((<|>), Const(..))
 import Control.Monad ((<=<), zipWithM)
 import Data.Aeson.Internal.Functions (mapKey)
+import Data.Aeson.Parser.Internal (eitherDecodeWith, jsonEOF)
 import Data.Aeson.Types.Generic
 import Data.Aeson.Types.Internal
 import Data.Attoparsec.Number (Number(..))
@@ -114,6 +116,7 @@ import GHC.Generics
 import Numeric.Natural (Natural)
 import Text.ParserCombinators.ReadP (readP_to_S)
 import Unsafe.Coerce (unsafeCoerce)
+import qualified Data.Aeson.Compat as Compat
 import qualified Data.Aeson.Parser.Time as Time
 import qualified Data.Attoparsec.ByteString.Char8 as A (endOfInput, parseOnly, scientific)
 import qualified Data.DList as DList
@@ -665,6 +668,16 @@ withBool _        f (Bool arr) = f arr
 withBool expected _ v          = typeMismatch expected v
 {-# INLINE withBool #-}
 
+-- | Decode a nested JSON-encoded string.
+withEmbeddedJSON :: (FromJSON a) => String -> (Value -> Parser a) -> Value -> Parser a
+withEmbeddedJSON _ innerParser (String txt) =
+    either fail innerParser $ eitherDecode (Compat.fromStrict $ T.encodeUtf8 txt)
+    where
+        eitherDecode = eitherFormatError . eitherDecodeWith jsonEOF ifromJSON
+        eitherFormatError = either (Left . uncurry formatError) Right
+withEmbeddedJSON name _ v = typeMismatch name v
+{-# INLINE withEmbeddedJSON #-}
+
 -- | Convert a value from JSON, failing if the types do not match.
 fromJSON :: (FromJSON a) => Value -> Result a
 fromJSON = parse parseJSON

aeson.cabal

@@ -100,6 +100,7 @@ library
     Data.Aeson.Encode
 
   other-modules:
+    Data.Aeson.Compat
     Data.Aeson.Encoding.Builder
     Data.Aeson.Internal.Functions
     Data.Aeson.Parser.Unescape

tests/UnitTests.hs

@@ -16,13 +16,14 @@ module UnitTests
     (
       ioTests
     , tests
+    , withEmbeddedJSONTest
     ) where
 
 import Prelude ()
 import Prelude.Compat
 
 import Control.Monad (forM, forM_)
-import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject)
+import Data.Aeson ((.=), (.:), (.:?), (.:!), FromJSON(..), FromJSONKeyFunction(..), FromJSONKey(..), ToJSON1(..), decode, eitherDecode, encode, fromJSON, genericParseJSON, genericToEncoding, genericToJSON, object, withObject, withEmbeddedJSON)
 import Data.Aeson.Internal (JSONPathElement(..), formatError)
 import Data.Aeson.TH (deriveJSON, deriveToJSON, deriveToJSON1)
 import Data.Aeson.Text (encodeToTextBuilder)
@@ -97,6 +98,7 @@ tests = testGroup "unit" [
   , testCase "Unescape string (PR #477)" unescapeString
   , testCase "Show Options" showOptions
   , testGroup "SingleMaybeField" singleMaybeField
+  , testCase "withEmbeddedJSON" withEmbeddedJSONTest
   ]
 
 roundTripCamel :: String -> Assertion
@@ -519,6 +521,19 @@ singleMaybeField = do
     v = SingleMaybeField Nothing
     opts = defaultOptions{omitNothingFields=True,unwrapUnaryRecords=True}
 
+
+newtype EmbeddedJSONTest = EmbeddedJSONTest Int
+  deriving (Eq, Show)
+
+instance FromJSON EmbeddedJSONTest where
+  parseJSON =
+    withObject "Object" $ \o ->
+      EmbeddedJSONTest <$> (o .: "prop" >>= withEmbeddedJSON "Quoted Int" parseJSON)
+
+withEmbeddedJSONTest :: Assertion
+withEmbeddedJSONTest =
+  assertEqual "Unquote embedded JSON" (Right $ EmbeddedJSONTest 1) (eitherDecode "{\"prop\":\"1\"}")
+
 deriveJSON defaultOptions{omitNothingFields=True} ''MyRecord
 
 deriveToJSON  defaultOptions ''Foo