diff --git a/aeson-injector.cabal b/aeson-injector.cabal --- a/aeson-injector.cabal +++ b/aeson-injector.cabal @@ -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 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 @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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