{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE StandaloneDeriving #-} module Data.JsonRpc.Instances () where import GHC.Generics (Generic) import Control.Applicative ((<$>), pure, (<|>)) import Data.Maybe (fromMaybe) import Data.List (stripPrefix) import Data.Aeson (FromJSON (..), genericParseJSON, ToJSON (..), genericToJSON, Value(..)) import Data.Aeson.Types (Options (..)) import qualified Data.Aeson.Types as Aeson import Data.JsonRpc.Integral (fromScientific) import Data.JsonRpc.Id (Id(..), numberId) import Data.JsonRpc.Request (Request (..)) import Data.JsonRpc.Success (Success (..)) import Data.JsonRpc.Failure (Failure (..), Error (..), ErrorStatus (..)) import qualified Data.JsonRpc.Failure as Failure import Data.JsonRpc.Response (Response (..)) instance FromJSON Id where parseJSON :: Value -> Parser Id parseJSON = Value -> Parser Id d where d :: Value -> Parser Id d (String Text t) = Id -> Parser Id forall (f :: * -> *) a. Applicative f => a -> f a pure (Id -> Parser Id) -> Id -> Parser Id forall a b. (a -> b) -> a -> b $ Text -> Id StringId Text t d (Number Scientific n) = Parser Id -> (Id -> Parser Id) -> Maybe Id -> Parser Id forall b a. b -> (a -> b) -> Maybe a -> b maybe ([Char] -> Parser Id forall a. [Char] -> Parser a parseError [Char] "Integer check error") Id -> Parser Id forall (f :: * -> *) a. Applicative f => a -> f a pure (Maybe Id -> Parser Id) -> Maybe Id -> Parser Id forall a b. (a -> b) -> a -> b $ Scientific -> Maybe Id forall (m :: * -> *). (MonadPlus m, Applicative m) => Scientific -> m Id numberId Scientific n d (Object {}) = [Char] -> Parser Id forall a. [Char] -> Parser a parseError [Char] "object is not allowed" d (Array {}) = [Char] -> Parser Id forall a. [Char] -> Parser a parseError [Char] "array is not allowed" d (Bool {}) = [Char] -> Parser Id forall a. [Char] -> Parser a parseError [Char] "boolean is not allowed" d Value Null = [Char] -> Parser Id forall a. [Char] -> Parser a parseError [Char] "null is not allowed" parseError :: [Char] -> Parser a parseError = [Char] -> Parser a forall (m :: * -> *) a. MonadFail m => [Char] -> m a fail ([Char] -> Parser a) -> ([Char] -> [Char]) -> [Char] -> Parser a forall b c a. (b -> c) -> (a -> b) -> a -> c . ([Char] "JSON RPC id: " [Char] -> [Char] -> [Char] forall a. [a] -> [a] -> [a] ++) instance ToJSON Id where toJSON :: Id -> Value toJSON = Id -> Value d where d :: Id -> Value d (StringId Text s) = Text -> Value String Text s d (NumberId Integer i) = Scientific -> Value Number (Scientific -> Value) -> Scientific -> Value forall a b. (a -> b) -> a -> b $ Integer -> Scientific forall a b. (Integral a, Num b) => a -> b fromIntegral Integer i deriving instance Generic (Request a) instance FromJSON a => FromJSON (Request a) where parseJSON :: Value -> Parser (Request a) parseJSON = Options -> Value -> Parser (Request a) forall a. (Generic a, GFromJSON Zero (Rep a)) => Options -> Value -> Parser a genericParseJSON Options customOptions instance ToJSON a => ToJSON (Request a) where toJSON :: Request a -> Value toJSON = Options -> Request a -> Value forall a. (Generic a, GToJSON' Value Zero (Rep a)) => Options -> a -> Value genericToJSON Options customOptions deriving instance Generic (Success a) instance FromJSON a => FromJSON (Success a) where parseJSON :: Value -> Parser (Success a) parseJSON = Options -> Value -> Parser (Success a) forall a. (Generic a, GFromJSON Zero (Rep a)) => Options -> Value -> Parser a genericParseJSON Options customOptions instance ToJSON a => ToJSON (Success a) where toJSON :: Success a -> Value toJSON = Options -> Success a -> Value forall a. (Generic a, GToJSON' Value Zero (Rep a)) => Options -> a -> Value genericToJSON Options customOptions deriving instance Generic (Error e) deriving instance Generic (Failure e) instance FromJSON ErrorStatus where parseJSON :: Value -> Parser ErrorStatus parseJSON = Value -> Parser ErrorStatus d where d :: Value -> Parser ErrorStatus d (String {}) = [Char] -> Parser ErrorStatus forall a. [Char] -> Parser a parseError [Char] "string is not allowed" d (Number Scientific n) = do Integer i <- Scientific -> Parser Integer forall (m :: * -> *). MonadPlus m => Scientific -> m Integer fromScientific Scientific n Parser Integer -> Parser Integer -> Parser Integer forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> [Char] -> Parser Integer forall a. [Char] -> Parser a parseError [Char] "not integer number" Integer -> Parser ErrorStatus forall a (m :: * -> *). (Integral a, MonadPlus m) => a -> m ErrorStatus Failure.fromCode Integer i Parser ErrorStatus -> Parser ErrorStatus -> Parser ErrorStatus forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> [Char] -> Parser ErrorStatus forall a. [Char] -> Parser a parseError [Char] "unknown error code range" d (Object {}) = [Char] -> Parser ErrorStatus forall a. [Char] -> Parser a parseError [Char] "object is not allowed" d (Array {}) = [Char] -> Parser ErrorStatus forall a. [Char] -> Parser a parseError [Char] "array is not allowed" d (Bool {}) = [Char] -> Parser ErrorStatus forall a. [Char] -> Parser a parseError [Char] "boolean is not allowed" d Value Null = [Char] -> Parser ErrorStatus forall a. [Char] -> Parser a parseError [Char] "null is not allowed" parseError :: [Char] -> Parser a parseError = [Char] -> Parser a forall (m :: * -> *) a. MonadFail m => [Char] -> m a fail ([Char] -> Parser a) -> ([Char] -> [Char]) -> [Char] -> Parser a forall b c a. (b -> c) -> (a -> b) -> a -> c . ([Char] "JSON RPC error code: " [Char] -> [Char] -> [Char] forall a. [a] -> [a] -> [a] ++) instance ToJSON ErrorStatus where toJSON :: ErrorStatus -> Value toJSON = Scientific -> Value Number (Scientific -> Value) -> (ErrorStatus -> Scientific) -> ErrorStatus -> Value forall b c a. (b -> c) -> (a -> b) -> a -> c . Integer -> Scientific forall a b. (Integral a, Num b) => a -> b fromIntegral (Integer -> Scientific) -> (ErrorStatus -> Integer) -> ErrorStatus -> Scientific forall b c a. (b -> c) -> (a -> b) -> a -> c . ErrorStatus -> Integer Failure.toCode instance FromJSON e => FromJSON (Error e) where parseJSON :: Value -> Parser (Error e) parseJSON = Options -> Value -> Parser (Error e) forall a. (Generic a, GFromJSON Zero (Rep a)) => Options -> Value -> Parser a genericParseJSON Options customOptions instance ToJSON e => ToJSON (Error e) where toJSON :: Error e -> Value toJSON = Options -> Error e -> Value forall a. (Generic a, GToJSON' Value Zero (Rep a)) => Options -> a -> Value genericToJSON Options customOptions { omitNothingFields :: Bool omitNothingFields = Bool True } instance FromJSON e => FromJSON (Failure e) where parseJSON :: Value -> Parser (Failure e) parseJSON = Options -> Value -> Parser (Failure e) forall a. (Generic a, GFromJSON Zero (Rep a)) => Options -> Value -> Parser a genericParseJSON Options customOptions instance ToJSON e => ToJSON (Failure e) where toJSON :: Failure e -> Value toJSON = Options -> Failure e -> Value forall a. (Generic a, GToJSON' Value Zero (Rep a)) => Options -> a -> Value genericToJSON Options customOptions instance (FromJSON e, FromJSON a) => FromJSON (Response e a) where parseJSON :: Value -> Parser (Response e a) parseJSON Value v = Either (Failure e) (Success a) -> Response e a forall e a. Either (Failure e) (Success a) -> Response e a Response (Either (Failure e) (Success a) -> Response e a) -> Parser (Either (Failure e) (Success a)) -> Parser (Response e a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> (Success a -> Either (Failure e) (Success a) forall a b. b -> Either a b Right (Success a -> Either (Failure e) (Success a)) -> Parser (Success a) -> Parser (Either (Failure e) (Success a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Value -> Parser (Success a) forall a. FromJSON a => Value -> Parser a parseJSON Value v Parser (Either (Failure e) (Success a)) -> Parser (Either (Failure e) (Success a)) -> Parser (Either (Failure e) (Success a)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a <|> Failure e -> Either (Failure e) (Success a) forall a b. a -> Either a b Left (Failure e -> Either (Failure e) (Success a)) -> Parser (Failure e) -> Parser (Either (Failure e) (Success a)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Value -> Parser (Failure e) forall a. FromJSON a => Value -> Parser a parseJSON Value v) instance (ToJSON e, ToJSON a) => ToJSON (Response e a) where toJSON :: Response e a -> Value toJSON (Response Either (Failure e) (Success a) r) = case Either (Failure e) (Success a) r of Right Success a a -> Success a -> Value forall a. ToJSON a => a -> Value toJSON Success a a Left Failure e e -> Failure e -> Value forall a. ToJSON a => a -> Value toJSON Failure e e customOptions :: Options customOptions :: Options customOptions = Options Aeson.defaultOptions { fieldLabelModifier :: [Char] -> [Char] fieldLabelModifier = \[Char] s -> [Char] -> Maybe [Char] -> [Char] forall a. a -> Maybe a -> a fromMaybe [Char] s (Maybe [Char] -> [Char]) -> Maybe [Char] -> [Char] forall a b. (a -> b) -> a -> b $ [Char] -> [Char] -> Maybe [Char] forall a. Eq a => [a] -> [a] -> Maybe [a] stripPrefix [Char] "_" [Char] s }