{-# 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 }