diff --git a/Network/JsonRpc.hs b/Network/JsonRpc.hs new file mode 100644 --- /dev/null +++ b/Network/JsonRpc.hs @@ -0,0 +1,136 @@ +module Network.JsonRpc +( -- * Introduction + -- $introduction + + -- ** Server Example + -- $server + + -- ** Client Example + -- $client + + module Network.JsonRpc.Conduit +, module Network.JsonRpc.Data +) where + +import Network.JsonRpc.Conduit +import Network.JsonRpc.Data + +-- $introduction +-- +-- This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and +-- partially-compatible with JSON-RPC 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. +-- +-- The recommended interface to this library is provided as conduits that +-- encode outgoing messages, and decode incoming messages. Incoming messages +-- are delivered as an 'IncomingMsg' data structure, while outgoing messages +-- are sent in a 'Message' data structure. The former packs responses and +-- errors with their corresponding request, and has a separate constructor for +-- decoding errors. +-- +-- 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. +-- +-- Type classes 'ToRequest', 'ToNotif' are for data that can be converted into +-- JSON-RPC requests and notifications respectively. An instance of aeson's +-- 'ToJSON' class is also required to serialize these data structures. Make +-- sure that they serialize as a structured JSON value (array or object) that +-- can go into the params field of the JSON-RPC object. Type classes +-- 'FromRequest', 'FromNotif' and 'FromResult' are for deserializing JSON-RPC +-- messages. +-- +-- Errors are deserialized to the 'ErrorObj' data type. Only a string is +-- supported as contents inside a JSON-RPC 1.0 error. JSON-RPC 2.0 errors also +-- have a code, and possibly additional data as an aeson 'Value'. + + +-- $server +-- +-- This server returns the current time. +-- +-- >{-# LANGUAGE OverloadedStrings #-} +-- >import Data.Aeson.Types +-- >import Data.Conduit +-- >import qualified Data.Conduit.List as CL +-- >import Data.Conduit.Network +-- >import Data.Time.Clock +-- >import Data.Time.Format +-- >import Network.JsonRpc +-- >import System.Locale +-- > +-- >data TimeReq = TimeReq +-- >data TimeRes = TimeRes UTCTime +-- > +-- >instance FromRequest TimeReq where +-- > paramsParser "time" = Just $ const $ return TimeReq +-- > paramsParser _ = Nothing +-- > +-- >instance ToJSON TimeRes where +-- > toJSON (TimeRes t) = toJSON $ formatTime defaultTimeLocale "%c" t +-- > +-- >srv :: AppConduits () () TimeRes TimeReq () () IO -> IO () +-- >srv (src, snk) = src $= CL.mapM respond $$ snk +-- > +-- >respond :: IncomingMsg () TimeReq () () +-- > -> IO (Message () () TimeRes) +-- >respond (IncomingMsg (MsgRequest (Request ver _ TimeReq i)) Nothing) = do +-- > t <- getCurrentTime +-- > return $ MsgResponse (Response ver (TimeRes t) i) +-- > +-- >respond (IncomingError e) = return $ MsgError e +-- >respond (IncomingMsg (MsgError e) _) = return $ MsgError $ e +-- >respond _ = undefined +-- > +-- >main :: IO () +-- >main = tcpServer V2 (serverSettings 31337 "127.0.0.1") srv + + +-- $client +-- +-- Corresponding TCP client to get time from server. +-- +-- >{-# LANGUAGE OverloadedStrings #-} +-- >import Data.Aeson.Types hiding (Error) +-- >import Data.Conduit +-- >import qualified Data.Conduit.List as CL +-- >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 TimeReq = TimeReq +-- >data TimeRes = TimeRes UTCTime +-- > +-- >instance ToRequest TimeReq where +-- > requestMethod TimeReq = "time" +-- > +-- >instance ToJSON TimeReq where +-- > toJSON TimeReq = emptyArray +-- > +-- >instance FromResponse TimeRes where +-- > parseResult "time" = withText "time" $ \t -> case f t of +-- > Nothing -> fail "Could not parse time" +-- > Just t' -> return $ TimeRes t' +-- > where +-- > f t = parseTime defaultTimeLocale "%c" (T.unpack t) +-- > +-- >cli :: AppConduits TimeReq () () () () TimeRes IO +-- > -> IO UTCTime +-- >cli (src, snk) = do +-- > CL.sourceList [MsgRequest $ buildRequest V2 TimeReq] $$ snk +-- > ts <- src $$ CL.consume +-- > case ts of +-- > [] -> error "No response received" +-- > [IncomingError (ErrorObj _ m _ _ _)] -> error $ "Unknown: " ++ m +-- > [IncomingMsg (MsgError (ErrorObj _ m _ _ _)) _] -> error m +-- > [IncomingMsg (MsgResponse (Response _ (TimeRes t) _)) _] -> return t +-- > _ -> undefined +-- > +-- >main :: IO () +-- >main = tcpClient V2 True (clientSettings 31337 "127.0.0.1") cli >>= print diff --git a/Network/JsonRpc/Conduit.hs b/Network/JsonRpc/Conduit.hs new file mode 100644 --- /dev/null +++ b/Network/JsonRpc/Conduit.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | Conduit Interface for JSON-RPC. +module Network.JsonRpc.Conduit +( -- * Conduits + -- ** High-Level + AppConduits +, IncomingMsg(..) +, runConduits +, tcpClient +, tcpServer +, query + -- ** Low-Level +, Session(..) +, initSession +, encodeConduit +, msgConduit +, decodeConduit +) where + +import Control.Applicative +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans +import Data.Aeson +import Data.Aeson.Types +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.Conduit +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import Data.Conduit.Network +import Data.Conduit.TMChan +import Data.Maybe +import Data.Text (Text) +import Network.JsonRpc.Data + +-- | Conduits of sending and receiving JSON-RPC messages. +type AppConduits qo no ro qi ni ri m = + (Source m (IncomingMsg qo qi ni ri), Sink (Message qo no ro) m ()) + +-- | Map of ids to sent requests. +type SentRequests qo = HashMap Id (Request qo) + +-- | Incoming messages. Responses and corresponding requests go together. +-- 'IncomingError' is for problems decoding incoming messages. These should be +-- sent to the remote party. +data IncomingMsg qo qi ni ri + = IncomingMsg { incomingMsg :: !(Message qi ni ri) + , matchingReq :: !(Maybe (Request qo)) + } + | IncomingError { incomingError :: !ErrorObj + } + deriving (Eq, Show) + +instance (NFData qo, NFData qi, NFData ni, NFData ri) + => NFData (IncomingMsg qo qi ni ri) + where + rnf (IncomingMsg msg qr) = rnf msg `seq` rnf qr + rnf (IncomingError e) = rnf e + +-- | JSON-RPC session mutable data. +data Session qo = Session + { lastId :: TVar Id -- ^ Last generated id + , sentRequests :: TVar (SentRequests qo) -- ^ Map of ids to requests + , isLast :: TVar Bool -- ^ Has the sink closed? + } + +-- | Initialize JSON-RPC session. +initSession :: STM (Session qo) +initSession = Session <$> newTVar (IdInt 0) + <*> newTVar M.empty + <*> newTVar False + +-- | Conduit that serializes JSON documents for sending to the network. +encodeConduit :: (ToJSON a, Monad m) => Conduit a m ByteString +encodeConduit = CL.map (L8.toStrict . flip L8.append "\n" . encode) + +-- | Conduit for outgoing JSON-RPC messages. +-- Adds an id to requests whose id is 'IdNull'. +-- Tracks all sent requests to match corresponding responses. +msgConduit :: MonadIO m + => Session qo + -> Conduit (Message qo no ro) m (Message qo no ro) +msgConduit qs = await >>= \nqM -> case nqM of + Nothing -> + liftIO (atomically $ writeTVar (isLast qs) True) >> return () + Just (MsgRequest rq) -> do + msg <- MsgRequest <$> liftIO (atomically $ addId rq) + yield msg >> msgConduit qs + Just msg -> + yield msg >> msgConduit qs + where + addId rq = case getReqId rq of + IdNull -> do + i <- readTVar (lastId qs) + h <- readTVar (sentRequests qs) + let i' = succ i + rq' = rq { getReqId = i' } + h' = M.insert i' rq' h + writeTVar (lastId qs) i' + writeTVar (sentRequests qs) h' + return rq' + i -> do + h <- readTVar (sentRequests qs) + writeTVar (sentRequests qs) (M.insert i rq h) + return rq + +-- | Conduit to decode incoming JSON-RPC messages. An error in the decoding +-- operation will output an 'IncomingError', which should be relayed to the +-- remote party. +decodeConduit + :: (FromRequest qi, FromNotif ni, FromResponse ri, MonadIO m) + => Ver -- ^ JSON-RPC version + -> Bool -- ^ Close on last response + -> Session qo -- ^ JSON-RPC session + -> Conduit ByteString m (IncomingMsg qo qi ni ri) + -- ^ Decoded incoming messages +decodeConduit ver c qs = CB.lines =$= f where + f = await >>= \bsM -> case bsM of + Nothing -> + return () + Just bs -> do + (m, d) <- liftIO . atomically $ decodeSTM bs + yield m >> unless d f + + decodeSTM bs = readTVar (sentRequests qs) >>= \h -> case decodeMsg h bs of + Right m@(MsgResponse rs) -> do + (rq, dis) <- requestSTM h $ getResId rs + return (IncomingMsg m (Just rq), dis) + Right m@(MsgError re) -> case getErrId re of + IdNull -> + return (IncomingMsg m Nothing, False) + i -> do + (rq, dis) <- requestSTM h i + return (IncomingMsg m (Just rq), dis) + Right m -> return (IncomingMsg m Nothing, False) + Left e -> return (IncomingError e, False) + + requestSTM h i = do + let rq = fromJust $ i `M.lookup` h + h' = M.delete i h + writeTVar (sentRequests qs) h' + t <- readTVar $ isLast qs + return (rq, c && t && M.null h') + + decodeMsg h bs = case eitherDecodeStrict' bs of + Left _ -> Left $ errorParse ver Null + Right v -> case parseEither (topParse h) v of + Left _ -> Left $ errorParse ver Null + Right x -> x + + topParse h v = parseReq v + <|> parseNot v + <|> parseRes h v + <|> return (Left $ errorInvalid ver v) + + parseRes h = withObject "response" $ \o -> do + r <- o .:? "result" .!= Null + e <- o .:? "error" .!= Null + when (r == Null && e == Null) mzero + i <- o .:? "id" .!= IdNull + j <- o .:? "jsonrpc" + let ver' = if j == Just ("2.0" :: Text) then V2 else V1 + case i of + IdNull -> + Right . MsgError <$> parseJSON (Object o) + _ -> case M.lookup i h of + Nothing -> return . Left $ errorId ver' i + Just rq -> do + rsE <- parseResponse rq (Object o) + return $ case rsE of + Left er -> Right $ MsgError er + Right rs -> Right $ MsgResponse rs + + parseReq v = flip fmap (parseRequest v) $ \rqE -> case rqE of + Left e -> Left e + Right rq -> Right $ MsgRequest rq + + parseNot v = flip fmap (parseNotif v) $ \rnE -> case rnE of + Left e -> Left e + Right rn -> Right $ MsgNotif rn + +-- | Send requests and get responses (or errors). +-- +-- Example: +-- +-- >tcpClient V2 True (clientSettings 31337 "127.0.0.1") (query V2 [TimeReq]) +query :: (ToJSON qo, ToRequest qo, FromResponse ri) + => Ver -- ^ JSON-RPC version + -> [qo] -- ^ List of requests + -> AppConduits qo () () () () ri IO -- ^ Message conduits + -> IO [IncomingMsg qo () () ri] -- ^ Incoming messages +query ver qs (src, snk) = withAsync (src $$ CL.consume) $ \a -> do + link a + CL.sourceList qs $= CL.map (MsgRequest . buildRequest ver) $$ snk + wait a + +-- Will create JSON-RPC conduits around 'ByteString' conduits from a transport +-- layer. +runConduits :: ( FromRequest qi, FromNotif ni, FromResponse ri + , ToJSON qo, ToJSON no, ToJSON ro ) + => Ver -- ^ JSON-RPC version + -> Bool -- ^ Disconnect on last response + -> Sink ByteString IO () -- ^ Sink to send messages + -> Source IO ByteString -- ^ Source of incoming messages + -> (AppConduits qo no ro qi ni ri IO -> IO a) + -- ^ JSON-RPC action + -> IO a -- ^ Output of action +runConduits ver d rpcSnk rpcSrc f = do + (reqChan, msgChan) <- atomically $ (,) <$> newTBMChan 128 <*> newTBMChan 128 + let inbSrc = sourceTBMChan msgChan + inbSnk = sinkTBMChan msgChan True + outSrc = sourceTBMChan reqChan + outSnk = sinkTBMChan reqChan True + withAsync (rpcThread outSrc inbSnk) (g inbSrc outSnk) + where + rpcThread outSrc inbSnk = do + qs <- atomically initSession + withAsync (outThread qs outSrc) $ \a -> do + link a + _ <- rpcSrc $= decodeConduit ver d qs $$ inbSnk + wait a + outThread qs outSrc = outSrc $= msgConduit qs $= encodeConduit $$ rpcSnk + g inbSrc outSnk a = do + link a + x <- f (inbSrc, outSnk) + _ <- wait a + return x + +-- JSON-RPC-over-TCP client. +tcpClient :: ( FromRequest qi, FromNotif ni, FromResponse ri + , ToJSON qo, ToJSON no, ToJSON ro ) + => Ver -- ^ JSON-RPC version + -> Bool -- ^ Disconnect on last response + -> ClientSettings -- ^ Connection settings + -> (AppConduits qo no ro qi ni ri IO -> IO a) + -- ^ JSON-RPC action + -> IO a -- ^ Output of action +tcpClient ver d cs f = runTCPClient cs $ \ad -> do + runConduits ver d (appSink ad) (appSource ad) f + +-- JSON-RPC-over-TCP server. +tcpServer :: ( FromRequest qi, FromNotif ni, FromResponse ri + , ToJSON qo, ToJSON no, ToJSON ro ) + => Ver -- ^ JSON-RPC version + -> ServerSettings -- ^ Connection settings + -> (AppConduits qo no ro qi ni ri IO -> IO ()) + -- ^ JSON-RPC action to perform on connecting client thread + -> IO () +tcpServer ver ss f = runTCPServer ss $ \cl -> do + runConduits ver False (appSink cl) (appSource cl) f + diff --git a/Network/JsonRpc/Data.hs b/Network/JsonRpc/Data.hs new file mode 100644 --- /dev/null +++ b/Network/JsonRpc/Data.hs @@ -0,0 +1,375 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +-- | Implementation of basic JSON-RPC data types. +module Network.JsonRpc.Data +( -- * Requests + Request(..) + -- ** Parsing +, FromRequest(..) +, parseRequest + -- ** Encoding +, ToRequest(..) +, buildRequest + + -- * Responses +, Response(..) + -- ** Parsing +, FromResponse(..) +, parseResponse + + -- * Notifications +, Notif(..) + -- ** Parsing +, FromNotif(..) +, parseNotif + -- ** Encoding +, ToNotif(..) +, buildNotif + + -- * Errors +, ErrorObj(..) + -- ** Error Messages +, errorParse +, errorInvalid +, errorParams +, errorMethod +, errorId + + -- * Others +, Message(..) +, Method +, Id(..) +, Ver(..) + +) where + +import Control.Applicative ((<$>), (<*>), (<|>)) +import Control.DeepSeq (NFData, rnf) +import Control.Monad (when, guard, mzero) +import Data.Aeson.Types +import Data.Hashable (Hashable) +import Data.Text (Text) +import GHC.Generics (Generic) + + + +-- +-- Requests +-- + +-- Request data type. +data Request q = Request { getReqVer :: !Ver -- Version + , getReqMethod :: !Method -- Method + , getReqParams :: !q -- Params + , getReqId :: !Id -- Id + } deriving (Eq, Show, Read) + +instance NFData q => NFData (Request q) where + rnf (Request v m q i) = rnf v `seq` rnf m `seq` rnf q `seq` rnf i + +instance ToJSON q => ToJSON (Request q) where + toJSON (Request V2 m p i) = object $ case toJSON p of + Null -> [jr2, "method" .= m, "id" .= i] + v -> [jr2, "method" .= m, "id" .= i, "params" .= v] + toJSON (Request V1 m p i) = object $ case toJSON p of + Null -> ["method" .= m, "params" .= emptyArray, "id" .= i] + v -> ["method" .= m, "params" .= v, "id" .= i] + +-- | Class for data that can be received in JSON-RPC requests. +class FromRequest q where + -- | Parser for params field. + paramsParser :: Method -> Maybe (Value -> Parser q) + +instance FromRequest Value where + paramsParser _ = Just return + +instance FromRequest () where + paramsParser _ = Nothing + +-- | Parse JSON-RPC request. +parseRequest :: FromRequest q => Value -> Parser (Either ErrorObj (Request q)) +parseRequest = withObject "request" $ \o -> do + j <- o .:? "jsonrpc" + i <- o .: "id" + when (i == IdNull) $ fail "Request must have non-null id" + m <- o .: "method" + p <- o .:? "params" .!= Null + let ver = if j == Just ("2.0" :: Text) then V2 else V1 + case paramsParser m of + Nothing -> return (Left (errorMethod ver m i)) + Just x -> parseIt ver m i x p <|> return (Left (errorParams ver p i)) + where + parseIt ver m i x p = (\y -> Right (Request ver m y i)) <$> x p + +-- | Class for data that can be sent as JSON-RPC requests. +-- Define a method name for each request. +class ToRequest q where + requestMethod :: q -> Method + +instance ToRequest Value where + requestMethod _ = "" + +instance ToRequest () where + requestMethod _ = undefined + +-- Build JSON-RPC request. +buildRequest :: ToRequest q + => Ver -- ^ JSON-RPC version + -> q -- ^ Request data + -> Request q +buildRequest ver q = Request ver (requestMethod q) q IdNull + + + +-- +-- Responses +-- + +-- | JSON-RPC response data type +data Response r = Response { getResVer :: !Ver -- ^ Version + , getResult :: !r -- ^ Result + , getResId :: !Id -- ^ Id + } deriving (Eq, Show, Read) + +instance NFData r => NFData (Response r) where + rnf (Response v r i) = rnf v `seq` rnf r `seq` rnf i + +instance ToJSON r => ToJSON (Response r) where + toJSON (Response V1 r i) = object + ["id" .= i, "result" .= r, "error" .= Null] + toJSON (Response V2 r i) = object + [jr2, "id" .= i, "result" .= r] + +-- | Class for data that can be received inside JSON-RPC responses. +class FromResponse r where + -- | Parse result field from JSON-RPC response. + parseResult :: Method -> Value -> Parser r + +instance FromResponse Value where + parseResult _ = return + +instance FromResponse () where + parseResult _ _ = return () + +-- | Parse JSON-RPC response. +parseResponse :: FromResponse r + => Request q -> Value -> Parser (Either ErrorObj (Response r)) +parseResponse rq = withObject "response" $ \o -> do + let m = getReqMethod rq + qi = getReqId rq + j <- o .:? "jsonrpc" + i <- o .: "id" + when (i == IdNull) $ fail "Response must have non-null id" + when (qi /= i) $ fail "Response id mismatch" + let ver = if j == Just ("2.0" :: Text) then V2 else V1 + (Right <$> parseRes ver i m o) <|> (Left <$> parseJSON (Object o)) + where + parseRes ver i m o = do + v <- o .: "result" + guard $ v /= Null + r <- parseResult m v + return $ Response ver r i + + + +-- +-- Notifications +-- + +-- | Class for JSON-RPC notifications. +data Notif n = Notif { getNotifVer :: !Ver -- ^ Version + , getNotifMethod :: !Method -- ^ Method + , getNotifParams :: !n -- ^ Params + } deriving (Eq, Show, Read) + +instance NFData n => NFData (Notif n) where + rnf (Notif v m n) = rnf v `seq` rnf m `seq` rnf n + +instance ToJSON n => ToJSON (Notif n) where + toJSON (Notif V2 m p) = object $ case toJSON p of + Null -> [jr2, "method" .= m] + v -> [jr2, "method" .= m, "params" .= v] + toJSON (Notif V1 m p) = object $ case toJSON p of + Null -> ["method" .= m, "params" .= emptyArray, "id" .= Null] + v -> ["method" .= m, "params" .= v, "id" .= Null] + +-- | Class for data that can be received in JSON-RPC notifications. +class FromNotif n where + -- | Parser for notification params field + notifParamsParser :: Method -> Maybe (Value -> Parser n) + +instance FromNotif Value where + notifParamsParser _ = Just return + +instance FromNotif () where + notifParamsParser _ = Nothing + +-- | Parse notifications. +parseNotif :: FromNotif n => Value -> Parser (Either ErrorObj (Notif n)) +parseNotif = withObject "notification" $ \o -> do + j <- o .:? "jsonrpc" + i <- o .:? "id" .!= IdNull + m <- o .: "method" + p <- o .:? "params" .!= Null + guard $ i == IdNull + let ver = if j == Just ("2.0" :: Text) then V2 else V1 + case notifParamsParser m of + Nothing -> return (Left $ errorMethod ver m IdNull) + Just x -> f ver m x p <|> return (Left (errorParams ver p i)) + where + f ver m x p = (Right . Notif ver m) <$> x p + +class ToNotif n where + notifMethod :: n -> Method + +instance ToNotif Value where + notifMethod _ = "" + +instance ToNotif () where + notifMethod _ = undefined + +-- | Build notifications. +buildNotif :: ToNotif n + => Ver -- ^ Version + -> n -- ^ Notification data + -> Notif n +buildNotif ver n = Notif ver (notifMethod n) n + + + +-- +-- Errors +-- + +-- | JSON-RPC errors. +data ErrorObj = ErrorObj { getErrVer :: !Ver -- ^ Version + , getErrMsg :: !String -- ^ Message + , getErrCode :: !Int -- ^ Error code (2.0) + , getErrData :: !Value -- ^ Error data (2.0) + , getErrId :: !Id -- ^ Error id + } deriving (Eq, Show) + +instance NFData ErrorObj where + rnf (ErrorObj v m c d i) = + rnf v `seq` rnf m `seq` rnf c `seq` rnf d `seq` rnf i + +instance FromJSON ErrorObj where + parseJSON = withObject "error" $ \o -> do + i <- o .:? "id" .!= IdNull + j <- o .:? "jsonrpc" + let ver = if j == Just ("2.0" :: Text) then V2 else V1 + case ver of + V2 -> o .: "error" >>= \e -> case e of + (Object b) -> ErrorObj V2 <$> b .: "message" + <*> b .: "code" + <*> b .:? "data" .!= Null + <*> return i + _ -> fail "JSON-RPC 2.0 error must be a JSON object" + V1 -> o .: "error" >>= \e -> return $ ErrorObj V1 e 0 Null i + +instance ToJSON ErrorObj where + toJSON (ErrorObj V2 m c d i) = object [jr2, "id" .= i, "error" .= o] where + o = case d of + Null -> object ["code" .= c, "message" .= m] + _ -> object ["code" .= c, "message" .= m, "data" .= d] + toJSON (ErrorObj V1 m _ _ i) = + object ["id" .= i, "error" .= m, "result" .= Null] + +-- | Parse error. +errorParse :: Ver -> Value -> ErrorObj +errorParse ver v = ErrorObj ver "Parse error" (-32700) v IdNull + +-- | Invalid request. +errorInvalid :: Ver -> Value -> ErrorObj +errorInvalid ver v = ErrorObj ver "Invalid request" (-32600) v IdNull + +-- | Invalid params. +errorParams :: Ver -> Value -> Id -> ErrorObj +errorParams ver v i = ErrorObj ver "Invalid params" (-32602) v i + +-- | Method not found. +errorMethod :: Ver -> Method -> Id -> ErrorObj +errorMethod ver m i = ErrorObj ver "Method not found" (-32601) (toJSON m) i + +-- | Id not recognized. +errorId :: Ver -> Id -> ErrorObj +errorId ver i = ErrorObj ver "Id not recognized" (-32000) (toJSON i) IdNull + + + +-- +-- Messages +-- + +-- | Class for any JSON-RPC message. +data Message q n r + = MsgRequest { getMsgRequest :: !(Request q) } + | MsgNotif { getMsgNotif :: !(Notif n) } + | MsgResponse { getMsgResponse :: !(Response r) } + | MsgError { getMsgError :: !ErrorObj } + deriving (Eq, Show) + +instance (NFData q, NFData n, NFData r) => NFData (Message q n r) where + rnf (MsgRequest q) = rnf q + rnf (MsgNotif n) = rnf n + rnf (MsgResponse r) = rnf r + rnf (MsgError e) = rnf e + +instance (ToJSON q, ToJSON n, ToJSON r) => ToJSON (Message q n r) where + toJSON (MsgRequest rq) = toJSON rq + toJSON (MsgNotif rn) = toJSON rn + toJSON (MsgResponse rs) = toJSON rs + toJSON (MsgError e) = toJSON e + +-- +-- Types +-- + +-- | JSON-RPC methods in requests and notifications. +type Method = Text + +-- | JSON-RPC message id. +data Id = IdInt { getIdInt :: !Int } + | IdTxt { getIdTxt :: !Text } + | IdNull + deriving (Eq, Show, Read, Generic) + +instance Hashable Id + +instance NFData Id where + rnf (IdInt i) = rnf i + rnf (IdTxt t) = rnf t + rnf _ = () + +instance Enum Id where + toEnum i = IdInt i + fromEnum (IdInt i) = i + fromEnum _ = error $ "Can't enumerate non-integral ids" + +instance FromJSON Id where + parseJSON s@(String _) = IdTxt <$> parseJSON s + parseJSON n@(Number _) = IdInt <$> parseJSON n + parseJSON Null = return $ IdNull + parseJSON _ = mzero + +instance ToJSON Id where + toJSON (IdTxt s) = toJSON s + toJSON (IdInt n) = toJSON n + toJSON IdNull = Null + +-- | JSON-RPC version +data Ver = V1 -- ^ JSON-RPC 1.0 + | V2 -- ^ JSON-RPC 2.0 + deriving (Eq, Show, Read) + +instance NFData Ver + + + +-- +-- Helpers +-- + +jr2 :: Pair +jr2 = "jsonrpc" .= ("2.0" :: Text) + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,124 @@ +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 +partially-compatible with JSON-RPC 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. + +The recommended interface to this library is provided as conduits that encode +outgoing messages, and decode incoming messages. Incoming messages are +delivered as an IncomingMsg data structure, while outgoing messages are sent in +a Message data structure. The former packs responses and errors with their +corresponding request, and has a separate constructor for decoding errors. + +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. + +Type classes ToRequest, ToNotif are for data that can be converted into +JSON-RPC requests and notifications respectively. An instance of aeson's ToJSON +class is also required to serialize these data structures. Make sure that they +serialize as a structured JSON value (array or object) that can go into the +params field of the JSON-RPC object. Type classes FromRequest, FromNotif and +FromResult are for deserializing JSON-RPC messages. + +Errors are deserialized to the ErrorObj data type. Only a string is supported +as contents inside a JSON-RPC 1.0 error. JSON-RPC 2.0 errors also have a code, +and possibly additional data as an aeson Value. + + +Server Example +-------------- + +This server returns the current time. + +``` haskell +{-# LANGUAGE OverloadedStrings #-} +import Data.Aeson.Types +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.Network +import Data.Time.Clock +import Data.Time.Format +import Network.JsonRpc +import System.Locale + +data TimeReq = TimeReq +data TimeRes = TimeRes UTCTime + +instance FromRequest TimeReq where + paramsParser "time" = Just $ const $ return TimeReq + paramsParser _ = Nothing + +instance ToJSON TimeRes where + toJSON (TimeRes t) = toJSON $ formatTime defaultTimeLocale "%c" t + +srv :: AppConduits () () TimeRes TimeReq () () IO -> IO () +srv (src, snk) = src $= CL.mapM respond $$ snk + +respond :: IncomingMsg () TimeReq () () + -> IO (Message () () TimeRes) +respond (IncomingMsg (MsgRequest (Request ver _ TimeReq i)) Nothing) = do + t <- getCurrentTime + return $ MsgResponse (Response ver (TimeRes t) i) + +respond (IncomingError e) = return $ MsgError e +respond (IncomingMsg (MsgError e) _) = return $ MsgError $ e +respond _ = undefined + +main :: IO () +main = tcpServer V2 (serverSettings 31337 "127.0.0.1") srv +``` + +Client Example +-------------- + +Corresponding TCP client to get time from server. + +``` haskell +{-# LANGUAGE OverloadedStrings #-} +import Data.Aeson.Types hiding (Error) +import Data.Conduit +import qualified Data.Conduit.List as CL +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 TimeReq = TimeReq +data TimeRes = TimeRes UTCTime + +instance ToRequest TimeReq where + requestMethod TimeReq = "time" + +instance ToJSON TimeReq where + toJSON TimeReq = emptyArray + +instance FromResponse TimeRes where + parseResult "time" = withText "time" $ \t -> case f t of + Nothing -> fail "Could not parse time" + Just t' -> return $ TimeRes t' + where + f t = parseTime defaultTimeLocale "%c" (T.unpack t) + +cli :: AppConduits TimeReq () () () () TimeRes IO + -> IO UTCTime +cli (src, snk) = do + CL.sourceList [MsgRequest $ buildRequest V2 TimeReq] $$ snk + ts <- src $$ CL.consume + case ts of + [] -> error "No response received" + [IncomingError (ErrorObj _ m _ _ _)] -> error $ "Unknown: " ++ m + [IncomingMsg (MsgError (ErrorObj _ m _ _ _)) _] -> error m + [IncomingMsg (MsgResponse (Response _ (TimeRes t) _)) _] -> return t + _ -> undefined + +main :: IO () +main = tcpClient V2 True (clientSettings 31337 "127.0.0.1") cli >>= print +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/UNLICENSE b/UNLICENSE new file mode 100644 --- /dev/null +++ b/UNLICENSE @@ -0,0 +1,24 @@ +This is free and unencumbered software released into the public domain. + +Anyone is free to copy, modify, publish, use, compile, sell, or +distribute this software, either in source code form or as a compiled +binary, for any purpose, commercial or non-commercial, and by any +means. + +In jurisdictions that recognize copyright laws, the author or authors +of this software dedicate any and all copyright interest in the +software to the public domain. We make this dedication for the benefit +of the public at large and to the detriment of our heirs and +successors. We intend this dedication to be an overt act of +relinquishment in perpetuity of all present and future rights to this +software under copyright law. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR +OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, +ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. + +For more information, please refer to diff --git a/json-rpc.cabal b/json-rpc.cabal new file mode 100644 --- /dev/null +++ b/json-rpc.cabal @@ -0,0 +1,64 @@ +name: json-rpc +version: 0.1.0.0 +synopsis: Fully-featured JSON-RPC 2.0 library +description: + This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and + partially-compatible with JSON-RPC 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. +homepage: https://github.com/xenog/json-rpc +license: PublicDomain +license-file: UNLICENSE +author: Jean-Pierre Rupp +maintainer: root@haskoin.com +category: Network +build-type: Simple +extra-source-files: README.md +cabal-version: >= 1.10 + +library + exposed-modules: Network.JsonRpc + other-modules: Network.JsonRpc.Data, + Network.JsonRpc.Conduit + build-depends: base >= 4.6 && < 5, + aeson >= 0.7.0.5 && < 0.8, + async >= 2.0 && < 2.1, + bytestring >= 0.10 && < 0.11, + conduit >= 1.1 && < 1.2, + conduit-extra >= 1.1 && < 1.2, + deepseq >= 1.3 && < 1.4, + hashable >= 1.2 && < 1.3, + mtl >= 2.1 && < 2.2, + stm >= 2.4 && < 2.5, + stm-conduit >= 2.4 && < 2.5, + text >= 1.1 && < 1.2, + unordered-containers >= 0.2 && < 0.3 + default-language: Haskell2010 + ghc-options: -Wall + +test-suite test-json-rpc + hs-source-dirs: test + type: exitcode-stdio-1.0 + main-is: main.hs + other-modules: Network.JsonRpc.Tests, + Network.JsonRpc.Arbitrary + build-depends: base >= 4.6 && < 5, + aeson >= 0.7.0.5 && < 0.8, + async >= 2.0 && < 2.1, + bytestring >= 0.10 && < 0.11, + conduit >= 1.1 && < 1.2, + conduit-extra >= 1.1 && < 1.2, + deepseq >= 1.3 && < 1.4, + hashable >= 1.2 && < 1.3, + json-rpc >= 0.1 && < 0.2, + mtl >= 2.1 && < 2.2, + stm >= 2.4 && < 2.5, + stm-conduit >= 2.4 && < 2.5, + text >= 1.1 && < 1.2, + unordered-containers >= 0.2 && < 0.3, + QuickCheck >= 2.6 && < 2.7, + test-framework >= 0.8 && < 0.9, + test-framework-quickcheck2 >= 0.3 && < 0.4 + default-language: Haskell2010 + ghc-options: -Wall diff --git a/test/Network/JsonRpc/Arbitrary.hs b/test/Network/JsonRpc/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/test/Network/JsonRpc/Arbitrary.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | Arbitrary instances and data types for use in test suites. +module Network.JsonRpc.Arbitrary +( -- * Arbitrary Data + ReqRes(..) +) where + +import Control.Applicative +import Data.Aeson.Types hiding (Error) +import qualified Data.HashMap.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Network.JsonRpc +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen + +-- | A pair of a request and its corresponding response. +-- Id and version should match. +data ReqRes q r = ReqRes !(Request q) !(Response r) + deriving (Show, Eq) + +instance Arbitrary (ReqRes Value Value) where + arbitrary = do + rq <- arbitrary + rs <- arbitrary + let rs' = rs { getResId = getReqId rq, getResVer = getReqVer rq } + return $ ReqRes rq rs' + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + +instance Arbitrary Ver where + arbitrary = elements [V1, V2] + +instance (Arbitrary q, ToRequest q) => Arbitrary (Request q) where + arbitrary = do + q <- arbitrary + v <- arbitrary + let m = requestMethod q + Request v m q <$> arbitrary + +instance (Arbitrary n, ToNotif n) => Arbitrary (Notif n) where + arbitrary = do + n <- arbitrary + v <- arbitrary + let m = notifMethod n + return $ Notif v m n + +instance Arbitrary r => Arbitrary (Response r) where + arbitrary = Response <$> arbitrary <*> arbitrary <*> arbitrary + +instance Arbitrary ErrorObj where + arbitrary = ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary + <*> arbitrary <*> arbitrary + +instance ( Arbitrary q, Arbitrary n, Arbitrary r + , ToRequest q, ToNotif n, ToJSON r ) + => Arbitrary (Message q n r) + where + arbitrary = oneof [ MsgRequest <$> arbitrary + , MsgNotif <$> arbitrary + , MsgResponse <$> arbitrary + , MsgError <$> arbitrary ] + +instance Arbitrary Id where + arbitrary = oneof [IdInt <$> arbitrary, IdTxt <$> arbitrary] + +instance Arbitrary Value where + arbitrary = resize 10 $ oneof [val, lsn, objn] where + val = oneof [ toJSON <$> (arbitrary :: Gen String) + , toJSON <$> (arbitrary :: Gen Int) + , toJSON <$> (arbitrary :: Gen Double) + , toJSON <$> (arbitrary :: Gen Bool) ] + ls = toJSON <$> listOf val + obj = toJSON . M.fromList <$> listOf ps + ps = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls] + lsn = toJSON <$> listOf (oneof [ls, obj, val]) + objn = toJSON . M.fromList <$> listOf psn + psn = (,) <$> (arbitrary :: Gen String) <*> oneof [val, ls, obj] + diff --git a/test/Network/JsonRpc/Tests.hs b/test/Network/JsonRpc/Tests.hs new file mode 100644 --- /dev/null +++ b/test/Network/JsonRpc/Tests.hs @@ -0,0 +1,392 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE Rank2Types #-} +module Network.JsonRpc.Tests (tests) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad +import Data.Aeson.Types hiding (Error) +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.List +import Data.Conduit.TMChan +import qualified Data.HashMap.Strict as M +import Data.Maybe +import Data.Text (Text) +import Network.JsonRpc +import Network.JsonRpc.Arbitrary +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Test.Framework +import Test.Framework.Providers.QuickCheck2 + +tests :: [Test] +tests = + [ testGroup "JSON-RPC Requests" + [ testProperty "Check fields" + (reqFields :: Request Value -> Bool) + , testProperty "Encode/decode" + (reqDecode :: Request Value -> Bool) + ] + , testGroup "JSON-RPC Notifications" + [ testProperty "Check fields" + (notifFields :: Notif Value -> Bool) + , testProperty "Encode/decode" + (notifDecode :: Notif Value -> Bool) + ] + , testGroup "JSON-RPC Responses" + [ testProperty "Check fields" + (resFields :: Response Value -> Bool) + , testProperty "Encode/decode" + (resDecode :: ReqRes Value Value -> Bool) + , testProperty "Bad response id" + (rpcBadResId :: ReqRes Value Value -> Bool) + , testProperty "Error response" + (rpcErrRes :: (ReqRes Value Value, ErrorObj) -> Bool) + ] + , testGroup "JSON-RPC Conduits" + [ testProperty "Outgoing conduit" + (newMsgConduit :: [Message Value Value Value] -> Property) + , testProperty "Decode requests" + (decodeReqConduit :: ([Request Value], Ver) -> Property) + , testProperty "Decode responses" + (decodeResConduit :: ([ReqRes Value Value], Ver) -> Property) + , testProperty "Bad responses" + (decodeErrConduit :: ([ReqRes Value Value], Ver) -> Property) + , testProperty "Sending messages" sendMsgNet + , testProperty "Two-way communication" twoWayNet + ] + ] + +-- +-- Requests +-- + +reqFields :: (ToRequest a, ToJSON a) => Request a -> Bool +reqFields rq = case rq of + Request V1 m p i -> r1ks && vals m p i + Request V2 m p i -> r2ks && vals m p i + where + (Object o) = toJSON rq + r1ks = sort (M.keys o) == ["id", "method", "params"] + r2ks = sort (M.keys o) == ["id", "jsonrpc", "method", "params"] + || sort (M.keys o) == ["id", "jsonrpc", "method"] + vals m p i = fromMaybe False $ parseMaybe (f m p i) o + f m p i _ = do + j <- o .:? "jsonrpc" + guard $ fromMaybe True $ fmap (== ("2.0" :: Text)) j + i' <- o .: "id" + guard $ i == i' + m' <- o .: "method" + guard $ m == m' + p' <- o .:? "params" .!= Null + guard $ (toJSON p) == p' + return True + +reqDecode :: (Eq a, ToRequest a, ToJSON a, FromRequest a) => Request a -> Bool +reqDecode rq = case parseMaybe parseRequest (toJSON rq) of + Nothing -> False + Just rqE -> either (const False) (rq ==) rqE + +-- +-- Notifications +-- + +notifFields :: (ToNotif a, ToJSON a) => Notif a -> Bool +notifFields rn = case rn of + Notif V1 m p -> n1ks && vals m p + Notif V2 m p -> n2ks && vals m p + where + (Object o) = toJSON rn + n1ks = sort (M.keys o) == ["id", "method", "params"] + n2ks = sort (M.keys o) == ["jsonrpc", "method", "params"] + || sort (M.keys o) == ["jsonrpc", "method"] + vals m p = fromMaybe False $ parseMaybe (f m p) o + f m p _ = do + i <- o .:? "id" .!= Null + guard $ i == Null + j <- o .:? "jsonrpc" + guard $ fromMaybe True $ fmap (== ("2.0" :: Text)) j + m' <- o .: "method" + guard $ m == m' + p' <- o .:? "params" .!= Null + guard $ (toJSON p) == p' + return True + +notifDecode :: (Eq a, ToNotif a, ToJSON a, FromNotif a) + => Notif a -> Bool +notifDecode rn = case parseMaybe parseNotif (toJSON rn) of + Nothing -> False + Just rnE -> either (const False) (rn ==) rnE + +-- +-- Responses +-- + +resFields :: (Eq a, ToJSON a, FromJSON a) => Response a -> Bool +resFields rs = case rs of + Response V1 s i -> s1ks && vals s i + Response V2 s i -> s2ks && vals s i + where + (Object o) = toJSON rs + s1ks = sort (M.keys o) == ["error", "id", "result"] + s2ks = sort (M.keys o) == ["id", "jsonrpc", "result"] + vals s i = fromMaybe False $ parseMaybe (f s i) o + f s i _ = do + i' <- o .: "id" + guard $ i == i' + j <- o .:? "jsonrpc" + guard $ fromMaybe True $ fmap (== ("2.0" :: Text)) j + s' <- o .: "result" + guard $ s == s' + e <- o .:? "error" .!= Null + guard $ e == Null + return True + +resDecode :: (Eq r, ToJSON r, FromResponse r) + => ReqRes q r -> Bool +resDecode (ReqRes rq rs) = case parseMaybe (parseResponse rq) (toJSON rs) of + Nothing -> False + Just rsE -> either (const False) (rs ==) rsE + +rpcBadResId :: forall q r. (ToJSON r, FromResponse r) + => ReqRes q r -> Bool +rpcBadResId (ReqRes rq rs) = case parseMaybe f (toJSON rs') of + Nothing -> True + _ -> False + where + f :: FromResponse r => Value -> Parser (Either ErrorObj (Response r)) + f = parseResponse rq + rs' = rs { getResId = IdNull } + +rpcErrRes :: forall q r. FromResponse r => (ReqRes q r, ErrorObj) -> Bool +rpcErrRes (ReqRes rq _, re) = case parseMaybe f (toJSON re') of + Nothing -> False + Just (Left _) -> True + _ -> False + where + f :: FromResponse r => Value -> Parser (Either ErrorObj (Response r)) + f = parseResponse rq + re' = re { getErrId = getReqId rq } + +-- +-- Conduit +-- + +newMsgConduit :: ( ToRequest q, ToJSON q, ToNotif n, ToJSON n + , ToJSON r, FromResponse r ) + => [Message q n r] -> Property +newMsgConduit (snds) = monadicIO $ do + msgs <- run $ do + qs <- atomically initSession + CL.sourceList snds' $= msgConduit qs $$ CL.consume + assert $ length msgs == length snds' + assert $ length (filter rqs msgs) == length (filter rqs snds') + assert $ map idn (filter rqs msgs) == take (length (filter rqs msgs)) [1..] + where + rqs (MsgRequest _) = True + rqs _ = False + idn (MsgRequest rq) = getIdInt $ getReqId rq + idn _ = error "Unexpected request" + snds' = flip map snds $ \m -> case m of + (MsgRequest rq) -> MsgRequest $ rq { getReqId = IdNull } + _ -> m + +decodeReqConduit :: forall q. (ToRequest q, FromRequest q, Eq q, ToJSON q) + => ([Request q], Ver) -> Property +decodeReqConduit (vs, ver) = monadicIO $ do + inmsgs <- run $ do + qs <- atomically initSession + qs' <- atomically initSession + CL.sourceList vs + $= CL.map f + $= msgConduit qs + $= encodeConduit + $= decodeConduit ver True qs' + $$ CL.consume + assert $ null $ filter unexpected inmsgs + assert $ all (uncurry match) (zip vs inmsgs) + where + unexpected :: IncomingMsg () q () () -> Bool + unexpected (IncomingMsg (MsgRequest _) Nothing) = False + unexpected _ = True + match rq (IncomingMsg (MsgRequest rq') _) = + rq { getReqId = getReqId rq' } == rq' + match _ _ = False + f rq = MsgRequest $ rq { getReqId = IdNull } :: Message q () () + +decodeResConduit :: forall q r. + ( ToRequest q, FromRequest q, Eq q, ToJSON q, ToJSON r + , FromResponse r, Eq r ) + => ([ReqRes q r], Ver) -> Property +decodeResConduit (rr, ver) = monadicIO $ do + inmsgs <- run $ do + qs <- atomically initSession + qs' <- atomically initSession + CL.sourceList vs + $= CL.map f + $= msgConduit qs + $= encodeConduit + $= decodeConduit ver True qs' + $= CL.map respond + $= encodeConduit + $= decodeConduit ver True qs + $$ CL.consume + assert $ null $ filter unexpected inmsgs + assert $ all (uncurry match) (zip vs inmsgs) + where + unexpected :: IncomingMsg q () () r -> Bool + unexpected (IncomingMsg (MsgResponse _) (Just _)) = False + unexpected _ = True + + match rq (IncomingMsg (MsgResponse rs) (Just rq')) = + rq { getReqId = getReqId rq' } == rq' + && rs == g rq' + match _ _ = False + + respond :: IncomingMsg () q () () -> Response r + respond (IncomingMsg (MsgRequest rq) Nothing) = g rq + respond _ = undefined + + f rq = MsgRequest $ rq { getReqId = IdNull } :: Message q () () + vs = map (\(ReqRes rq _) -> rq) rr + + g rq = let (ReqRes _ rs) = fromJust $ find h rr + h (ReqRes rq' _) = getReqParams rq == getReqParams rq' + in rs { getResId = getReqId rq } + +decodeErrConduit :: forall q r. + ( ToRequest q, FromRequest q, Eq q, ToJSON q, ToJSON r + , FromResponse r, Eq r, Show r, Show q ) + => ([ReqRes q r], Ver) -> Property +decodeErrConduit (vs, ver) = monadicIO $ do + inmsgs <- run $ do + qs <- atomically initSession + qs' <- atomically initSession + CL.sourceList vs + $= CL.map f + $= msgConduit qs + $= encodeConduit + $= decodeConduit ver True qs' + $= CL.map respond + $= encodeConduit + $= decodeConduit ver True qs + $$ CL.consume + assert $ null $ filter unexpected inmsgs + assert $ all (uncurry match) (zip vs inmsgs) + where + unexpected :: IncomingMsg q () () r -> Bool + unexpected (IncomingMsg (MsgError _) (Just _)) = False + -- unexpected _ = True + unexpected i = error $ show i + + match (ReqRes rq _) (IncomingMsg (MsgError _) (Just rq')) = + rq' { getReqId = getReqId rq } == rq + match _ _ = False + + respond :: IncomingMsg () q () () -> ErrorObj + respond (IncomingMsg (MsgRequest (Request ver' _ _ i)) Nothing) = + ErrorObj ver' "test" (getIdInt i) Null i + respond _ = undefined + + f (ReqRes rq _) = MsgRequest $ rq { getReqId = IdNull } :: Message q () () + +type ClientAppConduits = AppConduits Value Value Value () () () IO +type ServerAppConduits = AppConduits () () () Value Value Value IO + +sendMsgNet :: ([Message Value Value Value], Ver) -> Property +sendMsgNet (rs, ver) = monadicIO $ do + rt <- run $ do + mv <- newEmptyMVar + to <- atomically $ newTBMChan 128 + ti <- atomically $ newTBMChan 128 + let tiSink = sinkTBMChan ti True + toSource = sourceTBMChan to + toSink = sinkTBMChan to True + tiSource = sourceTBMChan ti + withAsync (srv tiSink toSource mv) $ \_ -> + runConduits ver False toSink tiSource (cliApp mv) + assert $ length rt == length rs + assert $ all (uncurry match) (zip rs rt) + where + srv tiSink toSource mv = runConduits ver False tiSink toSource (srvApp mv) + + srvApp :: MVar [IncomingMsg () Value Value Value] + -> ServerAppConduits -> IO () + srvApp mv (src, snk) = + (CL.sourceNull $$ snk) >> (src $$ CL.consume) >>= putMVar mv + + cliApp :: MVar [IncomingMsg () Value Value Value] + -> ClientAppConduits -> IO [IncomingMsg () Value Value Value] + cliApp mv (src, snk) = + (CL.sourceList rs $$ snk) >> (src $$ CL.sinkNull) >> readMVar mv + + match (MsgRequest rq) (IncomingMsg (MsgRequest rq') Nothing) = + rq == rq' + match (MsgNotif rn) (IncomingMsg (MsgNotif rn') Nothing) = + rn == rn' + match (MsgResponse _) (IncomingError e) = + getErrMsg e == "Id not recognized" + match (MsgError e) (IncomingMsg (MsgError e') Nothing) = + getErrMsg e == getErrMsg e' + match (MsgError _) (IncomingError e) = + getErrMsg e == "Id not recognized" + match _ _ = False + +type TwoWayAppConduits = AppConduits Value Value Value Value Value Value IO + +twoWayNet :: ([Message Value Value Value], Ver) -> Property +twoWayNet (rr, ver) = monadicIO $ do + rt <- run $ do + to <- atomically $ newTBMChan 128 + ti <- atomically $ newTBMChan 128 + let tiSink = sinkTBMChan ti True + toSource = sourceTBMChan to + toSink = sinkTBMChan to True + tiSource = sourceTBMChan ti + withAsync (srv tiSink toSource) $ \_ -> + runConduits ver False toSink tiSource cliApp + assert $ length rt == length rs + assert $ all (uncurry match) (zip rs rt) + where + rs = map f rr where + f (MsgRequest rq) = MsgRequest $ rq { getReqId = IdNull } + f m = m + + cliApp :: TwoWayAppConduits -> IO [IncomingMsg Value Value Value Value] + cliApp (src, snk) = (CL.sourceList rs $$ snk) >> (src $$ CL.consume) + + srv tiSink toSource = runConduits ver False tiSink toSource srvApp + + srvApp :: TwoWayAppConduits -> IO () + srvApp (src, snk) = src $= CL.map respond $$ snk + + respond (IncomingError e) = + MsgError e + respond (IncomingMsg (MsgRequest (Request ver' _ p i)) _) = + MsgResponse (Response ver' p i) + respond (IncomingMsg (MsgNotif rn) _) = + MsgNotif rn + respond (IncomingMsg (MsgError e) _) = + MsgNotif (Notif (getErrVer e) "error" (toJSON e)) + respond _ = undefined + + match (MsgRequest (Request ver' m p _)) + ( IncomingMsg (MsgResponse (Response ver'' p' _)) + (Just (Request ver''' m' p'' _)) ) = + p == p' && p == p'' && m == m' && ver' == ver'' && ver'' == ver''' + match (MsgNotif (Notif ver' _ p)) + (IncomingMsg (MsgNotif (Notif ver'' _ p')) Nothing) = + p == p' && ver' == ver'' + match (MsgResponse (Response ver' _ _)) + (IncomingMsg (MsgError e) Nothing) = + ver' == getErrVer e && getErrMsg e == "Id not recognized" + match (MsgError e@(ErrorObj _ _ _ _ IdNull)) + (IncomingMsg (MsgNotif (Notif _ "error" e')) Nothing) = + toJSON e == e' + match (MsgError _) + (IncomingMsg (MsgError e) Nothing) = + getErrMsg e == "Id not recognized" + match _ _ = False diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,6 @@ +import Test.Framework +import Network.JsonRpc.Tests + +main :: IO () +main = defaultMain (tests) +