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.2.0.0 +version: 2.0.0.0 synopsis: Injecting fields into aeson values description: It is small utility library that is intented to be used in RESTful APIs, especially with [servant](http://haskell-servant.readthedocs.io/en/stable/) and [Swagger](http://swagger.io/). Its main purpose is simple injection of fields into JSONs produced by [aeson](https://hackage.haskell.org/package/aeson) library. license: MIT @@ -11,10 +11,9 @@ build-type: Simple cabal-version: 1.18 tested-with: - GHC == 8.4.3 - , GHC == 8.6.5 - , GHC == 8.8.1 + GHC == 8.8.1 , GHC == 8.10.7 + , GHC == 9.0.2 extra-source-files: README.md CHANGELOG.md @@ -33,7 +32,7 @@ build-depends: base >= 4.7 && < 4.17 - , aeson >= 0.11 && < 1.6 + , aeson >= 2.1 && < 2.2 , attoparsec >= 0.14 && < 0.15 , bifunctors >= 5.2 && < 6 , deepseq >= 1.4 && < 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 @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,6 +8,7 @@ {-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-| Module : Data.Aeson.WithField @@ -167,6 +169,8 @@ import Control.Monad import Data.Aeson import Data.Aeson.Types (typeMismatch) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KM import Data.Aeson.WithField.Internal import Data.Hashable import Data.Monoid @@ -177,7 +181,6 @@ import Servant.Docs 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 @@ -232,9 +235,9 @@ instance (KnownSymbol s, ToJSON a, ToJSON b) => ToJSON (WithField s a b) where toJSON (WithField a b) = let jsonb = toJSON b - field = T.pack $ symbolVal (Proxy :: Proxy s) + field = mkFieldName @s in case toJSON b of - Object vs -> Object $ H.insert field (toJSON a) vs + Object vs -> Object $ KM.insert field (toJSON a) vs _ -> object [ "value" .= jsonb , field .= a @@ -249,10 +252,10 @@ instance (KnownSymbol s, FromJSON a, FromJSON b) => FromJSON (WithField s a b) where parseJSON val@(Object o) = injected `mplus0` wrapper where - field = T.pack $ symbolVal (Proxy :: Proxy s) + field = mkFieldName @s injected = WithField <$> o .: field - <*> (parseJSON (Object $ H.delete field o) <|> parseJSON val) + <*> (parseJSON (Object $ KM.delete field o) <|> parseJSON val) wrapper = WithField <$> o .: field <*> o .: "value" @@ -337,11 +340,11 @@ jsona = toJSON a in case jsonb of Object bvs -> case jsona of - Object avs -> Object $ H.union avs bvs - _ -> Object $ H.insert "injected" jsona bvs + Object avs -> Object $ KM.union avs bvs + _ -> Object $ KM.insert "injected" jsona bvs _ -> case jsona of - Object avs -> Object $ case H.lookup "value" avs of - Nothing -> H.insert "value" jsonb avs + Object avs -> Object $ case KM.lookup "value" avs of + Nothing -> KM.insert "value" jsonb avs Just _ -> avs _ -> object [ "injected" .= jsona @@ -360,17 +363,17 @@ instance (ToJSON a, FromJSON a, FromJSON b) => FromJSON (WithFields a b) where parseJSON val@(Object o) = do (a, isInjected) <- ((, False) <$> parseJSON val) `mplus0` ((, True) <$> (o .: "injected")) - let o' = (if isInjected then H.delete "injected" else deleteAll (extractFields a)) o + let o' = (if isInjected then KM.delete "injected" else deleteAll (extractFields a)) o b <- ((parseJSON (Object o')) `mplus0` (o' .: "value")) <|> ((parseJSON val) `mplus0` (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 + deleteAll :: [Key.Key] -> KM.KeyMap v -> KM.KeyMap v + deleteAll ks m = F.foldl' (flip KM.delete) m ks - extractFields :: ToJSON a => a -> [T.Text] + extractFields :: ToJSON a => a -> [Key.Key] extractFields a = case toJSON a of - Object vs -> H.keys vs + Object vs -> KM.keys vs _ -> [] parseJSON wat = typeMismatch "Expected JSON Object" wat @@ -425,24 +428,23 @@ as = snd <$> toSamples (Proxy :: Proxy a) instance (KnownSymbol s, ToJSON a) => ToJSON (OnlyField s a) where - toJSON (OnlyField a) = object [ field .= a ] - where - field = T.pack $ symbolVal (Proxy :: Proxy s) + toJSON (OnlyField a) = object [ mkFieldName @s .= a ] 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 (Object o) = OnlyField <$> o .: (mkFieldName @s) parseJSON _ = mzero instance (KnownSymbol s, ToSchema a) => ToSchema (OnlyField s a) where declareNamedSchema _ = do NamedSchema an as <- declareNamedSchema (Proxy :: Proxy a) - let namePrefix = "OnlyField '" <> field <> "' " + let namePrefix = "OnlyField '" <> Key.toText field <> "' " return $ NamedSchema (fmap (namePrefix <>) an) $ mempty & type_ .~ Just SwaggerObject - & properties .~ [(field, Inline as)] - & required .~ [field] + & properties .~ [(Key.toText field, Inline as)] + & required .~ [Key.toText field] where - field = T.pack $ symbolVal (Proxy :: Proxy s) + field = mkFieldName @s + +mkFieldName :: forall s . KnownSymbol s => Key.Key +mkFieldName = Key.fromString $ symbolVal (Proxy :: Proxy s) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -36,17 +36,6 @@ instance Arbitrary a => Arbitrary (OnlyField s a) where arbitrary = OnlyField <$> arbitrary -instance Arbitrary Value where - arbitrary = oneof [obj, arr] - where - json = oneof [obj, arr, str, num, bl, nullg] - 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 - main :: IO () main = defaultMain tests