module Network.JsonRpc.Types ( RpcResult
, Method (..)
, Methods (..)
, Parameter(..)
, (:+:) (..)
, MethodParams (..)
, Request (..)
, Response (..)
, Id (..)
, RpcError
, rpcError
, rpcErrorWithData) where
import Data.String (fromString)
import Data.Maybe (catMaybes)
import Data.Text (Text, append, unpack)
import Data.Aeson
import Data.Aeson.Types (emptyObject)
import qualified Data.Vector as V
import qualified Data.HashMap.Strict as H
import Data.Attoparsec.Number (Number)
import Control.Applicative ((<$>), (<*>), (<|>), (*>), empty)
import Control.Monad (when)
import Control.Monad.Error (Error, ErrorT, throwError, strMsg, noMsg)
import Prelude hiding (length)
type RpcResult m r = ErrorT RpcError m r
data Parameter a
= Required Text
| Optional Text a
data a :+: ps = (Parameter a) :+: ps
infixr :+:
class (Monad m, Functor m, ToJSON r) => MethodParams f p m r | f -> p m r where
apply :: f -> p -> Args -> RpcResult m r
instance (Monad m, Functor m, ToJSON r) => MethodParams (RpcResult m r) () m r where
apply r _ args | Left _ <- args = r
| Right ar <- args, V.null ar = r
| otherwise = throwError $ rpcError (32602) "Too many unnamed arguments"
instance (FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where
apply f (param :+: ps) args = arg >>= \a -> apply (f a) ps nextArgs
where arg = either (parseArg name) return =<<
(Left <$> lookupValue <|> Right <$> paramDefault param)
lookupValue = either (lookupArg name) (headArg name) args
nextArgs = tailOrEmpty <$> args
name = paramName param
lookupArg :: Monad m => Text -> Object -> RpcResult m Value
lookupArg name hm = case H.lookup name hm of
Nothing -> throwError $ missingArgError name
Just v -> return v
headArg :: Monad m => Text -> V.Vector a -> RpcResult m a
headArg name vec | V.null vec = throwError $ missingArgError name
| otherwise = return $ V.head vec
tailOrEmpty :: V.Vector a -> V.Vector a
tailOrEmpty vec = if V.null vec then V.empty else V.tail vec
parseArg :: (Monad m, FromJSON r) => Text -> Value -> RpcResult m r
parseArg name val = case fromJSON val of
Error msg -> throwError $ rpcErrorWithData (32602) ("Wrong type for argument: " `append` name) msg
Success x -> return x
paramDefault :: Monad m => Parameter a -> RpcResult m a
paramDefault (Optional _ d) = return d
paramDefault (Required name) = throwError $ missingArgError name
missingArgError :: Text -> RpcError
missingArgError name = rpcError (32602) ("Cannot find required argument: " `append` name)
paramName :: Parameter a -> Text
paramName (Optional n _) = n
paramName (Required n) = n
data Method m = Method Text (Args -> RpcResult m Value)
newtype Methods m = Methods (H.HashMap Text (Method m))
type Args = Either Object Array
data Request = Request Text Args (Maybe Id)
instance FromJSON Request where
parseJSON (Object x) = (checkVersion =<< x .:? versionKey .!= jsonRpcVersion) *>
(Request <$>
x .: methodKey <*>
(parseParams =<< x .:? paramsKey .!= emptyObject) <*>
(Just <$> x .: idKey <|> return Nothing))
where parseParams (Object obj) = return $ Left obj
parseParams (Array ar) = return $ Right ar
parseParams _ = empty
checkVersion ver = when (ver /= jsonRpcVersion) (fail $ "Wrong JSON RPC version: " ++ unpack ver)
parseJSON _ = empty
data Response = Response Id (Either RpcError Value)
instance ToJSON Response where
toJSON (Response i result) = object pairs
where pairs = [ versionKey .= jsonRpcVersion
, either (errorKey .=) (resultKey .=) result
, idKey .= i]
data Id = IdString Text | IdNumber Number | IdNull
instance FromJSON Id where
parseJSON (String x) = return $ IdString x
parseJSON (Number x) = return $ IdNumber x
parseJSON Null = return IdNull
parseJSON _ = empty
instance ToJSON Id where
toJSON i = case i of
IdString x -> toJSON x
IdNumber x -> toJSON x
IdNull -> Null
data RpcError = RpcError Int Text (Maybe Value)
deriving Show
instance Error RpcError where
noMsg = strMsg "unknown error"
strMsg msg = RpcError (32000) (fromString msg) Nothing
instance ToJSON RpcError where
toJSON (RpcError code msg data') = object pairs
where pairs = catMaybes [ Just $ codeKey .= code
, Just $ msgKey .= msg
, (dataKey .=) <$> data' ]
rpcError :: Int -> Text -> RpcError
rpcError code msg = RpcError code msg Nothing
rpcErrorWithData :: ToJSON a => Int -> Text -> a -> RpcError
rpcErrorWithData code msg errorData = RpcError code msg $ Just $ toJSON errorData
jsonRpcVersion, versionKey, idKey :: Text
jsonRpcVersion = "2.0"
versionKey = "jsonrpc"
idKey = "id"
methodKey, paramsKey :: Text
methodKey = "method"
paramsKey = "params"
resultKey, errorKey :: Text
resultKey = "result"
errorKey = "error"
codeKey, msgKey, dataKey :: Text
codeKey = "code"
msgKey = "message"
dataKey = "data"