diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,9 @@ +1.1.0.0 +======= + +- Fix #1 bug. +- `FromJSON (WithFields a b)` now requires `ToJSON a` to catch fields that should be removed from `b` JSON object before parsing. + 1.0.10.0 ======== diff --git a/aeson-injector.cabal b/aeson-injector.cabal --- a/aeson-injector.cabal +++ b/aeson-injector.cabal @@ -1,12 +1,12 @@ name: aeson-injector -version: 1.0.10.0 +version: 1.1.0.0 synopsis: Injecting fields into aeson values description: See README.md license: MIT license-file: LICENSE author: Anton Gushcha maintainer: ncrashed@gmail.com -copyright: 2016 Anton Gushcha +copyright: 2016-2017 Anton Gushcha category: Data, JSON, Web build-type: Simple cabal-version: >=1.18 @@ -14,6 +14,7 @@ GHC == 7.10.3 , GHC == 8.0.1 , GHC == 8.0.2 + , GHC == 8.2.1 extra-source-files: README.md CHANGELOG.md @@ -34,11 +35,12 @@ , aeson >= 0.11 && < 1.3 , bifunctors >= 5.2 && < 6 , deepseq >= 1.4 && < 2 + , hashable >= 1.0 && < 2.0 , lens >= 4.13 && < 5 + , servant-docs >= 0.7 && < 0.12 , swagger2 >= 2.1.2.1 && < 3.0 , text >= 1.2 && < 2.0 , unordered-containers >= 0.2.7 && < 0.3 - , servant-docs >= 0.7 && < 0.12 test-suite test-aeson-injector default-language: Haskell2010 @@ -49,6 +51,7 @@ base , aeson , aeson-injector + , containers , HUnit >= 1.3 , lens , QuickCheck >= 2.8.2 diff --git a/src/Data/Aeson/WithField.hs b/src/Data/Aeson/WithField.hs --- a/src/Data/Aeson/WithField.hs +++ b/src/Data/Aeson/WithField.hs @@ -5,6 +5,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-| Module : Data.Aeson.WithField @@ -21,12 +22,12 @@ fields attached to the response. The module provides you with 'WithField' and 'WithFields' data types that -help you to solve the issue without code duplication. +help you to solve the issue without code duplication. -It is small utility library that is intented to be used in RESTful APIs, -especially with -and . Its main purpose is simple injection of -fields into JSONs produced by +It is small utility library that is intented to be used in RESTful APIs, +especially with +and . Its main purpose is simple injection of +fields into JSONs produced by library. Consider the following common data type in web service developing: @@ -36,11 +37,11 @@ title :: Text , body :: Text , author :: Text -, timestamp :: UTCTime +, timestamp :: UTCTime } -- Consider we have simple 'ToJSON' and 'FromJSON' instances -$(deriveJSON defaultOptions ''News) +$(deriveJSON defaultOptions ''News) @ 'ToJSON' instance produces JSON's like: @@ -56,27 +57,27 @@ Now one can create a simple web server with servant DSL: -> type NewsId = Word -> -> type NewsAPI = +> type NewsId = Word +> +> type NewsAPI = > ReqBody '[JSON] News :> Post '[JSON] NewsId > :<|> Capture "news-id" NewsId :> Get '[JSON] News > :<|> "list" :> Get '[JSON] [News] -All seems legit, but, wait a second, an API user definitely would -like to know id of news in the "list" method. One way to do this is declare -new data type @NewsInfo@ with additional field, but it is bad solution as requires -to code duplication for each resource. +All seems legit, but, wait a second, an API user definitely would +like to know id of news in the "list" method. One way to do this is declare +new data type @NewsInfo@ with additional field, but it is bad solution as requires +to code duplication for each resource. So, here @aeson-injector@ steps in, now you can write: -> type NewsAPI = +> type NewsAPI = > ReqBody '[JSON] News :> Post '[JSON] NewsId > :<|> Capture "news-id" NewsId :> Get '[JSON] News > :<|> "list" :> Get '[JSON] [WithField "id" NewsId News] -@'WithField' "id" NewsId News@ or simply @'WithId' NewsId News@ wraps you data type +@'WithField' "id" NewsId News@ or simply @'WithId' NewsId News@ wraps you data type and injects "id" field in produced JSON values: >>> encode (WithField 42 myNews :: WithField "id" NewsId News) @@ -89,23 +90,23 @@ > , "timestamp": "2016-07-26T18:54:42.678999Z" > } -'WithField' data type has `FromJSON` instance for seamless parsing of data with +'WithField' data type has `FromJSON` instance for seamless parsing of data with injected fields and 'ToSchema' instance for support. = Injecting multiple values -The library also has more general data type 'WithFields a b' that injects fields of 'toJSON a' into 'toJSON b'. +The library also has more general data type 'WithFields a b' that injects fields of 'toJSON a' into 'toJSON b'. @ haskell data NewsPatch = NewsPatch { taggs :: [Text] , rating :: Double } -$(deriveJSON defaultOptions ''NewsPatch) +$(deriveJSON defaultOptions ''NewsPatch) @ @ haskell -let myNewsPatch = NewsPatch ["tag1", "tag2"] 42 +let myNewsPatch = NewsPatch ["tag1", "tag2"] 42 in encode $ WithFields myNewsPatch myNews @ @@ -120,7 +121,7 @@ = Corner cases -Unfortunately, we cannot inject in non object values of produced JSON, +Unfortunately, we cannot inject in non object values of produced JSON, so the library creates a wrapper object around non-object value: @ @@ -129,7 +130,7 @@ @ { - "id": 0 + "id": 0 , "value": "non-object" } @ @@ -142,7 +143,7 @@ @ { - "injected": 0 + "injected": 0 , "value": "non-object" } @ @@ -157,26 +158,29 @@ -- * Single field wrapper , OnlyField(..) , OnlyId - ) where + ) where import Control.Applicative import Control.DeepSeq import Control.Lens hiding ((.=)) -import Control.Monad +import Control.Monad import Data.Aeson -import Data.Monoid -import Data.Proxy -import Data.Swagger -import GHC.Generics -import GHC.TypeLits -import Servant.Docs +import Data.Aeson.Types (typeMismatch) +import Data.Hashable +import Data.Monoid +import Data.Proxy +import Data.Swagger +import GHC.Generics +import GHC.TypeLits +import Servant.Docs -import qualified Data.HashMap.Strict as H -import qualified Data.List as L -import qualified Data.Text as T +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as H +import qualified Data.List as L +import qualified Data.Text as T -- | Injects field 'a' into 'b' with tag 's'. It has --- special instances for 'ToJSON' and 'FromJSON' for +-- special instances for 'ToJSON' and 'FromJSON' for -- such injection and corresponding Swagger 'ToSchema' -- instance. -- @@ -192,15 +196,15 @@ -- "{\"value\":42,\"injected\":\"val\"}" -- -- `WithField s a b` always overwites field `s` in JSON produced by `b`. -data WithField (s :: Symbol) a b = WithField !a !b +data WithField (s :: Symbol) a b = WithField !a !b deriving (Generic, Eq, Show, Read) instance (NFData a, NFData b) => NFData (WithField s a b) -instance Functor (WithField s a) where +instance Functor (WithField s a) where fmap f (WithField a b) = WithField a (f b) -instance Bifunctor (WithField s) where +instance Bifunctor (WithField s) where bimap fa fb (WithField a b) = WithField (fa a) (fb b) -- | Workaround for a problem that is discribed as: @@ -208,59 +212,62 @@ -- -- The important note that 'ToJSON' and 'FromJSON' instances -- behaves as it is 'a' but with additional 'id' field. -type WithId i a = WithField "id" i a +type WithId i a = WithField "id" i a -instance (ToSample a, ToSample b) => ToSample (WithField s a b) where - toSamples _ = samples $ WithField <$> as <*> bs - where +instance (ToSample a, ToSample b) => ToSample (WithField s a b) where + toSamples _ = samples $ WithField <$> as <*> bs + where as = snd <$> toSamples (Proxy :: Proxy a) bs = snd <$> toSamples (Proxy :: Proxy b) -- | Note: the instance injects field only in 'Object' case. --- In other cases it forms a wrapper around the 'Value' produced +-- In other cases it forms a wrapper around the 'Value' produced -- by 'toJSON' of inner 'b' body. -- -- Example of wrapper: -- -- > { "id": 0, "value": [1, 2, 3] } -instance (KnownSymbol s, ToJSON a, ToJSON b) => ToJSON (WithField s a b) where +instance (KnownSymbol s, ToJSON a, ToJSON b) => ToJSON (WithField s a b) where toJSON (WithField a b) = let - jsonb = toJSON b + jsonb = toJSON b field = T.pack $ symbolVal (Proxy :: Proxy s) - in case toJSON b of - Object vs -> Object $ H.insert field (toJSON a) vs + in case toJSON b of + Object vs -> Object $ H.insert field (toJSON a) vs _ -> object [ "value" .= jsonb - , field .= a + , field .= a ] --- | Note: the instance tries to parse the json as object with +-- | Note: the instance tries to parse the json as object with -- additional field value, if it fails it assumes that it is a -- wrapper produced by corresponding 'ToJSON' instance. -instance (KnownSymbol s, FromJSON a, FromJSON b) => FromJSON (WithField s a b) where - parseJSON val@(Object o) = injected <|> wrapper - where +-- +-- Note: The instance tries to parse the `b` part without `s` field at first time. +-- If it fails, the instance retries with presence of the `s` field. +instance (KnownSymbol s, FromJSON a, FromJSON b) => FromJSON (WithField s a b) where + parseJSON val@(Object o) = injected <|> wrapper + where field = T.pack $ symbolVal (Proxy :: Proxy s) - injected = WithField + injected = WithField <$> o .: field - <*> parseJSON val - wrapper = WithField + <*> (parseJSON (Object $ H.delete field o) <|> parseJSON val) + wrapper = WithField <$> o .: field <*> o .: "value" - parseJSON _ = mzero + parseJSON wat = typeMismatch "Expected JSON Object" wat --- | Note: the instance tries to generate schema of the json as object with +-- | Note: the instance tries to generate schema of the json as object with -- additional field value, if it fails it assumes that it is a -- wrapper produced by corresponding 'ToJSON' instance. -instance (KnownSymbol s, ToSchema a, ToSchema b) => ToSchema (WithField s a b) where - declareNamedSchema _ = do +instance (KnownSymbol s, ToSchema a, ToSchema b) => ToSchema (WithField s a b) where + declareNamedSchema _ = do NamedSchema n s <- declareNamedSchema (Proxy :: Proxy b) - if s ^. type_ == SwaggerObject then inline n s + if s ^. type_ == SwaggerObject then inline n s else wrapper n s - where + where field = T.pack $ symbolVal (Proxy :: Proxy s) namePrefix = "WithField '" <> field <> "' " - wrapper n s = do + wrapper n s = do indexSchema <- declareSchema (Proxy :: Proxy a) return $ NamedSchema (fmap (namePrefix <>) n) $ mempty & type_ .~ SwaggerObject @@ -269,7 +276,7 @@ , (field, Inline indexSchema) ] & required .~ (L.nub [ "value", field ]) - inline n s = do + inline n s = do indexSchema <- declareSchema (Proxy :: Proxy a) return $ NamedSchema (fmap (namePrefix <>) n) $ s & properties %~ ([(field, Inline indexSchema)] <>) @@ -277,60 +284,60 @@ -- | Merge fields of 'a' into 'b', more general version of 'WithField'. -- --- The usual mode of the data type assumes that 'ToJSON' instances of 'a' and 'b' --- produce 'Object' subtype of aeson 'Value'. If it is not true, a wrapper +-- The usual mode of the data type assumes that 'ToJSON' instances of 'a' and 'b' +-- produce 'Object' subtype of aeson 'Value'. If it is not true, a wrapper -- layer is introduced. -- -- If 'a' is not a 'Object', the wrapper contains 'injected' field with body of 'a'. -- If 'b' is not a 'Object', the wrapper contains 'value' field with body of 'b'. -- If both are not 'Object', the wrapper contains 'injected' and 'value' keys with -- 'a' and 'b' respectively. -data WithFields a b = WithFields !a !b +data WithFields a b = WithFields !a !b deriving (Generic, Eq, Show, Read) instance (NFData a, NFData b) => NFData (WithFields a b) -instance Functor (WithFields a) where +instance Functor (WithFields a) where fmap f (WithFields a b) = WithFields a (f b) -instance Bifunctor WithFields where +instance Bifunctor WithFields where bimap fa fb (WithFields a b) = WithFields (fa a) (fb b) -instance (ToSample a, ToSample b) => ToSample (WithFields a b) where - toSamples _ = samples $ WithFields <$> as <*> bs - where +instance (ToSample a, ToSample b) => ToSample (WithFields a b) where + toSamples _ = samples $ WithFields <$> as <*> bs + where as = snd <$> toSamples (Proxy :: Proxy a) bs = snd <$> toSamples (Proxy :: Proxy b) -- | Note: the instance injects field only in 'Object' case. --- In other cases it forms a wrapper around the 'Value' produced +-- In other cases it forms a wrapper around the 'Value' produced -- by 'toJSON' of inner 'b' body. -- -- Example of wrapper when 'b' is not a 'Object', 'b' goes into "value" field: --- +-- -- > { "field1": 0, "field2": "val", "value": [1, 2, 3] } -- --- Example of wrapper when 'a' is not a 'Object', but 'b' is. 'a' goes into +-- Example of wrapper when 'a' is not a 'Object', but 'b' is. 'a' goes into -- "injected" field: --- +-- -- > { "field1": 0, "field2": "val", "injected": [1, 2, 3] } -- --- Example of wrapper when as 'a' is not a 'Object', as 'b' is not. 'a' goes into +-- Example of wrapper when as 'a' is not a 'Object', as 'b' is not. 'a' goes into -- "injected" field, 'b' goes into "value" field: -- -- > { "value": 42, "injected": [1, 2, 3] } -- --- `WithFields a b` always overwites fields in JSON produced by `b` with fields from JSON +-- `WithFields a b` always overwites fields in JSON produced by `b` with fields from JSON -- produced by `a`. -instance (ToJSON a, ToJSON b) => ToJSON (WithFields a b) where +instance (ToJSON a, ToJSON b) => ToJSON (WithFields a b) where toJSON (WithFields a b) = let - jsonb = toJSON b + jsonb = toJSON b jsona = toJSON a - in case jsonb of - Object bvs -> case jsona of + in case jsonb of + Object bvs -> case jsona of Object avs -> Object $ H.union avs bvs - _ -> Object $ H.insert "injected" jsona bvs - _ -> case jsona of + _ -> Object $ H.insert "injected" jsona bvs + _ -> case jsona of Object avs -> Object $ case H.lookup "value" avs of Nothing -> H.insert "value" jsonb avs Just _ -> avs @@ -339,25 +346,42 @@ , "value" .= jsonb ] --- | Note: the instance tries to parse the json as object with +-- | Note: the instance tries to parse the json as object with -- additional field value, if it fails it assumes that it is a -- wrapper produced by corresponding 'ToJSON' instance. -instance (FromJSON a, FromJSON b) => FromJSON (WithFields a b) where - parseJSON val@(Object o) = WithFields - <$> (parseJSON val <|> o .: "injected") - <*> (parseJSON val <|> o .: "value") - parseJSON _ = mzero +-- +-- Note: The instance tries to parse the `b` part without fields of `a` at first time. +-- If it fails, the instance retries with presence of a's fields. +-- +-- The implementation requires `ToJSON a` to catch fields of `a` and it is assumed +-- that `fromJSON . toJSON === id` for `a`. +instance (ToJSON a, FromJSON a, FromJSON b) => FromJSON (WithFields a b) where + parseJSON val@(Object o) = do + (a, isInjected) <- ((, False) <$> parseJSON val) <|> ((, True) <$> (o .: "injected")) + let o' = (if isInjected then H.delete "injected" else deleteAll (extractFields a)) o + b <- (parseJSON (Object o') <|> o' .: "value") + <|> (parseJSON val <|> o .: "value") + pure $ WithFields a b + where + deleteAll :: (Eq k, Hashable k) => [k] -> H.HashMap k v -> H.HashMap k v + deleteAll ks m = F.foldl' (flip H.delete) m ks --- | Note: the instance tries to generate schema of the json as object with + extractFields :: ToJSON a => a -> [T.Text] + extractFields a = case toJSON a of + Object vs -> H.keys vs + _ -> [] + parseJSON wat = typeMismatch "Expected JSON Object" wat + +-- | Note: the instance tries to generate schema of the json as object with -- additional field value, if it fails it assumes that it is a -- wrapper produced by corresponding 'ToJSON' instance. -instance (ToSchema a, ToSchema b) => ToSchema (WithFields a b) where - declareNamedSchema _ = do +instance (ToSchema a, ToSchema b) => ToSchema (WithFields a b) where + declareNamedSchema _ = do NamedSchema nb sb <- declareNamedSchema (Proxy :: Proxy b) NamedSchema na sa <- declareNamedSchema (Proxy :: Proxy a) let newName = combinedName <$> na <*> nb - return . NamedSchema newName $ case (sa ^. type_ , sb ^. type_) of - (SwaggerObject, SwaggerObject) -> sb <> sa + return . NamedSchema newName $ case (sa ^. type_ , sb ^. type_) of + (SwaggerObject, SwaggerObject) -> sb <> sa (SwaggerObject, _) -> bwrapper sb <> sa (_, SwaggerObject) -> sb <> awrapper sa _ -> bwrapper sb <> awrapper sa @@ -381,40 +405,40 @@ -- "{\"required\":[\"id\"],\"type\":\"object\",\"properties\":{\"id\":{\"maximum\":9223372036854775807,\"minimum\":-9223372036854775808,\"type\":\"integer\"}}}" -- -- Also the type can be used as an endpoint for 'WithField': --- +-- -- >>> encode (WithField True (OnlyField 0) :: WithField "val" Bool (OnlyField "id" Int)) -- "{\"id\":0,\"val\":true}" newtype OnlyField (s :: Symbol) a = OnlyField { unOnlyField :: a } deriving (Generic, Show, Read, Eq) -- | Special case for the most common "id" field -type OnlyId i = OnlyField "id" i +type OnlyId i = OnlyField "id" i -instance Functor (OnlyField s) where +instance Functor (OnlyField s) where fmap f (OnlyField a) = OnlyField (f a) -instance ToSample a => ToSample (OnlyField s a) where +instance ToSample a => ToSample (OnlyField s a) where toSamples _ = samples $ OnlyField <$> as - where + where as = snd <$> toSamples (Proxy :: Proxy a) -instance (KnownSymbol s, ToJSON a) => ToJSON (OnlyField s a) where +instance (KnownSymbol s, ToJSON a) => ToJSON (OnlyField s a) where toJSON (OnlyField a) = object [ field .= a ] - where + where field = T.pack $ symbolVal (Proxy :: Proxy s) -instance (KnownSymbol s, FromJSON a) => FromJSON (OnlyField s a) where - parseJSON (Object o) = OnlyField <$> o .: field - where +instance (KnownSymbol s, FromJSON a) => FromJSON (OnlyField s a) where + parseJSON (Object o) = OnlyField <$> o .: field + where field = T.pack $ symbolVal (Proxy :: Proxy s) - parseJSON _ = mzero + parseJSON _ = mzero -instance (KnownSymbol s, ToSchema a) => ToSchema (OnlyField s a) where +instance (KnownSymbol s, ToSchema a) => ToSchema (OnlyField s a) where declareNamedSchema _ = do NamedSchema an as <- declareNamedSchema (Proxy :: Proxy a) - return $ NamedSchema (fmap ("OnlyField" <>) an) $ mempty + return $ NamedSchema (fmap ("OnlyField" <>) an) $ mempty & type_ .~ SwaggerObject & properties .~ [(field, Inline as)] & required .~ [field] - where + where field = T.pack $ symbolVal (Proxy :: Proxy s) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -6,43 +6,45 @@ module Main where import Control.Lens hiding ((.=)) -import Control.Monad -import Data.Aeson as A +import Control.Monad +import Data.Aeson as A +import Data.Aeson.Types (parseEither) import Data.Aeson.Unit import Data.Aeson.WithField -import Data.Monoid +import Data.Monoid import Data.Proxy import Data.Scientific (scientific) import Data.Swagger import Data.Swagger.Internal.Schema import Data.Text import Data.Text.Arbitrary -import Data.Typeable +import Data.Typeable import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck as QC -import qualified Data.Vector as V +import qualified Data.Map.Strict as Map +import qualified Data.Vector as V -instance (Arbitrary a, Arbitrary b) => Arbitrary (WithField s a b) where +instance (Arbitrary a, Arbitrary b) => Arbitrary (WithField s a b) where arbitrary = WithField <$> arbitrary <*> arbitrary -instance (Arbitrary a, Arbitrary b) => Arbitrary (WithFields a b) where +instance (Arbitrary a, Arbitrary b) => Arbitrary (WithFields a b) where arbitrary = WithFields <$> arbitrary <*> arbitrary -instance Arbitrary a => Arbitrary (OnlyField s a) where +instance Arbitrary a => Arbitrary (OnlyField s a) where arbitrary = OnlyField <$> arbitrary -instance Arbitrary Value where +instance Arbitrary Value where arbitrary = oneof [obj, arr] - where + where json = oneof [obj, arr, str, num, bl, nullg] - obj = object <$> listOf ((.=) <$> arbitrary <*> json) + obj = object <$> listOf ((.=) <$> arbitrary <*> json) arr = Array . V.fromList <$> listOf json str = String <$> arbitrary num = fmap Number $ scientific <$> arbitrary <*> arbitrary bl = Bool <$> arbitrary - nullg = pure Null + nullg = pure Null main :: IO () main = defaultMain tests @@ -50,7 +52,7 @@ tests :: TestTree tests = testGroup "Tests" [qcProperties, unitTests] -qcProperties :: TestTree +qcProperties :: TestTree qcProperties = testGroup "Properties" [ withFieldProps , withFieldsProps @@ -58,7 +60,7 @@ , unitDataProps ] -unitTests :: TestTree +unitTests :: TestTree unitTests = testGroup "Unit tests" [ withFieldTests , withFieldsTests @@ -66,22 +68,22 @@ , unitDataTests ] -data TestObj = TestObj !Text +data TestObj = TestObj !Text deriving (Eq, Show) -instance ToJSON TestObj where +instance ToJSON TestObj where toJSON (TestObj t) = object ["field" .= t] -instance FromJSON TestObj where +instance FromJSON TestObj where parseJSON (Object o) = TestObj <$> o .: "field" parseJSON _ = mzero -instance ToSchema TestObj where - declareNamedSchema prx = do +instance ToSchema TestObj where + declareNamedSchema prx = do t <- declareSchema (Proxy :: Proxy Text) - return $ NamedSchema (Just "TestObj") $ mempty + return $ NamedSchema (Just "TestObj") $ mempty & type_ .~ SwaggerObject & properties .~ [("field", Inline t)] & required .~ ["field"] -instance Arbitrary TestObj where +instance Arbitrary TestObj where arbitrary = TestObj <$> arbitrary withFieldTests :: TestTree @@ -89,161 +91,167 @@ testsToJSON , testsFromJSON , testsToSchema + , testsRoundtip ] where testsToJSON = testGroup "toJSON" [ - testCase "Inline mode: atomic field" $ do + testCase "Inline mode: atomic field" $ do let expected = object ["a" .= (0 :: Int), "field" .= ("val" :: Text)] let actual = toJSON (WithField 0 (TestObj "val") :: WithField "a" Int TestObj) expected @=? actual - , testCase "Inline mode: complex field" $ do + , testCase "Inline mode: complex field" $ do let expected = object [ "a" .= object ["field" .= ("key" :: Text)] , "field" .= ("val" :: Text)] - let actual = toJSON (WithField (TestObj "key") (TestObj "val") + let actual = toJSON (WithField (TestObj "key") (TestObj "val") :: WithField "a" TestObj TestObj) expected @=? actual - , testCase "Wrapper mode: atomic" $ do + , testCase "Wrapper mode: atomic" $ do let expected = object ["a" .= (0 :: Int), "value" .= ("val" :: Text)] let actual = toJSON (WithField 0 "val" :: WithField "a" Int String) expected @=? actual - , testCase "Wrapper mode: array" $ do + , testCase "Wrapper mode: array" $ do let expected = object ["a" .= (0 :: Int), "value" .= (["val1", "val2"] :: [Text])] let actual = toJSON (WithField 0 ["val1", "val2"] :: WithField "a" Int [String]) expected @=? actual - , testCase "Wrapper mode: complex field" $ do + , testCase "Wrapper mode: complex field" $ do let expected = object [ "a" .= object ["field" .= ("key" :: Text)] , "value" .= ("val":: Text)] let actual = toJSON (WithField (TestObj "key") "val" :: WithField "a" TestObj String) expected @=? actual - , testCase "Overwrite mode" $ do + , testCase "Overwrite mode" $ do let expected = object ["a" .= (0 :: Int)] let actual = toJSON (WithField 0 (OnlyField "val") :: WithField "a" Int (OnlyField "a" Text)) expected @=? actual - , testCase "Overwrite mode: wrapper" $ do + , testCase "Overwrite mode: wrapper" $ do let expected = object ["value" .= (0 :: Int)] let actual = toJSON (WithField 0 "val" :: WithField "value" Int Text) expected @=? actual ] testsFromJSON = testGroup "fromJSON" [ - testCase "Inline mode: atomic field" $ do + testCase "Inline mode: atomic field" $ do let A.Success (expected :: WithField "a" Int TestObj) = fromJSON $ object [ "a" .= (0 :: Int) , "field" .= ("val" :: Text)] let actual = WithField 0 (TestObj "val") :: WithField "a" Int TestObj expected @=? actual - , testCase "Inline mode: complex field" $ do + , testCase "Inline mode: complex field" $ do let A.Success (expected :: WithField "a" TestObj TestObj) = fromJSON $ object [ "a" .= object ["field" .= ("key" :: Text)] , "field" .= ("val" :: Text)] let actual = WithField (TestObj "key") (TestObj "val") :: WithField "a" TestObj TestObj expected @=? actual - , testCase "Wrapper mode: atomic" $ do + , testCase "Wrapper mode: atomic" $ do let A.Success (expected :: WithField "a" Int String) = fromJSON $ object [ "a" .= (0 :: Int) , "value" .= ("val" :: Text)] let actual = WithField 0 "val" :: WithField "a" Int String expected @=? actual - , testCase "Wrapper mode: array" $ do + , testCase "Wrapper mode: array" $ do let A.Success (expected :: WithField "a" Int [String]) = fromJSON $ object [ "a" .= (0 :: Int) , "value" .= (["val1", "val2"] :: [Text]) ] let actual = WithField 0 ["val1", "val2"] :: WithField "a" Int [String] expected @=? actual - , testCase "Wrapper mode: complex field" $ do + , testCase "Wrapper mode: complex field" $ do let A.Success (expected :: WithField "a" TestObj String) = fromJSON $ object [ "a" .= object ["field" .= ("key" :: Text)] , "value" .= ("val":: Text)] let actual = WithField (TestObj "key") "val" :: WithField "a" TestObj String expected @=? actual - , testCase "Overwrite mode" $ do + , testCase "Overwrite mode" $ do let A.Success (expected :: WithField "a" Int (OnlyField "a" Double)) = fromJSON $ object [ "a" .= (0 :: Int) ] let actual = WithField 0 (OnlyField 0) :: WithField "a" Int (OnlyField "a" Double) expected @=? actual - , testCase "Overwrite mode: wrapper" $ do + , testCase "Overwrite mode: wrapper" $ do let A.Success (expected :: WithField "value" Int Double) = fromJSON $ object [ "value" .= (0 :: Int) ] let actual = WithField 0 0 :: WithField "value" Int Double expected @=? actual ] testsToSchema = testGroup "toSchema" [ - testCase "Inline mode: atomic field" $ do + testCase "Inline mode: atomic field" $ do let expected = [ ("a", Inline $ toSchema (Proxy :: Proxy Int)) , ("field", Inline $ toSchema (Proxy :: Proxy String))] let actual = toSchema (Proxy :: Proxy (WithField "a" Int TestObj)) expected @=? (actual ^. properties) - , testCase "Inline mode: complex field" $ do + , testCase "Inline mode: complex field" $ do let expected = [ ("a", Inline $ toSchema (Proxy :: Proxy TestObj)) , ("field", Inline $ toSchema (Proxy :: Proxy String))] let actual = toSchema (Proxy :: Proxy (WithField "a" TestObj TestObj)) expected @=? (actual ^. properties) - , testCase "Wrapper mode: atomic" $ do + , testCase "Wrapper mode: atomic" $ do let expected = [ ("a", Inline $ toSchema (Proxy :: Proxy Int)) , ("value", Inline $ toSchema (Proxy :: Proxy String))] let actual = toSchema (Proxy :: Proxy (WithField "a" Int String)) expected @=? (actual ^. properties) - , testCase "Wrapper mode: array" $ do + , testCase "Wrapper mode: array" $ do let expected = [ ("a", Inline $ toSchema (Proxy :: Proxy Int)) , ("value", Inline $ toSchema (Proxy :: Proxy [String]))] let actual = toSchema (Proxy :: Proxy (WithField "a" Int [String])) expected @=? (actual ^. properties) - , testCase "Wrapper mode: complex field" $ do + , testCase "Wrapper mode: complex field" $ do let expected = [ ("a", Inline $ toSchema (Proxy :: Proxy TestObj)) , ("value", Inline $ toSchema (Proxy :: Proxy String))] let actual = toSchema (Proxy :: Proxy (WithField "a" TestObj String)) expected @=? (actual ^. properties) - , testCase "Overwrite mode" $ do + , testCase "Overwrite mode" $ do let expected = [("a", Inline $ toSchema (Proxy :: Proxy Int))] let actual = toSchema (Proxy :: Proxy (WithField "a" Int (OnlyField "a" Text))) expected @=? (actual ^. properties) - , testCase "Overwrite mode: wrapper" $ do + , testCase "Overwrite mode: wrapper" $ do let expected = [("value", Inline $ toSchema (Proxy :: Proxy Int))] let actual = toSchema (Proxy :: Proxy (WithField "value" Int Text)) expected @=? (actual ^. properties) ] + testsRoundtip = testGroup "roundtip" [ + testCase "Map Bool Int" $ do -- Issue #1 + let val = WithField 10 (Map.fromList [(True, 20), (False, 30)]) :: WithField "foo" Int (Map.Map Bool Int) + Right val @=? (parseEither parseJSON . toJSON $ val) + ] -data TestObj1 a = TestObj1 !a +data TestObj1 a = TestObj1 !a deriving (Eq, Show) -instance ToJSON a => ToJSON (TestObj1 a) where +instance ToJSON a => ToJSON (TestObj1 a) where toJSON (TestObj1 t) = object ["field1" .= t] -instance FromJSON a => FromJSON (TestObj1 a) where +instance FromJSON a => FromJSON (TestObj1 a) where parseJSON (Object o) = TestObj1 <$> o .: "field1" parseJSON _ = mzero -instance (ToSchema a, Typeable a) => ToSchema (TestObj1 a) where - declareNamedSchema prx = do +instance (ToSchema a, Typeable a) => ToSchema (TestObj1 a) where + declareNamedSchema prx = do t <- declareSchema (Proxy :: Proxy a) let nm = pack . show $ typeRep (Proxy :: Proxy a) - return $ NamedSchema (Just $ "TestObj1'" <> nm) $ mempty + return $ NamedSchema (Just $ "TestObj1'" <> nm) $ mempty & type_ .~ SwaggerObject & properties .~ [("field1", Inline t)] & required .~ ["field1"] -instance Arbitrary a => Arbitrary (TestObj1 a) where +instance Arbitrary a => Arbitrary (TestObj1 a) where arbitrary = TestObj1 <$> arbitrary -data TestObj2 = TestObj2 !Text +data TestObj2 = TestObj2 !Text deriving (Eq, Show) -instance ToJSON TestObj2 where +instance ToJSON TestObj2 where toJSON (TestObj2 t) = object ["field2" .= t] -instance FromJSON TestObj2 where +instance FromJSON TestObj2 where parseJSON (Object o) = TestObj2 <$> o .: "field2" parseJSON _ = mzero -instance ToSchema TestObj2 where - declareNamedSchema prx = do +instance ToSchema TestObj2 where + declareNamedSchema prx = do t <- declareSchema (Proxy :: Proxy Text) - return $ NamedSchema (Just "TestObj2") $ mempty + return $ NamedSchema (Just "TestObj2") $ mempty & type_ .~ SwaggerObject & properties .~ [("field2", Inline t)] & required .~ ["field2"] -instance Arbitrary TestObj2 where +instance Arbitrary TestObj2 where arbitrary = TestObj2 <$> arbitrary withFieldsTests :: TestTree @@ -251,125 +259,134 @@ testsToJSON , testsFromJSON , testsToSchema + , testsRoundtip ] where testsToJSON = testGroup "toJSON" [ - testCase "Inline mode" $ do + testCase "Inline mode" $ do let expected = object [ "field1" .= ("val1" :: Text) , "field2" .= ("val2" :: Text) ] let actual = toJSON (WithFields (TestObj1 "val1" :: TestObj1 Text) (TestObj2 "val2")) expected @=? actual - , testCase "Wrapper mode: first" $ do + , testCase "Wrapper mode: first" $ do let expected = object [ "injected" .= ("val1" :: Text) , "field2" .= ("val2" :: Text) ] let actual = toJSON (WithFields ("val1" :: Text) (TestObj2 "val2")) expected @=? actual - , testCase "Wrapper mode: second" $ do + , testCase "Wrapper mode: second" $ do let expected = object [ "field1" .= ("val1" :: Text) , "value" .= ("val2" :: Text) ] let actual = toJSON (WithFields (TestObj1 "val1" :: TestObj1 Text) ("val2" :: Text)) expected @=? actual - , testCase "Wrapper mode: both" $ do + , testCase "Wrapper mode: both" $ do let expected = object [ "injected" .= ("val1" :: Text) , "value" .= ("val2" :: Text) ] let actual = toJSON (WithFields ("val1" :: Text) ("val2" :: Text)) expected @=? actual - , testCase "Overwrite mode" $ do + , testCase "Overwrite mode" $ do let expected = object ["field1" .= ("val1" :: Text) ] let actual = toJSON (WithFields (TestObj1 "val1" :: TestObj1 Text) (TestObj1 "val2" :: TestObj1 Text)) expected @=? actual - , testCase "Overwrite mode: wrapper first" $ do + , testCase "Overwrite mode: wrapper first" $ do let expected = object ["injected" .= ("val1" :: Text) ] let actual = toJSON (WithFields ("val1" :: Text) (OnlyField "val2" :: OnlyField "injected" Text)) expected @=? actual - , testCase "Overwrite mode: wrapper second" $ do + , testCase "Overwrite mode: wrapper second" $ do let expected = object ["value" .= ("val1" :: Text) ] let actual = toJSON (WithFields (OnlyField "val1" :: OnlyField "value" Text) ("val2" :: Text)) expected @=? actual ] testsFromJSON = testGroup "fromJSON" [ - testCase "Inline mode" $ do + testCase "Inline mode" $ do let A.Success (expected :: WithFields (TestObj1 Text) TestObj2) = fromJSON $ object [ "field1" .= ("val1" :: Text) , "field2" .= ("val2" :: Text)] let actual = WithFields (TestObj1 "val1") (TestObj2 "val2") expected @=? actual - , testCase "Wrapper mode: first" $ do + , testCase "Wrapper mode: first" $ do let A.Success (expected :: WithFields Text TestObj2) = fromJSON $ object [ "injected" .= ("val1" :: Text) , "field2" .= ("val2" :: Text)] let actual = WithFields ("val1" :: Text) (TestObj2 "val2") expected @=? actual - , testCase "Wrapper mode: second" $ do + , testCase "Wrapper mode: second" $ do let A.Success (expected :: WithFields (TestObj1 Text) Text) = fromJSON $ object [ "field1" .= ("val1" :: Text) , "value" .= ("val2" :: Text)] let actual = WithFields (TestObj1 "val1") ("val2" :: Text) expected @=? actual - , testCase "Wrapper mode: both" $ do + , testCase "Wrapper mode: both" $ do let A.Success (expected :: WithFields Text Text) = fromJSON $ object [ "injected" .= ("val1" :: Text) , "value" .= ("val2" :: Text)] let actual = WithFields ("val1" :: Text) ("val2" :: Text) expected @=? actual - , testCase "Overwrite mode" $ do + , testCase "Overwrite mode" $ do let A.Success (expected :: WithFields (TestObj1 Text) (TestObj1 Text)) = fromJSON $ object [ "field1" .= ("val1" :: Text) ] let actual = WithFields (TestObj1 "val1") (TestObj1 "val1") expected @=? actual - , testCase "Overwrite mode: wrapper first" $ do + , testCase "Overwrite mode: wrapper first" $ do let A.Success (expected :: WithFields Text (OnlyField "injected" Text)) = fromJSON $ object [ "injected" .= ("val1" :: Text) ] let actual = WithFields "val1" (OnlyField "val1" :: OnlyField "injected" Text) expected @=? actual - , testCase "Overwrite mode: wrapper second" $ do + , testCase "Overwrite mode: wrapper second" $ do let A.Success (expected :: WithFields (OnlyField "value" Text) Text) = fromJSON $ object [ "value" .= ("val1" :: Text) ] - let actual = WithFields (OnlyField "val1" :: OnlyField "value" Text) "val1" + let actual = WithFields (OnlyField "val1" :: OnlyField "value" Text) "val1" expected @=? actual ] testsToSchema = testGroup "toSchema" [ - testCase "Inline mode" $ do + testCase "Inline mode" $ do let expected = [ ("field1", Inline $ toSchema (Proxy :: Proxy Text)) , ("field2", Inline $ toSchema (Proxy :: Proxy Text))] let actual = toSchema (Proxy :: Proxy (WithFields (TestObj1 Text) TestObj2)) expected @=? (actual ^. properties) - , testCase "Wrapper mode: first" $ do + , testCase "Wrapper mode: first" $ do let expected = [ ("injected", Inline $ toSchema (Proxy :: Proxy Text)) , ("field2", Inline $ toSchema (Proxy :: Proxy Text))] let actual = toSchema (Proxy :: Proxy (WithFields Text TestObj2)) expected @=? (actual ^. properties) - , testCase "Wrapper mode: second" $ do + , testCase "Wrapper mode: second" $ do let expected = [ ("field1", Inline $ toSchema (Proxy :: Proxy Text)) , ("value", Inline $ toSchema (Proxy :: Proxy Text))] let actual = toSchema (Proxy :: Proxy (WithFields (TestObj1 Text) Text)) expected @=? (actual ^. properties) - , testCase "Wrapper mode: both" $ do + , testCase "Wrapper mode: both" $ do let expected = [ ("injected", Inline $ toSchema (Proxy :: Proxy Text)) , ("value", Inline $ toSchema (Proxy :: Proxy Text))] let actual = toSchema (Proxy :: Proxy (WithFields Text Text)) expected @=? (actual ^. properties) - , testCase "Overwrite mode" $ do + , testCase "Overwrite mode" $ do let expected = [("field1", Inline $ toSchema (Proxy :: Proxy Text))] let actual = toSchema (Proxy :: Proxy (WithFields (TestObj1 Text) (TestObj1 Int))) expected @=? (actual ^. properties) - , testCase "Overwrite mode: wrapper first" $ do + , testCase "Overwrite mode: wrapper first" $ do let expected = [("injected", Inline $ toSchema (Proxy :: Proxy Text))] let actual = toSchema (Proxy :: Proxy (WithFields Text (OnlyField "injected" Int))) expected @=? (actual ^. properties) - , testCase "Overwrite mode: wrapper second" $ do + , testCase "Overwrite mode: wrapper second" $ do let expected = [("value", Inline $ toSchema (Proxy :: Proxy Int))] let actual = toSchema (Proxy :: Proxy (WithFields (OnlyField "value" Int) Text)) expected @=? (actual ^. properties) ] + testsRoundtip = testGroup "roundtip" [ + testCase "Map Bool Int, one field" $ do -- Issue #1 + let val = WithFields (TestObj1 10) (Map.fromList [(True, 20), (False, 30)]) :: WithFields (TestObj1 Int) (Map.Map Bool Int) + Right val @=? (parseEither parseJSON . toJSON $ val) + , testCase "Map Bool Int, two fields" $ do -- Issue #1 + let val = WithFields (WithFields (TestObj1 10) (TestObj2 "Blah")) (Map.fromList [(True, 20), (False, 30)]) :: WithFields (WithFields (TestObj1 Int) TestObj2) (Map.Map Bool Int) + Right val @=? (parseEither parseJSON . toJSON $ val) + ] onlyFieldTests :: TestTree onlyFieldTests = testGroup "OnlyField tests" [ @@ -377,22 +394,22 @@ , testsFromJSON , testsToSchema ] - where + where testsToJSON = testGroup "toJSON" [ - testCase "Normal mode" $ do + testCase "Normal mode" $ do let expected = object [ "a" .= (42 :: Int) ] let actual = toJSON (OnlyField 42 :: OnlyField "a" Int) expected @=? actual ] testsFromJSON = testGroup "FromJSON" [ - testCase "Normal mode" $ do + testCase "Normal mode" $ do let expected = OnlyField 42 :: OnlyField "a" Int - let (A.Success (actual :: OnlyField "a" Int)) = fromJSON $ object [ + let (A.Success (actual :: OnlyField "a" Int)) = fromJSON $ object [ "a" .= (42 :: Int) ] expected @=? actual ] testsToSchema = testGroup "ToSchema" [ - testCase "Normal mode" $ do + testCase "Normal mode" $ do let expected = [ ("a", Inline $ toSchema (Proxy :: Proxy Int)) ] let actual = toSchema (Proxy :: Proxy (OnlyField "a" Int)) @@ -401,25 +418,25 @@ unitDataTests :: TestTree unitDataTests = testGroup "Unit tests" [ - testsToJSON - , testsFromJSON + testsToJSON + , testsFromJSON , testsToSchema ] - where + where testsToJSON = testGroup "toJSON" [ - testCase "Normal mode" $ do + testCase "Normal mode" $ do let expected = object [ ] let actual = toJSON Unit expected @=? actual ] testsFromJSON = testGroup "FromJSON" [ - testCase "Normal mode" $ do + testCase "Normal mode" $ do let expected = Unit let (A.Success (actual :: Unit)) = fromJSON $ object [ ] expected @=? actual ] testsToSchema = testGroup "ToSchema" [ - testCase "Normal mode" $ do + testCase "Normal mode" $ do let expected = NamedSchema Nothing $ mempty & type_ .~ SwaggerObject let actual = toNamedSchema (Proxy :: Proxy Unit) expected @=? actual @@ -430,37 +447,37 @@ functorProps , bifunctorProps ] - where - functorProps = QC.testProperty "fmap id == id" $ \(wf :: WithField "id" Int TestObj) -> - fmap id wf == wf - bifunctorProps = QC.testProperty "bimap id id == id" $ \(wf :: WithField "id" Int TestObj) -> - bimap id id wf == wf + where + functorProps = QC.testProperty "fmap id == id" $ \(wf :: WithField "id" Int TestObj) -> + fmap id wf == wf + bifunctorProps = QC.testProperty "bimap id id == id" $ \(wf :: WithField "id" Int TestObj) -> + bimap id id wf == wf withFieldsProps :: TestTree withFieldsProps = testGroup "withFields properties" [ functorProps , bifunctorProps ] - where - functorProps = QC.testProperty "fmap id == id" $ \(wf :: WithFields (TestObj1 Text) TestObj2) -> - fmap id wf == wf - bifunctorProps = QC.testProperty "bimap id id == id" $ \(wf :: WithFields (TestObj1 Text) TestObj2) -> - bimap id id wf == wf + where + functorProps = QC.testProperty "fmap id == id" $ \(wf :: WithFields (TestObj1 Text) TestObj2) -> + fmap id wf == wf + bifunctorProps = QC.testProperty "bimap id id == id" $ \(wf :: WithFields (TestObj1 Text) TestObj2) -> + bimap id id wf == wf -onlyFieldProps :: TestTree +onlyFieldProps :: TestTree onlyFieldProps = testGroup "onlyField properties" [ functorProps ] - where - functorProps = QC.testProperty "fmap id == id" $ \(wf :: OnlyField "id" TestObj) -> + where + functorProps = QC.testProperty "fmap id == id" $ \(wf :: OnlyField "id" TestObj) -> fmap id wf == wf -unitDataProps :: TestTree +unitDataProps :: TestTree unitDataProps = testGroup "Unit properties" [ parseProps ] - where - parseProps = QC.testProperty "parseJSON Unit not fails" $ \(json :: Value) -> - case fromJSON json of - A.Success Unit -> True - _ -> False + where + parseProps = QC.testProperty "parseJSON Unit not fails" $ \(json :: Value) -> + case fromJSON json of + A.Success Unit -> True + _ -> False