aeson-injector 1.0.10.0 → 1.1.0.0
raw patch · 4 files changed
+270/−220 lines, 4 filesdep +containersdep +hashablePVP ok
version bump matches the API change (PVP)
Dependencies added: containers, hashable
API changes (from Hackage documentation)
- Data.Aeson.WithField: instance (Data.Aeson.Types.FromJSON.FromJSON a, Data.Aeson.Types.FromJSON.FromJSON b) => Data.Aeson.Types.FromJSON.FromJSON (Data.Aeson.WithField.WithFields a b)
+ Data.Aeson.WithField: instance (Data.Aeson.Types.ToJSON.ToJSON a, Data.Aeson.Types.FromJSON.FromJSON a, Data.Aeson.Types.FromJSON.FromJSON b) => Data.Aeson.Types.FromJSON.FromJSON (Data.Aeson.WithField.WithFields a b)
Files
- CHANGELOG.md +6/−0
- aeson-injector.cabal +6/−3
- src/Data/Aeson/WithField.hs +132/−108
- test/Main.hs +126/−109
CHANGELOG.md view
@@ -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 ========
aeson-injector.cabal view
@@ -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
src/Data/Aeson/WithField.hs view
@@ -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 <http://haskell-servant.readthedocs.io/en/stable/ servant> -and <http://swagger.io/ Swagger>. Its main purpose is simple injection of -fields into JSONs produced by <https://hackage.haskell.org/package/aeson aeson> +It is small utility library that is intented to be used in RESTful APIs,+especially with <http://haskell-servant.readthedocs.io/en/stable/ servant>+and <http://swagger.io/ Swagger>. Its main purpose is simple injection of+fields into JSONs produced by <https://hackage.haskell.org/package/aeson aeson> 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 <https://hackage.haskell.org/package/servant-swagger servant-swagger> 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)
test/Main.hs view
@@ -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