content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FunctionalDependencies #-}
  -- required by GHC 7.0.1
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE TypeOperators #-}
  -- required by GHC 7.0.1
  {-# LANGUAGE TypeSynonymInstances #-}
  {-# LANGUAGE UndecidableInstances #-}
  
  module Network.JsonRpc.Types
    ( RpcResult,
      Method (..),
      Parameter (..),
      (:+:) (..),
      MethodParams (..),
      Request (..),
      Response (..),
      Id (..),
      RpcError (..),
      rpcError,
      rpcErrorWithData,
    )
  where
  
  import Data.Maybe (catMaybes)
  import Data.Text (Text)
  #if ! MIN_VERSION_aeson(2,0,0)
  import Data.Text (unpack)
  #endif
  import qualified Data.Aeson as A
  #if MIN_VERSION_aeson(2,0,0)
  import qualified Data.Aeson.Key as A
  #endif
  import Data.Aeson ((.!=), (.:), (.:?), (.=))
  import Data.Aeson.Types (emptyObject)
  import qualified Data.Vector as V
  #if MIN_VERSION_aeson(2,0,0)
  import qualified Data.Aeson.KeyMap as KeyMap
  #else
  import qualified Data.HashMap.Strict as H
  #endif
  import Control.Applicative (empty, (<|>))
  import Control.DeepSeq (NFData, rnf)
  import Control.Monad (when)
  import Control.Monad.Except (ExceptT (..), throwError)
  import Prelude hiding (length)
  
  #if !MIN_VERSION_base(4,8,0)
  import Control.Applicative ((<$>), (<*>), (*>))
  #endif
  
  -- | Return type of a method. A method call can either fail with an 'RpcError'
  --   or succeed with a result of type 'r'.
  type RpcResult m r = ExceptT RpcError m r
  
  -- | Parameter expected by a method.
  data Parameter a
    = -- | Required parameter with a name.
      Required Text
    | -- | Optional parameter with a name and default value.
      Optional Text a
  
  -- | A node in a type-level linked list of 'Parameter' types.  It is right associative.
  data a :+: ps = (Parameter a) :+: ps
  
  infixr 9 :+:
  
  -- | Relationship between a method's function ('f'), parameters ('p'),
  --   monad ('m'), and return type ('r'). 'p' has one 'Parameter' for
  --   every argument of 'f' and is terminated by @()@. The return type
  --   of 'f' is @RpcResult m r@. This class is treated as closed.
  class (Monad m, A.ToJSON r) => MethodParams f p m r | f -> p m r, p m r -> f where
    _apply :: f -> p -> Args -> RpcResult m r
  
  instance (Monad m, A.ToJSON r) => MethodParams (RpcResult m r) () m r where
    _apply _ _ (Right ar)
      | not $ V.null ar =
        throwError $ rpcError (-32602) "Too many unnamed arguments"
    _apply res _ _ = res
  
  instance (A.FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where
    _apply f (param :+: ps) args =
      ExceptT (return arg) >>= \a -> _apply (f a) ps nextArgs
      where
        arg = maybe (paramDefault param) (parseArg name) lookupValue
        lookupValue = either (lookupInObject name) (V.!? 0) args
        nextArgs = V.drop 1 <$> args
        name = paramName param
  
  parseArg :: A.FromJSON r => Text -> A.Value -> Either RpcError r
  parseArg name val = case A.fromJSON val of
    A.Error msg -> throwError $ argTypeError msg
    A.Success x -> return x
    where
      argTypeError = rpcErrorWithData (-32602) $ "Wrong type for argument: " <> name
  
  paramDefault :: Parameter a -> Either RpcError a
  paramDefault (Optional _ d) = Right d
  paramDefault (Required name) = Left $ missingArgError name
  
  missingArgError :: Text -> RpcError
  missingArgError name = rpcError (-32602) $ "Cannot find required argument: " <> name
  
  paramName :: Parameter a -> Text
  paramName (Optional n _) = n
  paramName (Required n) = n
  
  -- | A JSON-RPC method.
  data Method m = Method Text (Args -> RpcResult m A.Value)
  
  type Args = Either A.Object A.Array
  
  data Request = Request Text Args (Maybe Id)
  
  instance A.FromJSON Request where
    parseJSON (A.Object x) =
      (checkVersion =<< x .:? versionKey .!= jsonRpcVersion)
        *> ( Request
               <$> x .: "method"
               <*> (parseParams =<< x .:? "params" .!= emptyObject)
               <*> parseId
           )
      where
        parseParams (A.Object obj) = return $ Left obj
        parseParams (A.Array ar) = return $ Right ar
        parseParams _ = empty
        checkVersion ver =
          when (ver /= jsonRpcVersion) $
            fail $ "Wrong JSON-RPC version: " ++ unpackKey ver
        -- (.:?) parses Null value as Nothing so parseId needs
        -- to use both (.:?) and (.:) to handle all cases
        parseId =
          x .:? idKey >>= \optional ->
            case optional of
              Nothing -> Just <$> (x .: idKey) <|> return Nothing
              _ -> return optional
    parseJSON _ = empty
  
  data Response = Response Id (Either RpcError A.Value)
  
  instance NFData Response where
    rnf (Response i e) = rnf i `seq` rnf e
  
  instance A.ToJSON Response where
    toJSON (Response i result) = A.object pairs
      where
        pairs =
          [ versionKey .= jsonRpcVersion,
            either ("error" .=) ("result" .=) result,
            idKey .= i
          ]
  
  -- IdNumber cannot directly reference the type stored in A.Number,
  -- since it changes between aeson-0.6 and 0.7.
  data Id = IdString A.Value | IdNumber A.Value | IdNull
  
  instance NFData Id where
    rnf (IdString s) = rnf s
    rnf (IdNumber n) = rnf n
    rnf IdNull = ()
  
  instance A.FromJSON Id where
    parseJSON x@(A.String _) = return $ IdString x
    parseJSON x@(A.Number _) = return $ IdNumber x
    parseJSON A.Null = return IdNull
    parseJSON _ = empty
  
  instance A.ToJSON Id where
    toJSON (IdString x) = x
    toJSON (IdNumber x) = x
    toJSON IdNull = A.Null
  
  -- | JSON-RPC error.
  data RpcError = RpcError
    { errCode :: Int,
      errMsg :: Text,
      errData :: Maybe A.Value
    }
    deriving (Show, Eq)
  
  instance NFData RpcError where
    rnf (RpcError e m d) = rnf e `seq` rnf m `seq` rnf d
  
  instance A.ToJSON RpcError where
    toJSON (RpcError code msg data') = A.object pairs
      where
        pairs =
          catMaybes
            [ Just $ "code" .= code,
              Just $ "message" .= msg,
              ("data" .=) <$> data'
            ]
  
  instance A.FromJSON RpcError where
    parseJSON (A.Object v) =
      RpcError
        <$> v .: "code"
        <*> v .: "message"
        <*> v .:? "data"
    parseJSON _ = empty
  
  -- | Creates an 'RpcError' with the given error code and message.
  --   According to the specification, server error codes should be
  --   in the range -32099 to -32000, and application defined errors
  --   should be outside the range -32768 to -32000.
  rpcError :: Int -> Text -> RpcError
  rpcError code msg = RpcError code msg Nothing
  
  -- | Creates an 'RpcError' with the given code, message, and additional data.
  --   See 'rpcError' for the recommended error code ranges.
  rpcErrorWithData :: A.ToJSON a => Int -> Text -> a -> RpcError
  rpcErrorWithData code msg errorData = RpcError code msg $ Just $ A.toJSON errorData
  
  #if MIN_VERSION_aeson(2,0,0)
  jsonRpcVersion, versionKey, idKey :: A.Key
  #else
  jsonRpcVersion, versionKey, idKey :: Text
  #endif
  jsonRpcVersion = "2.0"
  
  versionKey = "jsonrpc"
  
  idKey = "id"
  
  #if MIN_VERSION_aeson(2,0,0)
  unpackKey :: A.Key -> String
  unpackKey = A.toString
  
  lookupInObject :: Text -> KeyMap.KeyMap A.Value -> Maybe A.Value
  lookupInObject key = KeyMap.lookup (A.fromText key)
  #else
  unpackKey :: Text -> String
  unpackKey = unpack
  
  lookupInObject :: Text -> H.HashMap Text A.Value -> Maybe A.Value
  lookupInObject = H.lookup
  #endif
  