{-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} module Data.JsonRpc.Generic ( GFromArrayJSON, genericParseJSONRPC, GFieldSetJSON, genericFieldSetParseJSON, JsonRpcOptions (..), defaultJsonRpcOptions, GToArrayJSON, genericToArrayJSON, ) where import GHC.Generics import Control.Applicative ((<$>), (<*>), (<*), empty, (<|>)) import Control.Monad (guard) import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.Writer (Writer, runWriter, tell) import Control.Monad.Trans.State (StateT, runStateT, get, put) import Data.Monoid (Endo (..)) import Data.Set ((\\)) import qualified Data.Set as Set import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T import Data.Aeson.Types (FromJSON (..), ToJSON (..), genericParseJSON, Parser, Options (..), Value (..)) import Data.Aeson.Generic.Compat (GFromJSON0) import Data.Vector (Vector) import qualified Data.Vector as Vector class GFromArrayJSON f where gFromArrayJSON :: StateT [Value] Parser (f a) instance GFromArrayJSON U1 where gFromArrayJSON :: StateT [Value] Parser (U1 a) gFromArrayJSON = U1 a -> StateT [Value] Parser (U1 a) forall (m :: * -> *) a. Monad m => a -> m a return U1 a forall k (p :: k). U1 p U1 instance (GFromArrayJSON a, GFromArrayJSON b) => GFromArrayJSON (a :*: b) where gFromArrayJSON :: StateT [Value] Parser ((:*:) a b a) gFromArrayJSON = a a -> b a -> (:*:) a b a forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> g p -> (:*:) f g p (:*:) (a a -> b a -> (:*:) a b a) -> StateT [Value] Parser (a a) -> StateT [Value] Parser (b a -> (:*:) a b a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StateT [Value] Parser (a a) forall (f :: * -> *) a. GFromArrayJSON f => StateT [Value] Parser (f a) gFromArrayJSON StateT [Value] Parser (b a -> (:*:) a b a) -> StateT [Value] Parser (b a) -> StateT [Value] Parser ((:*:) a b a) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> StateT [Value] Parser (b a) forall (f :: * -> *) a. GFromArrayJSON f => StateT [Value] Parser (f a) gFromArrayJSON instance GFromArrayJSON a => GFromArrayJSON (M1 i c a) where gFromArrayJSON :: StateT [Value] Parser (M1 i c a a) gFromArrayJSON = a a -> M1 i c a a forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p M1 (a a -> M1 i c a a) -> StateT [Value] Parser (a a) -> StateT [Value] Parser (M1 i c a a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> StateT [Value] Parser (a a) forall (f :: * -> *) a. GFromArrayJSON f => StateT [Value] Parser (f a) gFromArrayJSON instance FromJSON a => GFromArrayJSON (K1 i a) where gFromArrayJSON :: StateT [Value] Parser (K1 i a a) gFromArrayJSON = do [Value] vs' <- StateT [Value] Parser [Value] forall (m :: * -> *) s. Monad m => StateT s m s get a -> K1 i a a forall k i c (p :: k). c -> K1 i c p K1 (a -> K1 i a a) -> StateT [Value] Parser a -> StateT [Value] Parser (K1 i a a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> case [Value] vs' of Value v:[Value] vs -> (Parser a -> StateT [Value] Parser a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (Parser a -> StateT [Value] Parser a) -> Parser a -> StateT [Value] Parser a forall a b. (a -> b) -> a -> b $ Value -> Parser a forall a. FromJSON a => Value -> Parser a parseJSON Value v) StateT [Value] Parser a -> StateT [Value] Parser () -> StateT [Value] Parser a forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a <* [Value] -> StateT [Value] Parser () forall (m :: * -> *) s. Monad m => s -> StateT s m () put [Value] vs [] -> Parser a -> StateT [Value] Parser a forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift (Parser a -> StateT [Value] Parser a) -> Parser a -> StateT [Value] Parser a forall a b. (a -> b) -> a -> b $ Value -> Parser a forall a. FromJSON a => Value -> Parser a parseJSON Value Null type FieldName = String type FieldsW = Writer (Endo [FieldName]) class GFieldSetJSON f where gFieldSet :: FieldsW (f a) instance GFieldSetJSON U1 where gFieldSet :: FieldsW (U1 a) gFieldSet = U1 a -> FieldsW (U1 a) forall (m :: * -> *) a. Monad m => a -> m a return U1 a forall k (p :: k). U1 p U1 instance (GFieldSetJSON a, GFieldSetJSON b) => GFieldSetJSON (a :*: b) where gFieldSet :: FieldsW ((:*:) a b a) gFieldSet = do a a x <- FieldsW (a a) forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a) gFieldSet b a y <- FieldsW (b a) forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a) gFieldSet (:*:) a b a -> FieldsW ((:*:) a b a) forall (m :: * -> *) a. Monad m => a -> m a return (a a x a a -> b a -> (:*:) a b a forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> g p -> (:*:) f g p :*: b a y) instance GFieldSetJSON a => GFieldSetJSON (D1 c a) where gFieldSet :: FieldsW (D1 c a a) gFieldSet = do a a x <- FieldsW (a a) forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a) gFieldSet D1 c a a -> FieldsW (D1 c a a) forall (m :: * -> *) a. Monad m => a -> m a return (D1 c a a -> FieldsW (D1 c a a)) -> D1 c a a -> FieldsW (D1 c a a) forall a b. (a -> b) -> a -> b $ a a -> D1 c a a forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p M1 a a x instance GFieldSetJSON a => GFieldSetJSON (C1 c a) where gFieldSet :: FieldsW (C1 c a a) gFieldSet = do a a x <- FieldsW (a a) forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a) gFieldSet C1 c a a -> FieldsW (C1 c a a) forall (m :: * -> *) a. Monad m => a -> m a return (C1 c a a -> FieldsW (C1 c a a)) -> C1 c a a -> FieldsW (C1 c a a) forall a b. (a -> b) -> a -> b $ a a -> C1 c a a forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p M1 a a x instance (GFieldSetJSON a, Selector s) => GFieldSetJSON (S1 s a) where gFieldSet :: FieldsW (S1 s a a) gFieldSet = do a a x <- FieldsW (a a) forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a) gFieldSet S1 s a a -> FieldsW (S1 s a a) forall (a :: * -> *) (s :: Meta) p. (GFieldSetJSON a, Selector s) => S1 s a p -> FieldsW (S1 s a p) saveQueriedField (S1 s a a -> FieldsW (S1 s a a)) -> S1 s a a -> FieldsW (S1 s a a) forall a b. (a -> b) -> a -> b $ a a -> S1 s a a forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p M1 a a x saveQueriedField :: (GFieldSetJSON a, Selector s) => S1 s a p -> FieldsW (S1 s a p) saveQueriedField :: S1 s a p -> FieldsW (S1 s a p) saveQueriedField S1 s a p m1 = do Endo [[Char]] -> WriterT (Endo [[Char]]) Identity () forall (m :: * -> *) w. Monad m => w -> WriterT w m () tell (([[Char]] -> [[Char]]) -> Endo [[Char]] forall a. (a -> a) -> Endo a Endo (S1 s a p -> [Char] forall k (s :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *) (f :: k1 -> *) (a :: k1). Selector s => t s f a -> [Char] selName S1 s a p m1 [Char] -> [[Char]] -> [[Char]] forall a. a -> [a] -> [a] :)) S1 s a p -> FieldsW (S1 s a p) forall (m :: * -> *) a. Monad m => a -> m a return S1 s a p m1 instance GFieldSetJSON (K1 i a) where gFieldSet :: FieldsW (K1 i a a) gFieldSet = K1 i a a -> FieldsW (K1 i a a) forall (m :: * -> *) a. Monad m => a -> m a return (K1 i a a -> FieldsW (K1 i a a)) -> K1 i a a -> FieldsW (K1 i a a) forall a b. (a -> b) -> a -> b $ a -> K1 i a a forall k i c (p :: k). c -> K1 i c p K1 a forall a. HasCallStack => a undefined genericFieldSetParseJSON :: (Generic a, GFromJSON0 (Rep a), GFieldSetJSON (Rep a)) => JsonRpcOptions -> Options -> Value -> Parser a genericFieldSetParseJSON :: JsonRpcOptions -> Options -> Value -> Parser a genericFieldSetParseJSON = JsonRpcOptions -> Options -> Value -> Parser a forall b. (GFromJSON Zero (Rep b), GFieldSetJSON (Rep b), Generic b) => JsonRpcOptions -> Options -> Value -> Parser b d where d :: JsonRpcOptions -> Options -> Value -> Parser b d JsonRpcOptions rpcOpts Options opts v :: Value v@(Object Object m) = do let (Rep b a px, Endo [[Char]] fs) = Writer (Endo [[Char]]) (Rep b a) -> (Rep b a, Endo [[Char]]) forall w a. Writer w a -> (a, w) runWriter Writer (Endo [[Char]]) (Rep b a) forall (f :: * -> *) a. GFieldSetJSON f => FieldsW (f a) gFieldSet inv :: Set Text inv = [Text] -> Set Text forall a. Ord a => [a] -> Set a Set.fromList (Object -> [Text] forall k v. HashMap k v -> [k] HashMap.keys Object m) Set Text -> Set Text -> Set Text forall a. Ord a => Set a -> Set a -> Set a \\ [Text] -> Set Text forall a. Ord a => [a] -> Set a Set.fromList (([Char] -> Text) -> [[Char]] -> [Text] forall a b. (a -> b) -> [a] -> [b] map ([Char] -> Text T.pack ([Char] -> Text) -> ([Char] -> [Char]) -> [Char] -> Text forall b c a. (b -> c) -> (a -> b) -> a -> c . Options -> [Char] -> [Char] fieldLabelModifier Options opts) ([[Char]] -> [Text]) -> [[Char]] -> [Text] forall a b. (a -> b) -> a -> b $ Endo [[Char]] -> [[Char]] -> [[Char]] forall a. Endo a -> a -> a appEndo Endo [[Char]] fs []) Bool -> Parser () forall (f :: * -> *). Alternative f => Bool -> f () guard (JsonRpcOptions -> Bool allowNonExistField JsonRpcOptions rpcOpts Bool -> Bool -> Bool || Set Text -> Bool forall a. Set a -> Bool Set.null Set Text inv) Parser () -> Parser () -> Parser () forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> [Char] -> Parser () forall (m :: * -> *) a. MonadFail m => [Char] -> m a fail ([Char] "object has illegal field: " [Char] -> [Char] -> [Char] forall a. [a] -> [a] -> [a] ++ [Text] -> [Char] forall a. Show a => a -> [Char] show (Set Text -> [Text] forall a. Set a -> [a] Set.toList Set Text inv)) b j <- Options -> Value -> Parser b forall a. (Generic a, GFromJSON Zero (Rep a)) => Options -> Value -> Parser a genericParseJSON Options opts Value v let Rep b Any _ = b -> Rep b Any forall a x. Generic a => a -> Rep a x from b j Rep b Any -> Rep b Any -> Rep b Any forall a. a -> a -> a `asTypeOf` Rep b Any forall a. Rep b a px b -> Parser b forall (m :: * -> *) a. Monad m => a -> m a return b j d JsonRpcOptions _ Options opts Value v = Options -> Value -> Parser b forall a. (Generic a, GFromJSON Zero (Rep a)) => Options -> Value -> Parser a genericParseJSON Options opts Value v genericParseJSONRPC :: (Generic a, GFromJSON0 (Rep a), GFromArrayJSON (Rep a), GFieldSetJSON (Rep a)) => JsonRpcOptions -> Options -> Value -> Parser a genericParseJSONRPC :: JsonRpcOptions -> Options -> Value -> Parser a genericParseJSONRPC JsonRpcOptions rpcOpt Options opt = Value -> Parser a forall b. (GFromArrayJSON (Rep b), Generic b, GFromJSON Zero (Rep b), GFieldSetJSON (Rep b)) => Value -> Parser b d where d :: Value -> Parser b d (Array Array vs) = do (Rep b Any a, [Value] s) <- StateT [Value] Parser (Rep b Any) -> [Value] -> Parser (Rep b Any, [Value]) forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s) runStateT StateT [Value] Parser (Rep b Any) forall (f :: * -> *) a. GFromArrayJSON f => StateT [Value] Parser (f a) gFromArrayJSON ([Value] -> Parser (Rep b Any, [Value])) -> [Value] -> Parser (Rep b Any, [Value]) forall a b. (a -> b) -> a -> b $ Array -> [Value] forall a. Vector a -> [a] Vector.toList Array vs Bool -> Parser () forall (f :: * -> *). Alternative f => Bool -> f () guard (JsonRpcOptions -> Bool allowSpilledArguemnts JsonRpcOptions rpcOpt Bool -> Bool -> Bool || [Value] -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null [Value] s) Parser () -> Parser () -> Parser () forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> [Char] -> Parser () forall (m :: * -> *) a. MonadFail m => [Char] -> m a fail ([Char] "Too many arguments! Spilled arguments: " [Char] -> [Char] -> [Char] forall a. [a] -> [a] -> [a] ++ [Value] -> [Char] forall a. Show a => a -> [Char] show [Value] s) b -> Parser b forall (m :: * -> *) a. Monad m => a -> m a return (b -> Parser b) -> b -> Parser b forall a b. (a -> b) -> a -> b $ Rep b Any -> b forall a x. Generic a => Rep a x -> a to Rep b Any a d v :: Value v@(Object Object _) = JsonRpcOptions -> Options -> Value -> Parser b forall a. (Generic a, GFromJSON0 (Rep a), GFieldSetJSON (Rep a)) => JsonRpcOptions -> Options -> Value -> Parser a genericFieldSetParseJSON JsonRpcOptions rpcOpt Options opt Value v d Value _ = Parser b forall (f :: * -> *) a. Alternative f => f a empty data JsonRpcOptions = JsonRpcOptions { JsonRpcOptions -> Bool allowSpilledArguemnts :: Bool , JsonRpcOptions -> Bool allowNonExistField :: Bool } defaultJsonRpcOptions :: JsonRpcOptions defaultJsonRpcOptions :: JsonRpcOptions defaultJsonRpcOptions = JsonRpcOptions :: Bool -> Bool -> JsonRpcOptions JsonRpcOptions { allowSpilledArguemnts :: Bool allowSpilledArguemnts = Bool True , allowNonExistField :: Bool allowNonExistField = Bool True } class GToArrayJSON f where gToArrayJSON :: f a -> Vector Value instance GToArrayJSON U1 where gToArrayJSON :: U1 a -> Array gToArrayJSON U1 a U1 = Array forall a. Vector a Vector.empty instance (GToArrayJSON a, GToArrayJSON b) => GToArrayJSON (a :*: b) where gToArrayJSON :: (:*:) a b a -> Array gToArrayJSON (a a x :*: b a y) = a a -> Array forall (f :: * -> *) a. GToArrayJSON f => f a -> Array gToArrayJSON a a x Array -> Array -> Array forall a. Vector a -> Vector a -> Vector a Vector.++ b a -> Array forall (f :: * -> *) a. GToArrayJSON f => f a -> Array gToArrayJSON b a y instance GToArrayJSON a => GToArrayJSON (M1 i c a) where gToArrayJSON :: M1 i c a a -> Array gToArrayJSON (M1 a a x) = a a -> Array forall (f :: * -> *) a. GToArrayJSON f => f a -> Array gToArrayJSON a a x instance ToJSON a => GToArrayJSON (K1 i a) where gToArrayJSON :: K1 i a a -> Array gToArrayJSON (K1 a x) = Value -> Array forall a. a -> Vector a Vector.singleton (Value -> Array) -> Value -> Array forall a b. (a -> b) -> a -> b $ a -> Value forall a. ToJSON a => a -> Value toJSON a x genericToArrayJSON :: (Generic a, GToArrayJSON (Rep a)) => a -> Value genericToArrayJSON :: a -> Value genericToArrayJSON = Array -> Value Array (Array -> Value) -> (a -> Array) -> a -> Value forall b c a. (b -> c) -> (a -> b) -> a -> c . Rep a Any -> Array forall (f :: * -> *) a. GToArrayJSON f => f a -> Array gToArrayJSON (Rep a Any -> Array) -> (a -> Rep a Any) -> a -> Array forall b c a. (b -> c) -> (a -> b) -> a -> c . a -> Rep a Any forall a x. Generic a => a -> Rep a x from