JSON-RPC client

Client.hs

module JSONRPC.Client where

import Control.Applicative ((<|>))
import Data.Aeson (encode, decode)
import Data.Aeson.Types
import Network.HTTP.Conduit
import qualified Data.Text as T
import qualified Data.ByteString.Lazy.Char8 as BSL

data (FromJSON a) => JSONRPCReply a =
    RPCResult a
  | RPCError Int T.Text (Maybe Value)

parseError :: Object -> Parser (JSONRPCReply a)
parseError o = RPCError
    <$> o .: "code"
    <*> o .: "message"
    <*> o .:? "data"

instance FromJSON a => FromJSON (JSONRPCReply a) where
    parseJSON =
        withObject "jsonrpc" $ \o ->
                (RPCResult <$> o .: "result")
            <|> (o .: "error" >>= parseError)
            <|> fail "Incorrect JSON RPC reply"


jsonRPC :: FromJSON a
        => Manager
        -> String
        -> Text
        -> [Value]
        -> IO (JSONRPCReply a)
jsonRPC manager url rpcMethod params = do
    req <- parseUrl url
    let request = req { method = "POST"
                      , responseTimeout = Just 30000000
                      , requestHeaders = [ ("Content-Type", "application/json")]
                      , requestBody = RequestBodyLBS $ encode payload
                      , checkStatus = \_ _ _ -> Nothing
                      }

    print req
    resp <- httpLbs request manager
    BSL.putStrLn $ responseBody resp

    return . maybe (error "Bad server reply.") id
           . decode
           . responseBody
           $ resp

  where
    payload = object
        [ "jsonrpc" .= (2.0 :: Double)
        , "method"  .= rpcMethod
        , "params"  .= params
        , "id"      .= (42 :: Int)
        ]