JsonRpcClient.hs

{-# LANGUAGE OverloadedStrings #-}

module JsonRpcClient
                ( JsonRpcVersion(JsonRpcV1, JsonRpcV2)
                , JsonRpcRequest(..)
                , JsonRpcNotification
                , JsonRpcError(..)
                , parseJsonRpc
                ) where

import Data.ByteString.Lazy (ByteString)
import Control.Applicative ((<$>), (<*>), empty)
import Data.Either
import Data.Aeson

data JsonRpcVersion = JsonRpcV1 | JsonRpcV2
        deriving (Show)

data JsonRpcRequest = JsonRpcRequest { jrpcVersion    :: JsonRpcVersion
                                     , jrpcReqMethod  :: ByteString
                                     , jrpcReqParams  :: [ByteString]
                                     , jrpcReqId      :: Value
                                     } deriving (Show)
instance ToJSON JsonRpcRequest where
  toJSON (JsonRpcRequest version method params id) =
    let l = [ "method" .= method, "params" .= params, "id" .= id ]
    in case version of
      JsonRpcV1 -> object l
      JsonRpcV2 -> object $ ("jsonrpc" .= toJSON ("2.0" :: ByteString)):l

data JsonRpcNotification = JsonRpcNotification
                                     { jrpcNtfVersion :: JsonRpcVersion
                                     , jrpcNtfMethod  :: ByteString
                                     , jrpcNtfParams  :: [ByteString]
                                     } deriving (Show)
instance ToJSON JsonRpcNotification where
  toJSON (JsonRpcNotification version method params) =
    let l = [ "method" .= method, "params" .= params ]
    in case version of
      JsonRpcV1 -> object l
      JsonRpcV2 -> object $ ("jsonrpc" .= toJSON ("2.0" :: ByteString)):l

data JsonRpcError = JsonRpcError { jrpcErrCode    :: Int
                                 , jrpcErrMessage :: ByteString
                                 , jrpcErrData    :: Maybe Value
                                 } deriving (Show)
instance FromJSON JsonRpcError where
  parseJSON (Object o) = JsonRpcError
                                <$> o .:  "code"
                                <*> o .:  "message"
                                <*> o .:? "data"
  parseJSON x = return $ JsonRpcError
                                (-32600)
                                "Unparseable error object"
                                (Just (toJSON x))

data JsonRpcResponse = JsonRpcResponse { jrpcRspResult :: Maybe Value
                                       , jrpcRspError  :: JsonRpcError
                                       , jrpcRspId     :: Value
                                       } deriving (Show)
instance FromJSON JsonRpcResponse where
  parseJSON (Object o) = JsonRpcResponse
                                <$> o .:? "result"
                                <*> o .:  "error"
                                <*> o .:  "id"
  parseJSON x = return $ JsonRpcResponse
                                Nothing
                                (JsonRpcError
                                        (-32700)
                                        "Unparseable response object"
                                        (Just (toJSON x))
                                )
                                (String "n/a")

parseJsonRpc :: (FromJSON a) => ByteString -> Either JsonRpcError a
parseJsonRpc s = case (decode s :: Maybe JsonRpcResponse) of
  Just (JsonRpcResponse result error id) ->
    case result of
      Just v -> case fromJSON v of
        Success a -> Right a
        Error s   -> Left $ JsonRpcError (-32900) "Unparseable result" (Just v)
      Nothing -> Left error
  Nothing -> Left $ JsonRpcError (-32800) "Unparseable response" (Just (toJSON s))