aeson-injector 1.0.5.0 → 1.0.5.1
raw patch · 3 files changed
+102/−26 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- aeson-injector.cabal +1/−1
- src/Data/Aeson/WithField.hs +18/−10
- test/Main.hs +83/−15
aeson-injector.cabal view
@@ -1,5 +1,5 @@ name: aeson-injector-version: 1.0.5.0+version: 1.0.5.1 synopsis: Injecting fields into aeson values description: See README.md license: MIT
src/Data/Aeson/WithField.hs view
@@ -172,6 +172,7 @@ import Servant.Docs 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@@ -189,6 +190,8 @@ -- -- >>> encode (WithField "val" 42 :: WithField "injected" String Int) -- "{\"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 deriving (Generic, Eq, Show, Read) @@ -227,8 +230,8 @@ in case toJSON b of Object vs -> Object $ H.insert field (toJSON a) vs _ -> object [- field .= a - , "value" .= jsonb+ "value" .= jsonb+ , field .= a ] -- | Note: the instance tries to parse the json as object with @@ -262,10 +265,10 @@ return $ NamedSchema (fmap (namePrefix <>) n) $ mempty & type_ .~ SwaggerObject & properties .~- [ (field, Inline indexSchema)- , ("value", Inline s)+ [ ("value", Inline s)+ , (field, Inline indexSchema) ]- & required .~ [ field, "value" ]+ & required .~ (L.nub [ "value", field ]) inline n s = do indexSchema <- declareSchema (Proxy :: Proxy a) return $ NamedSchema (fmap (namePrefix <>) n) $ s@@ -316,6 +319,9 @@ -- "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 +-- produced by `a`. instance (ToJSON a, ToJSON b) => ToJSON (WithFields a b) where toJSON (WithFields a b) = let jsonb = toJSON b @@ -325,7 +331,9 @@ Object avs -> Object $ H.union avs bvs _ -> Object $ H.insert "injected" jsona bvs _ -> case jsona of - Object avs -> Object $ H.insert "value" jsonb avs+ Object avs -> Object $ case H.lookup "value" avs of+ Nothing -> H.insert "value" jsonb avs+ Just _ -> avs _ -> object [ "injected" .= jsona , "value" .= jsonb@@ -349,10 +357,10 @@ NamedSchema na sa <- declareNamedSchema (Proxy :: Proxy a) let newName = combinedName <$> na <*> nb return . NamedSchema newName $ case (sa ^. type_ , sb ^. type_) of - (SwaggerObject, SwaggerObject) -> sa <> sb - (SwaggerObject, _) -> sa <> bwrapper sb- (_, SwaggerObject) -> awrapper sa <> sb- _ -> awrapper sa <> bwrapper sb+ (SwaggerObject, SwaggerObject) -> sb <> sa + (SwaggerObject, _) -> bwrapper sb <> sa+ (_, SwaggerObject) -> sb <> awrapper sa+ _ -> bwrapper sb <> awrapper sa where combinedName a b = "WithFields_" <> a <> "_" <> b awrapper nas = mempty
test/Main.hs view
@@ -10,12 +10,14 @@ import Data.Aeson as A import Data.Aeson.Unit import Data.Aeson.WithField+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 Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck as QC@@ -115,6 +117,14 @@ , "value" .= ("val":: Text)] let actual = toJSON (WithField (TestObj "key") "val" :: WithField "a" TestObj String) expected @=? actual+ , 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 + 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 @@ -147,6 +157,16 @@ , "value" .= ("val":: Text)] let actual = WithField (TestObj "key") "val" :: WithField "a" TestObj String expected @=? actual+ , 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 + 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 @@ -179,24 +199,33 @@ , ("value", Inline $ toSchema (Proxy :: Proxy String))] let actual = toSchema (Proxy :: Proxy (WithField "a" TestObj String)) expected @=? (actual ^. properties)+ , 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 + let expected = [("value", Inline $ toSchema (Proxy :: Proxy Int))]+ let actual = toSchema (Proxy :: Proxy (WithField "value" Int Text))+ expected @=? (actual ^. properties) ] -data TestObj1 = TestObj1 !Text +data TestObj1 a = TestObj1 !a deriving (Eq, Show) -instance ToJSON TestObj1 where +instance ToJSON a => ToJSON (TestObj1 a) where toJSON (TestObj1 t) = object ["field1" .= t]-instance FromJSON TestObj1 where +instance FromJSON a => FromJSON (TestObj1 a) where parseJSON (Object o) = TestObj1 <$> o .: "field1" parseJSON _ = mzero-instance ToSchema TestObj1 where +instance (ToSchema a, Typeable a) => ToSchema (TestObj1 a) where declareNamedSchema prx = do - t <- declareSchema (Proxy :: Proxy Text)- return $ NamedSchema (Just "TestObj1") $ mempty + t <- declareSchema (Proxy :: Proxy a)+ let nm = pack . show $ typeRep (Proxy :: Proxy a)+ return $ NamedSchema (Just $ "TestObj1'" <> nm) $ mempty & type_ .~ SwaggerObject & properties .~ [("field1", Inline t)] & required .~ ["field1"]-instance Arbitrary TestObj1 where +instance Arbitrary a => Arbitrary (TestObj1 a) where arbitrary = TestObj1 <$> arbitrary data TestObj2 = TestObj2 !Text @@ -229,7 +258,7 @@ let expected = object [ "field1" .= ("val1" :: Text) , "field2" .= ("val2" :: Text) ]- let actual = toJSON (WithFields (TestObj1 "val1") (TestObj2 "val2"))+ let actual = toJSON (WithFields (TestObj1 "val1" :: TestObj1 Text) (TestObj2 "val2")) expected @=? actual , testCase "Wrapper mode: first" $ do let expected = object [@@ -241,7 +270,7 @@ let expected = object [ "field1" .= ("val1" :: Text) , "value" .= ("val2" :: Text) ]- let actual = toJSON (WithFields (TestObj1 "val1") ("val2" :: Text))+ let actual = toJSON (WithFields (TestObj1 "val1" :: TestObj1 Text) ("val2" :: Text)) expected @=? actual , testCase "Wrapper mode: both" $ do let expected = object [@@ -249,10 +278,22 @@ , "value" .= ("val2" :: Text) ] let actual = toJSON (WithFields ("val1" :: Text) ("val2" :: Text)) expected @=? actual+ , 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 + 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 + 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 - let A.Success (expected :: WithFields TestObj1 TestObj2) = fromJSON $ object [+ let A.Success (expected :: WithFields (TestObj1 Text) TestObj2) = fromJSON $ object [ "field1" .= ("val1" :: Text) , "field2" .= ("val2" :: Text)] let actual = WithFields (TestObj1 "val1") (TestObj2 "val2")@@ -264,7 +305,7 @@ let actual = WithFields ("val1" :: Text) (TestObj2 "val2") expected @=? actual , testCase "Wrapper mode: second" $ do - let A.Success (expected :: WithFields TestObj1 Text) = fromJSON $ object [+ let A.Success (expected :: WithFields (TestObj1 Text) Text) = fromJSON $ object [ "field1" .= ("val1" :: Text) , "value" .= ("val2" :: Text)] let actual = WithFields (TestObj1 "val1") ("val2" :: Text)@@ -275,13 +316,28 @@ , "value" .= ("val2" :: Text)] let actual = WithFields ("val1" :: Text) ("val2" :: Text) expected @=? actual+ , 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 + 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 + let A.Success (expected :: WithFields (OnlyField "value" Text) Text) = fromJSON $ object [+ "value" .= ("val1" :: Text) ]+ let actual = WithFields (OnlyField "val1" :: OnlyField "value" Text) "val1" + expected @=? actual ] testsToSchema = testGroup "toSchema" [ 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 TestObj2))+ let actual = toSchema (Proxy :: Proxy (WithFields (TestObj1 Text) TestObj2)) expected @=? (actual ^. properties) , testCase "Wrapper mode: first" $ do let expected = [@@ -293,7 +349,7 @@ let expected = [ ("field1", Inline $ toSchema (Proxy :: Proxy Text)) , ("value", Inline $ toSchema (Proxy :: Proxy Text))]- let actual = toSchema (Proxy :: Proxy (WithFields TestObj1 Text))+ let actual = toSchema (Proxy :: Proxy (WithFields (TestObj1 Text) Text)) expected @=? (actual ^. properties) , testCase "Wrapper mode: both" $ do let expected = [@@ -301,6 +357,18 @@ , ("value", Inline $ toSchema (Proxy :: Proxy Text))] let actual = toSchema (Proxy :: Proxy (WithFields Text Text)) expected @=? (actual ^. properties)+ , 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 + 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 + let expected = [("value", Inline $ toSchema (Proxy :: Proxy Int))]+ let actual = toSchema (Proxy :: Proxy (WithFields (OnlyField "value" Int) Text))+ expected @=? (actual ^. properties) ] onlyFieldTests :: TestTree@@ -374,9 +442,9 @@ , bifunctorProps ] where - functorProps = QC.testProperty "fmap id == id" $ \(wf :: WithFields TestObj1 TestObj2) -> + 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 TestObj2) -> + bifunctorProps = QC.testProperty "bimap id id == id" $ \(wf :: WithFields (TestObj1 Text) TestObj2) -> bimap id id wf == wf onlyFieldProps :: TestTree