json-rpc
Fully-featured JSON-RPC 2.0 library for Haskell programs.
This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and 1.0. It
provides an interface that combines a JSON-RPC client and server. It can
set and keep track of request ids to parse responses. There is support
for sending and receiving notifications. You may use any underlying
transport. Basic TCP client and server provided.
A JSON-RPC application using this interface is considered to be
peer-to-peer, as it can send and receive all types of JSON-RPC message
independent of whether it originated the connection.
Documentation
Examples
Time Server Example
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Logger
import Data.Aeson.Types
import Data.Conduit.Network
import qualified Data.Foldable as F
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format
import Network.JsonRpc
import System.Locale
data Req = TimeReq | Ping deriving (Show, Eq)
instance FromRequest Req where
parseParams "time" = Just $ const $ return TimeReq
parseParams "ping" = Just $ const $ return Ping
parseParams _ = Nothing
instance ToRequest Req where
requestMethod TimeReq = "time"
requestMethod Ping = "ping"
requestIsNotif = const False
instance ToJSON Req where
toJSON = const emptyArray
data Res = Time { getTime :: UTCTime } | Pong deriving (Show, Eq)
instance FromResponse Res where
parseResult "time" = Just $ withText "time" $ \t ->
case parseTime defaultTimeLocale "%c" $ T.unpack t of
Just t' -> return $ Time t'
Nothing -> mzero
parseResult "ping" = Just $ const $ return Pong
parseResult _ = Nothing
instance ToJSON Res where
toJSON (Time t) = toJSON $ formatTime defaultTimeLocale "%c" t
toJSON Pong = emptyArray
respond :: MonadLoggerIO m => Respond Req m Res
respond TimeReq = liftM (Right . Time) $ liftIO getCurrentTime
respond Ping = return $ Right Pong
main :: IO ()
main = runStderrLoggingT $ do
let ss = serverSettings 31337 "::1"
jsonRpcTcpServer V2 False ss srv
srv :: MonadLoggerIO m => JsonRpcT m ()
srv = do
$(logDebug) "listening for new request"
qM <- receiveBatchRequest
case qM of
Nothing -> do
$(logDebug) "closed request channel, exting"
return ()
Just (SingleRequest q) -> do
$(logDebug) "got request"
rM <- buildResponse respond q
F.forM_ rM sendResponse
srv
Just (BatchRequest qs) -> do
$(logDebug) "got request batch"
rs <- catMaybes `liftM` forM qs (buildResponse respond)
sendBatchResponse $ BatchResponse rs
srv
Time Client Example
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
import Control.Concurrent
import Control.Monad
import Control.Monad.Trans
import Control.Monad.Logger
import Data.Aeson
import Data.Aeson.Types hiding (Error)
import Data.Conduit.Network
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Format
import Network.JsonRpc
import System.Locale
data Req = TimeReq | Ping deriving (Show, Eq)
instance FromRequest Req where
parseParams "time" = Just $ const $ return TimeReq
parseParams "ping" = Just $ const $ return Ping
parseParams _ = Nothing
instance ToRequest Req where
requestMethod TimeReq = "time"
requestMethod Ping = "ping"
requestIsNotif = const False
instance ToJSON Req where
toJSON = const emptyArray
data Res = Time { getTime :: UTCTime } | Pong deriving (Show, Eq)
instance FromResponse Res where
parseResult "time" = Just $ withText "time" $ \t ->
case parseTime defaultTimeLocale "%c" $ T.unpack t of
Just t' -> return $ Time t'
Nothing -> mzero
parseResult "ping" = Just $ const $ return Pong
parseResult _ = Nothing
instance ToJSON Res where
toJSON (Time t) = toJSON $ formatTime defaultTimeLocale "%c" t
toJSON Pong = emptyArray
handleResponse :: Maybe (Either ErrorObj Res) -> Res
handleResponse t =
case t of
Nothing -> error "could not receive or parse response"
Just (Left e) -> error $ fromError e
Just (Right r) -> r
req :: MonadLoggerIO m => JsonRpcT m Res
req = do
tEM <- sendRequest TimeReq
$(logDebug) "sending time request"
return $ handleResponse tEM
reqBatch :: MonadLoggerIO m => JsonRpcT m [Res]
reqBatch = do
$(logDebug) "sending pings"
tEMs <- sendBatchRequest $ replicate 2 Ping
return $ map handleResponse tEMs
main :: IO ()
main = runStderrLoggingT $
jsonRpcTcpClient V2 True (clientSettings 31337 "::1") $ do
$(logDebug) "sending two time requests one second apart"
replicateM_ 2 $ do
req >>= $(logDebug) . T.pack . ("response: "++) . show
liftIO (threadDelay 1000000)
$(logDebug) "sending two pings in a batch"
reqBatch >>= $(logDebug) . T.pack . ("response: "++) . show