aeson-injector 1.1.6.0 → 2.0.0.0
raw patch · 5 files changed
Files
- CHANGELOG.md +5/−0
- aeson-injector.cabal +6/−5
- src/Data/Aeson/WithField.hs +33/−28
- src/Data/Aeson/WithField/Internal.hs +25/−0
- test/Main.hs +0/−11
CHANGELOG.md view
@@ -1,3 +1,8 @@+1.2.0.0+=======++- Fixes issue #3 with unexpected errors when injected value fails to parse.+ 1.1.6.0 =======
aeson-injector.cabal view
@@ -1,5 +1,5 @@ name: aeson-injector-version: 1.1.6.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@@ -29,10 +28,12 @@ exposed-modules: Data.Aeson.Unit Data.Aeson.WithField+ Data.Aeson.WithField.Internal 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 , hashable >= 1.0 && < 2.0
src/Data/Aeson/WithField.hs view
@@ -1,11 +1,14 @@+{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-| Module : Data.Aeson.WithField@@ -166,6 +169,9 @@ 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 import Data.Proxy@@ -175,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 @@ -230,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@@ -245,12 +250,12 @@ -- 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+ 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"@@ -335,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@@ -357,18 +362,18 @@ -- 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")+ (a, isInjected) <- ((, False) <$> parseJSON val) `mplus0` ((, True) <$> (o .: "injected"))+ 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 @@ -423,23 +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)+
+ src/Data/Aeson/WithField/Internal.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+module Data.Aeson.WithField.Internal+ ( mplus0+ ) where++import Data.Aeson.Types (Parser, JSONPath)++import Unsafe.Coerce++newtype P a = P + { runP :: forall f r.+ JSONPath+ -> Failure f r+ -> Success a f r+ -> f r }++type Failure f r = JSONPath -> String -> f r+type Success a f r = a -> f r++mplus0 :: forall a . Parser a -> Parser a -> Parser a+mplus0 a b = unsafeCoerce @(P a) $ P $ \path kf ks -> + let kf' p l = runP (unsafeCoerce b) path (\_ _ -> kf p l) ks+ in runP (unsafeCoerce a) path kf' ks
test/Main.hs view
@@ -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