diff --git a/Network/JsonRpc.hs b/Network/JsonRpc.hs deleted file mode 100644 --- a/Network/JsonRpc.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Network.JsonRpc -( -- * Introduction - -- $introduction - - module Network.JsonRpc.Interface -, module Network.JsonRpc.Data -) where - -import Network.JsonRpc.Interface -import Network.JsonRpc.Data -import Network.JsonRpc.Arbitrary() - --- $introduction --- --- 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. diff --git a/Network/JsonRpc/Arbitrary.hs b/Network/JsonRpc/Arbitrary.hs deleted file mode 100644 --- a/Network/JsonRpc/Arbitrary.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Network.JsonRpc.Arbitrary where - -import Control.Applicative -import Data.Aeson.Types -import qualified Data.HashMap.Strict as M -import Data.Text (Text) -import qualified Data.Text as T -import Network.JsonRpc.Data -import Test.QuickCheck.Arbitrary -import Test.QuickCheck.Gen - -instance Arbitrary Text where - arbitrary = T.pack <$> arbitrary - -instance Arbitrary Ver where - arbitrary = elements [V1, V2] - -instance Arbitrary Request where - arbitrary = oneof - [ Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - , Notif <$> arbitrary <*> arbitrary <*> arbitrary - ] - -instance Arbitrary Response where - arbitrary = oneof - [ Response <$> arbitrary <*> arbitrary <*> arbitrary - , ResponseError <$> arbitrary <*> arbitrary <*> arbitrary - , OrphanError <$> arbitrary <*> arbitrary - ] - - -instance Arbitrary ErrorObj where - arbitrary = oneof - [ ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary - , ErrorVal <$> arbitrary - ] - -instance Arbitrary BatchRequest where - arbitrary = oneof - [ BatchRequest <$> arbitrary - , SingleRequest <$> arbitrary - ] - -instance Arbitrary BatchResponse where - arbitrary = oneof - [ BatchResponse <$> arbitrary - , SingleResponse <$> arbitrary - ] - -instance Arbitrary Message where - arbitrary = oneof - [ MsgRequest <$> arbitrary - , MsgResponse <$> arbitrary - , MsgBatch <$> batch - ] - where - batch = listOf $ oneof [ MsgRequest <$> arbitrary - , MsgResponse <$> arbitrary - ] - -instance Arbitrary Id where - arbitrary = oneof [IdInt <$> arbitrary, IdTxt <$> arbitrary] - -instance Arbitrary Value where - arbitrary = resize 10 $ oneof [nonull, lsn, objn] where - nonull = oneof - [ toJSON <$> (arbitrary :: Gen String) - , toJSON <$> (arbitrary :: Gen Int) - , toJSON <$> (arbitrary :: Gen Double) - , toJSON <$> (arbitrary :: Gen Bool) - ] - val = oneof [ nonull, return Null ] - 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/Network/JsonRpc/Data.hs b/Network/JsonRpc/Data.hs deleted file mode 100644 --- a/Network/JsonRpc/Data.hs +++ /dev/null @@ -1,413 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveGeneric #-} --- | Implementation of basic JSON-RPC data types. -module Network.JsonRpc.Data -( -- * Requests - Request(..) -, BatchRequest(..) - -- ** Parsing -, FromRequest(..) -, fromRequest - -- ** Encoding -, ToRequest(..) -, buildRequest - - -- * Responses -, Response(..) -, BatchResponse(..) - -- ** Parsing -, FromResponse(..) -, fromResponse - -- ** Encoding -, Respond -, buildResponse - -- ** Errors -, ErrorObj(..) -, fromError - -- ** Error messages -, errorParse -, errorInvalid -, errorParams -, errorMethod -, errorId - - -- * Others -, Message(..) -, Method -, Id(..) -, fromId -, Ver(..) - -) where - -import Control.Applicative -import Data.ByteString (ByteString) -import qualified Data.ByteString.Lazy as L -import Control.DeepSeq -import Control.Monad -import Data.Aeson (encode) -import Data.Aeson.Types -import Data.Hashable (Hashable) -import Data.Maybe -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding -import GHC.Generics (Generic) - - --- --- Requests --- - -data Request = Request { getReqVer :: !Ver - , getReqMethod :: !Method - , getReqParams :: !Value - , getReqId :: !Id - } - | Notif { getReqVer :: !Ver - , getReqMethod :: !Method - , getReqParams :: !Value - } - deriving (Eq, Show, Generic) - -instance NFData Request where - rnf (Request v m p i) = rnf v `seq` rnf m `seq` rnf p `seq` rnf i - rnf (Notif v m p) = rnf v `seq` rnf m `seq` rnf p - -instance ToJSON Request where - toJSON (Request V2 m p i) = object $ case p of - Null -> [jr2, "method" .= m, "id" .= i] - _ -> [jr2, "method" .= m, "id" .= i, "params" .= p] - toJSON (Request V1 m p i) = object $ case p of - Null -> ["method" .= m, "params" .= emptyArray, "id" .= i] - _ -> ["method" .= m, "params" .= p, "id" .= i] - toJSON (Notif V2 m p) = object $ case p of - Null -> [jr2, "method" .= m] - _ -> [jr2, "method" .= m, "params" .= p] - toJSON (Notif V1 m p) = object $ case p of - Null -> ["method" .= m, "params" .= emptyArray, "id" .= Null] - _ -> ["method" .= m, "params" .= p, "id" .= Null] - -class FromRequest q where - -- | Parser for params Value in JSON-RPC request. - parseParams :: Method -> Maybe (Value -> Parser q) - -fromRequest :: FromRequest q => Request -> Either ErrorObj q -fromRequest req = - case parserM of - Nothing -> Left $ errorMethod m - Just parser -> - case parseMaybe parser p of - Nothing -> Left $ errorParams p - Just q -> Right q - where - m = getReqMethod req - p = getReqParams req - parserM = parseParams m - -instance FromRequest Value where - parseParams = const $ Just return - -instance FromRequest () where - parseParams = const . Just . const $ return () - -instance FromJSON Request where - parseJSON = withObject "request" $ \o -> do - (v, n, m, p) <- parseVerIdMethParams o - case n of Nothing -> return $ Notif v m p - Just i -> return $ Request v m p i - -parseVerIdMethParams :: Object -> Parser (Ver, Maybe Id, Method, Value) -parseVerIdMethParams o = do - v <- parseVer o - i <- o .:? "id" - m <- o .: "method" - p <- o .:? "params" .!= Null - return (v, i, m, p) - -class ToRequest q where - -- | Method associated with request data to build a request object. - requestMethod :: q -> Method - - -- | Is this request to be sent as a notification (no id, no response)? - requestIsNotif :: q -> Bool - -instance ToRequest Value where - requestMethod = const "json" - requestIsNotif = const False - -instance ToRequest () where - requestMethod = const "json" - requestIsNotif = const False - -buildRequest :: (ToJSON q, ToRequest q) - => Ver -- ^ JSON-RPC version - -> q -- ^ Request data - -> Id - -> Request -buildRequest ver q = if requestIsNotif q - then const $ Notif ver (requestMethod q) (toJSON q) - else Request ver (requestMethod q) (toJSON q) - --- --- Responses --- - -data Response = Response { getResVer :: !Ver - , getResult :: !Value - , getResId :: !Id - } - | ResponseError { getResVer :: !Ver - , getError :: !ErrorObj - , getResId :: !Id - } - | OrphanError { getResVer :: !Ver - , getError :: !ErrorObj - } - deriving (Eq, Show, Generic) - - -instance NFData Response where - rnf (Response v r i) = rnf v `seq` rnf r `seq` rnf i - rnf (ResponseError v o i) = rnf v `seq` rnf o `seq` rnf i - rnf (OrphanError v o) = rnf v `seq` rnf o - -instance ToJSON Response where - toJSON (Response V1 r i) = object - ["id" .= i, "result" .= r, "error" .= Null] - toJSON (Response V2 r i) = object - [jr2, "id" .= i, "result" .= r] - toJSON (ResponseError V1 e i) = object - ["id" .= i, "error" .= e, "result" .= Null] - toJSON (ResponseError V2 e i) = object - [jr2, "id" .= i, "error" .= e] - toJSON (OrphanError V1 e) = object - ["id" .= Null, "error" .= e, "result" .= Null] - toJSON (OrphanError V2 e) = object - [jr2, "id" .= Null, "error" .= e] - -class FromResponse r where - -- | Parser for result Value in JSON-RPC response. - -- Method corresponds to request to which this response answers. - parseResult :: Method -> Maybe (Value -> Parser r) - --- | Parse a response knowing the method of the corresponding request. -fromResponse :: FromResponse r => Method -> Response -> Maybe r -fromResponse m (Response _ r _) = parseResult m >>= flip parseMaybe r -fromResponse _ _ = Nothing - -instance FromResponse Value where - parseResult = const $ Just return - -instance FromResponse () where - parseResult = const Nothing - -instance FromJSON Response where - parseJSON = withObject "response" $ \o -> do - (v, d, s) <- parseVerIdResultError o - case s of - Right r -> do - guard $ isJust d - return $ Response v r (fromJust d) - Left e -> - case d of - Just i -> return $ ResponseError v e i - Nothing -> return $ OrphanError v e - -parseVerIdResultError :: Object - -> Parser (Ver, Maybe Id, Either ErrorObj Value) -parseVerIdResultError o = do - v <- parseVer o - i <- o .:? "id" - r <- o .:? "result" .!= Null - p <- if r == Null then Left <$> o .: "error" else return $ Right r - return (v, i, p) - --- | Create a response from a request. Use in servers. -buildResponse :: (Monad m, FromRequest q, ToJSON r) - => Respond q m r - -> Request - -> m (Maybe Response) -buildResponse f req@(Request v _ _ i) = - case fromRequest req of - Left e -> return . Just $ ResponseError v e i - Right q -> do - rE <- f q - case rE of - Left e -> return . Just $ ResponseError v e i - Right r -> return . Just $ Response v (toJSON r) i -buildResponse _ _ = return Nothing - --- | Type of function to make it easy to create a response from a request. --- Meant to be used in servers. -type Respond q m r = q -> m (Either ErrorObj r) - --- | Error object from JSON-RPC 2.0. ErrorVal for backwards compatibility. -data ErrorObj = ErrorObj { getErrMsg :: !String - , getErrCode :: !Int - , getErrData :: !Value - } - | ErrorVal { getErrData :: !Value } - deriving (Show, Eq, Generic) - -instance NFData ErrorObj where - rnf (ErrorObj m c d) = rnf m `seq` rnf c `seq` rnf d - rnf (ErrorVal v) = rnf v - -instance FromJSON ErrorObj where - parseJSON Null = mzero - parseJSON v@(Object o) = p1 <|> p2 where - p1 = do - m <- o .: "message" - c <- o .: "code" - d <- o .:? "data" .!= Null - return $ ErrorObj m c d - p2 = return $ ErrorVal v - parseJSON v = return $ ErrorVal v - -instance ToJSON ErrorObj where - toJSON (ErrorObj s i d) = object $ ["message" .= s, "code" .= i] - ++ if d == Null then [] else ["data" .= d] - toJSON (ErrorVal v) = v - --- | Get a user-friendly string with the error information. -fromError :: ErrorObj -> String -fromError (ErrorObj m c v) = show c ++ ": " ++ m ++ ": " ++ valueAsString v -fromError (ErrorVal (String t)) = T.unpack t -fromError (ErrorVal v) = valueAsString v - -valueAsString :: Value -> String -valueAsString = T.unpack . decodeUtf8 . L.toStrict . encode - --- | Parse error. -errorParse :: ByteString -> ErrorObj -errorParse = ErrorObj "Parse error" (-32700) . String . decodeUtf8 - --- | Invalid request. -errorInvalid :: Value -> ErrorObj -errorInvalid = ErrorObj "Invalid request" (-32600) - --- | Invalid params. -errorParams :: Value -> ErrorObj -errorParams = ErrorObj "Invalid params" (-32602) - --- | Method not found. -errorMethod :: Method -> ErrorObj -errorMethod = ErrorObj "Method not found" (-32601) . toJSON - --- | Id not recognized. -errorId :: Id -> ErrorObj -errorId = ErrorObj "Id not recognized" (-32000) . toJSON - - --- --- Messages --- - -data BatchRequest - = BatchRequest { getBatchRequest :: ![Request] } - | SingleRequest { getSingleRequest :: !Request } - deriving (Eq, Show, Generic) - -instance NFData BatchRequest where - rnf (BatchRequest qs) = rnf qs - rnf (SingleRequest q) = rnf q - -instance FromJSON BatchRequest where - parseJSON qs@Array{} = BatchRequest <$> parseJSON qs - parseJSON q@Object{} = SingleRequest <$> parseJSON q - parseJSON _ = mzero - -instance ToJSON BatchRequest where - toJSON (BatchRequest qs) = toJSON qs - toJSON (SingleRequest q) = toJSON q - -data BatchResponse - = BatchResponse { getBatchResponse :: ![Response] } - | SingleResponse { getSingleResponse :: !Response } - deriving (Eq, Show, Generic) - -instance NFData BatchResponse where - rnf (BatchResponse qs) = rnf qs - rnf (SingleResponse q) = rnf q - -instance FromJSON BatchResponse where - parseJSON qs@Array{} = BatchResponse <$> parseJSON qs - parseJSON q@Object{} = SingleResponse <$> parseJSON q - parseJSON _ = mzero - -instance ToJSON BatchResponse where - toJSON (BatchResponse qs) = toJSON qs - toJSON (SingleResponse q) = toJSON q - -data Message - = MsgRequest { getMsgRequest :: !Request } - | MsgResponse { getMsgResponse :: !Response } - | MsgBatch { getBatch :: ![Message] } - deriving (Eq, Show, Generic) - -instance NFData Message where - rnf (MsgRequest q) = rnf q - rnf (MsgResponse r) = rnf r - rnf (MsgBatch b) = rnf b - -instance ToJSON Message where - toJSON (MsgRequest q) = toJSON q - toJSON (MsgResponse r) = toJSON r - toJSON (MsgBatch b) = toJSON b - -instance FromJSON Message where - parseJSON v = (MsgRequest <$> parseJSON v) - <|> (MsgResponse <$> parseJSON v) - <|> (MsgBatch <$> parseJSON v) - --- --- Types --- - -type Method = Text - -data Id = IdInt { getIdInt :: !Int } - | IdTxt { getIdTxt :: !Text } - deriving (Eq, Show, Read, Generic) - -instance Hashable Id - -instance NFData Id where - rnf (IdInt i) = rnf i - rnf (IdTxt t) = rnf t - -instance Enum Id where - toEnum = IdInt - 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 _ = mzero - -instance ToJSON Id where - toJSON (IdTxt s) = toJSON s - toJSON (IdInt n) = toJSON n - --- | Pretty display a message id. Meant for logs. -fromId :: Id -> String -fromId (IdInt i) = show i -fromId (IdTxt t) = T.unpack t - --- | JSON-RPC version. -data Ver = V1 -- ^ JSON-RPC 1.0 - | V2 -- ^ JSON-RPC 2.0 - deriving (Eq, Show, Read, Generic) - -instance NFData Ver where - rnf v = v `seq` () - -jr2 :: Pair -jr2 = "jsonrpc" .= ("2.0" :: Text) - -parseVer :: Object -> Parser Ver -parseVer o = do - j <- o .:? "jsonrpc" - return $ if j == Just ("2.0" :: Text) then V2 else V1 diff --git a/Network/JsonRpc/Interface.hs b/Network/JsonRpc/Interface.hs deleted file mode 100644 --- a/Network/JsonRpc/Interface.hs +++ /dev/null @@ -1,363 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE TemplateHaskell #-} --- | Interface for JSON-RPC. -module Network.JsonRpc.Interface -( -- * Establish JSON-RPC context - JsonRpcT -, runJsonRpcT - - -- * Conduits for encoding/decoding -, decodeConduit -, encodeConduit - - -- * Communicate with remote party -, receiveRequest -, receiveBatchRequest -, sendResponse -, sendBatchResponse -, sendRequest -, sendBatchRequest - - -- * Transports - -- ** Client -, jsonRpcTcpClient - -- ** Server -, jsonRpcTcpServer - - -- * Internal data and functions -, SentRequests -, Session(..) -, initSession -, processIncoming -, sendMessage -) where - -import Control.Applicative -import Control.Concurrent.Async.Lifted -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.Logger -import Control.Monad.Reader -import Control.Monad.Trans.State -import Control.Monad.Trans.Control -import Data.Aeson -import Data.Aeson.Types (parseMaybe) -import Data.Attoparsec.ByteString -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as B8 -import qualified Data.ByteString.Lazy.Char8 as L8 -import Data.Either -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as M -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Maybe -import Data.Conduit.Network -import Data.Conduit.TMChan -import qualified Data.Foldable as F -import qualified Data.Vector as V -import Network.JsonRpc.Data - -type SentRequests = HashMap Id (TMVar (Maybe Response)) - -data Session = Session { inCh :: TBMChan (Either Response Value) - , outCh :: TBMChan Message - , reqCh :: Maybe (TBMChan BatchRequest) - , lastId :: TVar Id - , sentReqs :: TVar SentRequests - , rpcVer :: Ver - , dead :: TVar Bool - } - --- Context for JSON-RPC connection. Connection will remain active as long --- as context is maintaned. -type JsonRpcT = ReaderT Session - -initSession :: Ver -> Bool -> STM Session -initSession v ignore = - Session <$> newTBMChan 128 - <*> newTBMChan 128 - <*> (if ignore then return Nothing else Just <$> newTBMChan 128) - <*> newTVar (IdInt 0) - <*> newTVar M.empty - <*> return v - <*> newTVar False - --- Conduit to encode JSON to ByteString. -encodeConduit :: (ToJSON j, MonadLogger m) => Conduit j m ByteString -encodeConduit = CL.mapM $ \m -> return . L8.toStrict $ encode m - --- | Conduit to decode incoming messages. Left Response indicates --- a response to send back to sender if parsing JSON fails. -decodeConduit :: MonadLogger m - => Ver -> Conduit ByteString m (Either Response Value) -decodeConduit ver = evalStateT loop Nothing where - loop = lift await >>= maybe flush (process False) - flush = get >>= maybe (return ()) (handle True . ($ B8.empty)) - process b = runParser >=> handle b - runParser ck = maybe (parse json ck) ($ ck) <$> get <* put Nothing - - handle True (Fail "" _ _) = - $(logDebug) "ignoring null string at end of incoming data" - handle b (Fail i _ _) = do - $(logError) "error parsing incoming message" - lift . yield . Left $ OrphanError ver (errorParse i) - unless b loop - handle _ (Partial k) = put (Just k) >> loop - handle b (Done rest v) = do - lift $ yield $ Right v - if B8.null rest - then unless b loop - else process b rest - --- | Process incoming messages. Do not use this directly unless you know --- what you are doing. This is an internal function. -processIncoming :: (Functor m, MonadLoggerIO m) => JsonRpcT m () -processIncoming = ask >>= \qs -> join . liftIO . atomically $ do - vEM <- readTBMChan $ inCh qs - case vEM of - Nothing -> flush qs - Just vE -> - case vE of - Right v@Object{} -> do - single qs v - return $ do - $(logDebug) "received message" - processIncoming - Right v@(Array a) -> do - if V.null a - then do - let e = OrphanError (rpcVer qs) (errorInvalid v) - writeTBMChan (outCh qs) $ MsgResponse e - else batch qs (V.toList a) - return $ do - $(logDebug) "received batch" - processIncoming - Right v -> do - let e = OrphanError (rpcVer qs) (errorInvalid v) - writeTBMChan (outCh qs) $ MsgResponse e - return $ do - $(logWarn) "got invalid message" - processIncoming - Left e -> do - writeTBMChan (outCh qs) $ MsgResponse e - return $ do - $(logWarn) "error parsing JSON" - processIncoming - where - flush qs = do - m <- readTVar $ sentReqs qs - F.forM_ (reqCh qs) closeTBMChan - closeTBMChan $ outCh qs - writeTVar (dead qs) True - mapM_ ((`putTMVar` Nothing) . snd) $ M.toList m - return $ do - $(logDebug) "session is now dead" - unless (M.null m) $ $(logError) "requests remained unfulfilled" - batch qs vs = do - ts <- catMaybes <$> forM vs (process qs) - unless (null ts) $ - if any isRight ts - then do - let ch = fromJust $ reqCh qs - writeTBMChan ch $ BatchRequest $ rights ts - else writeTBMChan (outCh qs) $ MsgBatch $ lefts ts - single qs v = do - tM <- process qs v - case tM of - Nothing -> return () - Just (Right t) -> do - let ch = fromJust $ reqCh qs - writeTBMChan ch $ SingleRequest t - Just (Left e) -> writeTBMChan (outCh qs) e - process qs v = do - let qM = parseMaybe parseJSON v - case qM of - Just q -> request qs q - Nothing -> do - let rM = parseMaybe parseJSON v - case rM of - Just r -> response qs r >> return Nothing - Nothing -> do - let e = OrphanError (rpcVer qs) (errorInvalid v) - m = MsgResponse e - return $ Just $ Left m - request qs t = - case reqCh qs of - Just _ -> return $ Just $ Right t - Nothing -> - case t of - Notif{} -> return Nothing - Request{} -> do - let e = errorMethod (getReqMethod t) - v = getReqVer t - i = getReqId t - m = MsgResponse $ ResponseError v e i - return $ Just $ Left m - response qs r = do - let hasid = case r of - Response{} -> True - ResponseError{} -> True - OrphanError{} -> False -- Ignore orphan errors - when hasid $ do - let x = getResId r - m <- readTVar (sentReqs qs) - case x `M.lookup` m of - Nothing -> return () -- Ignore orphan responses - Just p -> do - writeTVar (sentReqs qs) $ M.delete x m - putTMVar p $ Just r - --- | Returns Nothing if did not receive response, could not parse it, or --- request is a notification. Just Left contains the error object returned --- by server if any. Just Right means response was received just right. -sendRequest :: (MonadLoggerIO m , ToJSON q, ToRequest q, FromResponse r) - => q -> JsonRpcT m (Maybe (Either ErrorObj r)) -sendRequest q = head `liftM` sendBatchRequest [q] - --- | Send multiple requests in a batch. If only a single request, do not --- put it in a batch. -sendBatchRequest :: (MonadLoggerIO m, ToJSON q, ToRequest q, FromResponse r) - => [q] -> JsonRpcT m [Maybe (Either ErrorObj r)] -sendBatchRequest qs = do - v <- reader rpcVer - l <- reader lastId - s <- reader sentReqs - o <- reader outCh - k <- reader dead - aps <- liftIO . atomically $ do - d <- readTVar k - aps <- forM qs $ \q -> - if requestIsNotif q - then return (buildRequest v q undefined, Nothing) - else do - p <- newEmptyTMVar - i <- succ <$> readTVar l - m <- readTVar s - unless d $ writeTVar s $ M.insert i p m - unless d $ writeTVar l i - if d - then return (buildRequest v q i, Nothing) - else return (buildRequest v q i, Just p) - case map fst aps of - [] -> return () - [a] -> unless d $ writeTBMChan o $ MsgRequest a - as -> unless d $ writeTBMChan o $ MsgBatch $ map MsgRequest as - return aps - if null aps - then $(logDebug) "no responses pending" - else $(logDebug) "listening for responses if pending" - liftIO . atomically $ forM aps $ \(a, pM) -> - case pM of - Nothing -> return Nothing - Just p -> do - rM <- takeTMVar p - case rM of - Nothing -> return Nothing - Just r@Response{} -> - case fromResponse (getReqMethod a) r of - Nothing -> return Nothing - Just x -> return $ Just $ Right x - Just e -> return $ Just $ Left $ getError e - --- | Receive requests from remote endpoint. Returns Nothing if incoming --- channel is closed or has never been opened. Will reject incoming request --- if sent in a batch. -receiveRequest :: MonadLoggerIO m => JsonRpcT m (Maybe Request) -receiveRequest = do - bt <- receiveBatchRequest - case bt of - Nothing -> return Nothing - Just (SingleRequest q) -> return $ Just q - Just BatchRequest{} -> do - v <- reader rpcVer - let e = errorInvalid $ String "not accepting batches" - m = OrphanError v e - sendResponse m - return Nothing - --- | Receive batch of requests. Will also accept single requests. -receiveBatchRequest :: MonadLoggerIO m => JsonRpcT m (Maybe BatchRequest) -receiveBatchRequest = do - chM <- reader reqCh - case chM of - Just ch -> do - $(logDebug) "listening for a new request" - liftIO . atomically $ readTBMChan ch - Nothing -> do - $(logError) "ignoring requests from remote endpoint" - return Nothing - --- | Send response message. Do not use to respond to a batch of requests. -sendResponse :: MonadLoggerIO m => Response -> JsonRpcT m () -sendResponse r = do - o <- reader outCh - liftIO . atomically . writeTBMChan o $ MsgResponse r - --- | Send batch of responses. Use to respond to a batch of requests. -sendBatchResponse :: MonadLoggerIO m => BatchResponse -> JsonRpcT m () -sendBatchResponse (BatchResponse rs) = do - o <- reader outCh - liftIO . atomically . writeTBMChan o $ MsgBatch $ map MsgResponse rs -sendBatchResponse (SingleResponse r) = do - o <- reader outCh - liftIO . atomically . writeTBMChan o $ MsgResponse r - --- | Send any message. Do not use this. Use the other high-level functions --- instead. Will not track request ids. Incoming responses to requests sent --- using this method will be ignored. -sendMessage :: MonadLoggerIO m => Message -> JsonRpcT m () -sendMessage msg = reader outCh >>= liftIO . atomically . (`writeTBMChan` msg) - --- | Create JSON-RPC session around conduits from transport layer. When --- context exits session disappears. -runJsonRpcT :: (MonadLoggerIO m, MonadBaseControl IO m) - => Ver -- ^ JSON-RPC version - -> Bool -- ^ Ignore incoming requests/notifs - -> Sink ByteString m () -- ^ Sink to send messages - -> Source m ByteString -- ^ Source to receive messages from - -> JsonRpcT m a -- ^ JSON-RPC action - -> m a -- ^ Output of action -runJsonRpcT ver ignore snk src f = do - qs <- liftIO . atomically $ initSession ver ignore - let inSnk = sinkTBMChan (inCh qs) True - outSrc = sourceTBMChan (outCh qs) - withAsync (src $$ decodeConduit ver $= inSnk) $ const $ - withAsync (outSrc =$ encodeConduit $$ snk) $ \o -> - withAsync (runReaderT processIncoming qs) $ const $ do - a <- runReaderT f qs - liftIO $ do - atomically . closeTBMChan $ outCh qs - _ <- wait o - return a - - -cr :: Monad m => Conduit ByteString m ByteString -cr = CL.map (`B8.snoc` '\n') - --- --- Transports --- - --- | TCP client transport for JSON-RPC. -jsonRpcTcpClient - :: (MonadLoggerIO m, MonadBaseControl IO m) - => Ver -- ^ JSON-RPC version - -> Bool -- ^ Ignore incoming requests or notifications - -> ClientSettings -- ^ Connection settings - -> JsonRpcT m a -- ^ JSON-RPC action - -> m a -- ^ Output of action -jsonRpcTcpClient ver ignore cs f = runGeneralTCPClient cs $ \ad -> - runJsonRpcT ver ignore (cr =$ appSink ad) (appSource ad) f - --- | TCP server transport for JSON-RPC. -jsonRpcTcpServer - :: (MonadLoggerIO m, MonadBaseControl IO m) - => Ver -- ^ JSON-RPC version - -> Bool -- ^ Ignore incoming requests or notifications - -> ServerSettings -- ^ Connection settings - -> JsonRpcT m () -- ^ Action to perform on connecting client thread - -> m a -jsonRpcTcpServer ver ignore ss f = runGeneralTCPServer ss $ \cl -> - runJsonRpcT ver ignore (cr =$ appSink cl) (appSource cl) f diff --git a/examples/concurrent-client.hs b/examples/concurrent-client.hs new file mode 100644 --- /dev/null +++ b/examples/concurrent-client.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Monad +import Control.Monad.Logger +import Data.Aeson +import Data.Aeson.Types hiding (Error) +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 UnliftIO +import UnliftIO.Concurrent + +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 parseTimeM True 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 + +respond :: MonadLoggerIO m => Respond Req m Res +respond TimeReq = (Right . Time) <$> liftIO getCurrentTime +respond Ping = return $ Right Pong + +main :: IO () +main = runStderrLoggingT $ + jsonrpcTCPClient V2 False (clientSettings 31337 "::1") $ + withAsync responder $ const $ do + $(logDebug) "sending four time requests one second apart" + replicateM_ 4 $ do + req >>= $(logDebug) . T.pack . ("response: "++) . show + liftIO (threadDelay 1000000) + $(logDebug) "sending two pings in a batch" + reqBatch >>= $(logDebug) . T.pack . ("response: "++) . show + +responder :: MonadLoggerIO m => JSONRPCT m () +responder = 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 + responder + Just (BatchRequest qs) -> do + $(logDebug) "got request batch" + rs <- catMaybes `liftM` forM qs (buildResponse respond) + sendBatchResponse $ BatchResponse rs + responder diff --git a/examples/concurrent-server.hs b/examples/concurrent-server.hs new file mode 100644 --- /dev/null +++ b/examples/concurrent-server.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Monad +import Control.Monad.Logger +import Control.Monad.Trans +import Data.Aeson.Types hiding (Error) +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 UnliftIO +import UnliftIO.Concurrent + +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 parseTimeM True 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 = (Right . Time) <$> liftIO getCurrentTime +respond Ping = return $ Right Pong + +main :: IO () +main = runStderrLoggingT $ do + let ss = serverSettings 31337 "::1" + jsonrpcTCPServer V2 False ss $ withAsync pinger $ const 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 + +pinger :: MonadLoggerIO m => JSONRPCT m () +pinger = do + $(logDebug) "ping client" + p <- sendRequest Ping + $(logDebug) $ T.pack $ + "received " ++ show (p :: Maybe (Either ErrorObj Res)) + liftIO $ threadDelay 1500000 + pinger diff --git a/examples/time-client.hs b/examples/time-client.hs new file mode 100644 --- /dev/null +++ b/examples/time-client.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Monad +import Control.Monad.Logger +import Control.Monad.Trans +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 UnliftIO.Concurrent + +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 parseTimeM True 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 diff --git a/examples/time-server.hs b/examples/time-server.hs new file mode 100644 --- /dev/null +++ b/examples/time-server.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +import Control.Monad +import Control.Monad.Logger +import Control.Monad.Trans +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 + +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 parseTimeM True 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 = (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 diff --git a/json-rpc.cabal b/json-rpc.cabal --- a/json-rpc.cabal +++ b/json-rpc.cabal @@ -1,73 +1,172 @@ -name: json-rpc -version: 0.7.1.1 -synopsis: Fully-featured JSON-RPC 2.0 library -description: - 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. -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 +-- This file has been generated from package.yaml by hpack version 0.20.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: a02d2b107df6439cd518ee3c9bd65b181355abbe8d1c04d46fe6d0fdbe6045eb +name: json-rpc +version: 0.8.0.0 +synopsis: Fully-featured JSON-RPC 2.0 library +description: Library compatible with JSON-RPC 2.0 and 1.0 +category: Network +homepage: https://github.com/xenog/json-rpc.git#readme +bug-reports: https://github.com/xenog/json-rpc.git/issues +author: Jean-Pierre Rupp +maintainer: xenog@protonmail.com +license: PublicDomain +license-file: UNLICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + README.md + source-repository head - type: git - location: https://github.com/xenog/json-rpc.git + type: git + location: https://github.com/xenog/json-rpc.git library - exposed-modules: Network.JsonRpc - other-modules: Network.JsonRpc.Data, - Network.JsonRpc.Interface - Network.JsonRpc.Arbitrary - build-depends: base >= 4.6 && < 5, - aeson, - attoparsec, - bytestring, - conduit, - conduit-extra, - deepseq, - hashable, - lifted-async, - monad-control, - monad-logger, - mtl, - stm, - stm-conduit, - text, - transformers, - unordered-containers, - vector, - QuickCheck - default-language: Haskell2010 - ghc-options: -Wall + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + QuickCheck + , aeson + , attoparsec + , base >=4.6 && <5 + , bytestring + , conduit + , conduit-extra + , deepseq + , hashable + , monad-logger + , mtl + , stm-conduit + , text + , time + , unliftio + , unordered-containers + , vector + exposed-modules: + Network.JSONRPC + other-modules: + Network.JSONRPC.Arbitrary + Network.JSONRPC.Data + Network.JSONRPC.Interface + Paths_json_rpc + default-language: Haskell2010 +executable concurrent-client + main-is: examples/concurrent-client.hs + build-depends: + QuickCheck + , aeson + , base >=4.6 && <5 + , bytestring + , conduit + , conduit-extra + , json-rpc + , monad-logger + , mtl + , stm-conduit + , text + , time + , unliftio + , unordered-containers + , vector + other-modules: + Paths_json_rpc + default-language: Haskell2010 + +executable concurrent-server + main-is: examples/concurrent-server.hs + build-depends: + QuickCheck + , aeson + , base >=4.6 && <5 + , bytestring + , conduit + , conduit-extra + , json-rpc + , monad-logger + , mtl + , stm-conduit + , text + , time + , unliftio + , unordered-containers + , vector + other-modules: + Paths_json_rpc + default-language: Haskell2010 + +executable time-client + main-is: examples/time-client.hs + build-depends: + QuickCheck + , aeson + , base >=4.6 && <5 + , bytestring + , conduit + , conduit-extra + , json-rpc + , monad-logger + , mtl + , stm-conduit + , text + , time + , unliftio + , unordered-containers + , vector + other-modules: + Paths_json_rpc + default-language: Haskell2010 + +executable time-server + main-is: examples/time-server.hs + build-depends: + QuickCheck + , aeson + , base >=4.6 && <5 + , bytestring + , conduit + , conduit-extra + , json-rpc + , monad-logger + , mtl + , stm-conduit + , text + , time + , unliftio + , unordered-containers + , vector + other-modules: + Paths_json_rpc + default-language: Haskell2010 + test-suite test-json-rpc - hs-source-dirs: test - type: exitcode-stdio-1.0 - main-is: main.hs - other-modules: Network.JsonRpc.Tests - build-depends: base >= 4.6 && < 5, - aeson, - bytestring, - conduit, - json-rpc, - lifted-async, - monad-logger, - mtl, - text, - unordered-containers, - stm, - stm-conduit, - transformers, - QuickCheck, - test-framework, - test-framework-quickcheck2 - default-language: Haskell2010 - ghc-options: -Wall + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + QuickCheck + , aeson + , base >=4.6 && <5 + , bytestring + , conduit + , conduit-extra + , hspec + , json-rpc + , monad-logger + , mtl + , stm-conduit + , text + , time + , unliftio + , unordered-containers + , vector + other-modules: + Paths_json_rpc + default-language: Haskell2010 diff --git a/src/Network/JSONRPC.hs b/src/Network/JSONRPC.hs new file mode 100644 --- /dev/null +++ b/src/Network/JSONRPC.hs @@ -0,0 +1,23 @@ +module Network.JSONRPC +( -- * Introduction + -- $introduction + + module Network.JSONRPC.Interface +, module Network.JSONRPC.Data +) where + +import Network.JSONRPC.Arbitrary () +import Network.JSONRPC.Data +import Network.JSONRPC.Interface + +-- $introduction +-- +-- 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. diff --git a/src/Network/JSONRPC/Arbitrary.hs b/src/Network/JSONRPC/Arbitrary.hs new file mode 100644 --- /dev/null +++ b/src/Network/JSONRPC/Arbitrary.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Network.JSONRPC.Arbitrary where + +import Data.Aeson.Types +import qualified Data.HashMap.Strict as M +import Data.Text (Text) +import qualified Data.Text as T +import Network.JSONRPC.Data +import Test.QuickCheck.Arbitrary +import Test.QuickCheck.Gen + +instance Arbitrary Text where + arbitrary = T.pack <$> arbitrary + +instance Arbitrary Ver where + arbitrary = elements [V1, V2] + +instance Arbitrary Request where + arbitrary = oneof + [ Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + , Notif <$> arbitrary <*> arbitrary <*> arbitrary + ] + +instance Arbitrary Response where + arbitrary = oneof + [ Response <$> arbitrary <*> arbitrary <*> arbitrary + , ResponseError <$> arbitrary <*> arbitrary <*> arbitrary + , OrphanError <$> arbitrary <*> arbitrary + ] + + +instance Arbitrary ErrorObj where + arbitrary = oneof + [ ErrorObj <$> arbitrary <*> arbitrary <*> arbitrary + , ErrorVal <$> arbitrary + ] + +instance Arbitrary BatchRequest where + arbitrary = oneof + [ BatchRequest <$> arbitrary + , SingleRequest <$> arbitrary + ] + +instance Arbitrary BatchResponse where + arbitrary = oneof + [ BatchResponse <$> arbitrary + , SingleResponse <$> arbitrary + ] + +instance Arbitrary Message where + arbitrary = oneof + [ MsgRequest <$> arbitrary + , MsgResponse <$> arbitrary + , MsgBatch <$> batch + ] + where + batch = listOf $ oneof [ MsgRequest <$> arbitrary + , MsgResponse <$> arbitrary + ] + +instance Arbitrary Id where + arbitrary = IdInt <$> arbitraryBoundedRandom + +instance Arbitrary Value where + arbitrary = resize 10 $ oneof [nonull, lsn, objn] where + nonull = oneof + [ toJSON <$> (arbitrary :: Gen String) + , toJSON <$> (arbitrary :: Gen Int) + , toJSON <$> (arbitrary :: Gen Double) + , toJSON <$> (arbitrary :: Gen Bool) + ] + val = oneof [ nonull, return Null ] + 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/src/Network/JSONRPC/Data.hs b/src/Network/JSONRPC/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/JSONRPC/Data.hs @@ -0,0 +1,413 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Implementation of basic JSON-RPC data types. +module Network.JSONRPC.Data +( -- * Requests + Request(..) +, BatchRequest(..) + -- ** Parsing +, FromRequest(..) +, fromRequest + -- ** Encoding +, ToRequest(..) +, buildRequest + + -- * Responses +, Response(..) +, BatchResponse(..) + -- ** Parsing +, FromResponse(..) +, fromResponse + -- ** Encoding +, Respond +, buildResponse + -- ** Errors +, ErrorObj(..) +, fromError + -- ** Error messages +, errorParse +, errorInvalid +, errorParams +, errorMethod +, errorId + + -- * Others +, Message(..) +, Method +, Id(..) +, fromId +, Ver(..) + +) where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Data.Aeson (encode) +import Data.Aeson.Types +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L +import Data.Hashable (Hashable) +import Data.Maybe +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import GHC.Generics (Generic) + + +-- +-- Requests +-- + +data Request = Request { getReqVer :: !Ver + , getReqMethod :: !Method + , getReqParams :: !Value + , getReqId :: !Id + } + | Notif { getReqVer :: !Ver + , getReqMethod :: !Method + , getReqParams :: !Value + } + deriving (Eq, Show, Generic) + +instance NFData Request where + rnf (Request v m p i) = rnf v `seq` rnf m `seq` rnf p `seq` rnf i + rnf (Notif v m p) = rnf v `seq` rnf m `seq` rnf p + +instance ToJSON Request where + toJSON (Request V2 m p i) = object $ case p of + Null -> [jr2, "method" .= m, "id" .= i] + _ -> [jr2, "method" .= m, "id" .= i, "params" .= p] + toJSON (Request V1 m p i) = object $ case p of + Null -> ["method" .= m, "params" .= emptyArray, "id" .= i] + _ -> ["method" .= m, "params" .= p, "id" .= i] + toJSON (Notif V2 m p) = object $ case p of + Null -> [jr2, "method" .= m] + _ -> [jr2, "method" .= m, "params" .= p] + toJSON (Notif V1 m p) = object $ case p of + Null -> ["method" .= m, "params" .= emptyArray, "id" .= Null] + _ -> ["method" .= m, "params" .= p, "id" .= Null] + +class FromRequest q where + -- | Parser for params Value in JSON-RPC request. + parseParams :: Method -> Maybe (Value -> Parser q) + +fromRequest :: FromRequest q => Request -> Either ErrorObj q +fromRequest req = + case parserM of + Nothing -> Left $ errorMethod m + Just parser -> + case parseMaybe parser p of + Nothing -> Left $ errorParams p + Just q -> Right q + where + m = getReqMethod req + p = getReqParams req + parserM = parseParams m + +instance FromRequest Value where + parseParams = const $ Just return + +instance FromRequest () where + parseParams = const . Just . const $ return () + +instance FromJSON Request where + parseJSON = withObject "request" $ \o -> do + (v, n, m, p) <- parseVerIdMethParams o + case n of Nothing -> return $ Notif v m p + Just i -> return $ Request v m p i + +parseVerIdMethParams :: Object -> Parser (Ver, Maybe Id, Method, Value) +parseVerIdMethParams o = do + v <- parseVer o + i <- o .:? "id" + m <- o .: "method" + p <- o .:? "params" .!= Null + return (v, i, m, p) + +class ToRequest q where + -- | Method associated with request data to build a request object. + requestMethod :: q -> Method + + -- | Is this request to be sent as a notification (no id, no response)? + requestIsNotif :: q -> Bool + +instance ToRequest Value where + requestMethod = const "json" + requestIsNotif = const False + +instance ToRequest () where + requestMethod = const "json" + requestIsNotif = const False + +buildRequest :: (ToJSON q, ToRequest q) + => Ver -- ^ JSON-RPC version + -> q -- ^ Request data + -> Id + -> Request +buildRequest ver q = if requestIsNotif q + then const $ Notif ver (requestMethod q) (toJSON q) + else Request ver (requestMethod q) (toJSON q) + +-- +-- Responses +-- + +data Response = Response { getResVer :: !Ver + , getResult :: !Value + , getResId :: !Id + } + | ResponseError { getResVer :: !Ver + , getError :: !ErrorObj + , getResId :: !Id + } + | OrphanError { getResVer :: !Ver + , getError :: !ErrorObj + } + deriving (Eq, Show, Generic) + + +instance NFData Response where + rnf (Response v r i) = rnf v `seq` rnf r `seq` rnf i + rnf (ResponseError v o i) = rnf v `seq` rnf o `seq` rnf i + rnf (OrphanError v o) = rnf v `seq` rnf o + +instance ToJSON Response where + toJSON (Response V1 r i) = object + ["id" .= i, "result" .= r, "error" .= Null] + toJSON (Response V2 r i) = object + [jr2, "id" .= i, "result" .= r] + toJSON (ResponseError V1 e i) = object + ["id" .= i, "error" .= e, "result" .= Null] + toJSON (ResponseError V2 e i) = object + [jr2, "id" .= i, "error" .= e] + toJSON (OrphanError V1 e) = object + ["id" .= Null, "error" .= e, "result" .= Null] + toJSON (OrphanError V2 e) = object + [jr2, "id" .= Null, "error" .= e] + +class FromResponse r where + -- | Parser for result Value in JSON-RPC response. + -- Method corresponds to request to which this response answers. + parseResult :: Method -> Maybe (Value -> Parser r) + +-- | Parse a response knowing the method of the corresponding request. +fromResponse :: FromResponse r => Method -> Response -> Maybe r +fromResponse m (Response _ r _) = parseResult m >>= flip parseMaybe r +fromResponse _ _ = Nothing + +instance FromResponse Value where + parseResult = const $ Just return + +instance FromResponse () where + parseResult = const Nothing + +instance FromJSON Response where + parseJSON = withObject "response" $ \o -> do + (v, d, s) <- parseVerIdResultError o + case s of + Right r -> do + guard $ isJust d + return $ Response v r (fromJust d) + Left e -> + case d of + Just i -> return $ ResponseError v e i + Nothing -> return $ OrphanError v e + +parseVerIdResultError :: Object + -> Parser (Ver, Maybe Id, Either ErrorObj Value) +parseVerIdResultError o = do + v <- parseVer o + i <- o .:? "id" + r <- o .:? "result" .!= Null + p <- if r == Null then Left <$> o .: "error" else return $ Right r + return (v, i, p) + +-- | Create a response from a request. Use in servers. +buildResponse :: (Monad m, FromRequest q, ToJSON r) + => Respond q m r + -> Request + -> m (Maybe Response) +buildResponse f req@(Request v _ _ i) = + case fromRequest req of + Left e -> return . Just $ ResponseError v e i + Right q -> do + rE <- f q + case rE of + Left e -> return . Just $ ResponseError v e i + Right r -> return . Just $ Response v (toJSON r) i +buildResponse _ _ = return Nothing + +-- | Type of function to make it easy to create a response from a request. +-- Meant to be used in servers. +type Respond q m r = q -> m (Either ErrorObj r) + +-- | Error object from JSON-RPC 2.0. ErrorVal for backwards compatibility. +data ErrorObj = ErrorObj { getErrMsg :: !String + , getErrCode :: !Int + , getErrData :: !Value + } + | ErrorVal { getErrData :: !Value } + deriving (Show, Eq, Generic) + +instance NFData ErrorObj where + rnf (ErrorObj m c d) = rnf m `seq` rnf c `seq` rnf d + rnf (ErrorVal v) = rnf v + +instance FromJSON ErrorObj where + parseJSON Null = mzero + parseJSON v@(Object o) = p1 <|> p2 where + p1 = do + m <- o .: "message" + c <- o .: "code" + d <- o .:? "data" .!= Null + return $ ErrorObj m c d + p2 = return $ ErrorVal v + parseJSON v = return $ ErrorVal v + +instance ToJSON ErrorObj where + toJSON (ErrorObj s i d) = object $ ["message" .= s, "code" .= i] + ++ if d == Null then [] else ["data" .= d] + toJSON (ErrorVal v) = v + +-- | Get a user-friendly string with the error information. +fromError :: ErrorObj -> String +fromError (ErrorObj m c v) = show c ++ ": " ++ m ++ ": " ++ valueAsString v +fromError (ErrorVal (String t)) = T.unpack t +fromError (ErrorVal v) = valueAsString v + +valueAsString :: Value -> String +valueAsString = T.unpack . decodeUtf8 . L.toStrict . encode + +-- | Parse error. +errorParse :: ByteString -> ErrorObj +errorParse = ErrorObj "Parse error" (-32700) . String . decodeUtf8 + +-- | Invalid request. +errorInvalid :: Value -> ErrorObj +errorInvalid = ErrorObj "Invalid request" (-32600) + +-- | Invalid params. +errorParams :: Value -> ErrorObj +errorParams = ErrorObj "Invalid params" (-32602) + +-- | Method not found. +errorMethod :: Method -> ErrorObj +errorMethod = ErrorObj "Method not found" (-32601) . toJSON + +-- | Id not recognized. +errorId :: Id -> ErrorObj +errorId = ErrorObj "Id not recognized" (-32000) . toJSON + + +-- +-- Messages +-- + +data BatchRequest + = BatchRequest { getBatchRequest :: ![Request] } + | SingleRequest { getSingleRequest :: !Request } + deriving (Eq, Show, Generic) + +instance NFData BatchRequest where + rnf (BatchRequest qs) = rnf qs + rnf (SingleRequest q) = rnf q + +instance FromJSON BatchRequest where + parseJSON qs@Array{} = BatchRequest <$> parseJSON qs + parseJSON q@Object{} = SingleRequest <$> parseJSON q + parseJSON _ = mzero + +instance ToJSON BatchRequest where + toJSON (BatchRequest qs) = toJSON qs + toJSON (SingleRequest q) = toJSON q + +data BatchResponse + = BatchResponse { getBatchResponse :: ![Response] } + | SingleResponse { getSingleResponse :: !Response } + deriving (Eq, Show, Generic) + +instance NFData BatchResponse where + rnf (BatchResponse qs) = rnf qs + rnf (SingleResponse q) = rnf q + +instance FromJSON BatchResponse where + parseJSON qs@Array{} = BatchResponse <$> parseJSON qs + parseJSON q@Object{} = SingleResponse <$> parseJSON q + parseJSON _ = mzero + +instance ToJSON BatchResponse where + toJSON (BatchResponse qs) = toJSON qs + toJSON (SingleResponse q) = toJSON q + +data Message + = MsgRequest { getMsgRequest :: !Request } + | MsgResponse { getMsgResponse :: !Response } + | MsgBatch { getBatch :: ![Message] } + deriving (Eq, Show, Generic) + +instance NFData Message where + rnf (MsgRequest q) = rnf q + rnf (MsgResponse r) = rnf r + rnf (MsgBatch b) = rnf b + +instance ToJSON Message where + toJSON (MsgRequest q) = toJSON q + toJSON (MsgResponse r) = toJSON r + toJSON (MsgBatch b) = toJSON b + +instance FromJSON Message where + parseJSON v = (MsgRequest <$> parseJSON v) + <|> (MsgResponse <$> parseJSON v) + <|> (MsgBatch <$> parseJSON v) + +-- +-- Types +-- + +type Method = Text + +data Id = IdInt { getIdInt :: !Int } + | IdTxt { getIdTxt :: !Text } + deriving (Eq, Show, Read, Generic) + +instance Hashable Id + +instance NFData Id where + rnf (IdInt i) = rnf i + rnf (IdTxt t) = rnf t + +instance Enum Id where + toEnum = IdInt + 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 _ = mzero + +instance ToJSON Id where + toJSON (IdTxt s) = toJSON s + toJSON (IdInt n) = toJSON n + +-- | Pretty display a message id. Meant for logs. +fromId :: Id -> String +fromId (IdInt i) = show i +fromId (IdTxt t) = T.unpack t + +-- | JSON-RPC version. +data Ver = V1 -- ^ JSON-RPC 1.0 + | V2 -- ^ JSON-RPC 2.0 + deriving (Eq, Show, Read, Generic) + +instance NFData Ver where + rnf v = v `seq` () + +jr2 :: Pair +jr2 = "jsonrpc" .= ("2.0" :: Text) + +parseVer :: Object -> Parser Ver +parseVer o = do + j <- o .:? "jsonrpc" + return $ if j == Just ("2.0" :: Text) then V2 else V1 diff --git a/src/Network/JSONRPC/Interface.hs b/src/Network/JSONRPC/Interface.hs new file mode 100644 --- /dev/null +++ b/src/Network/JSONRPC/Interface.hs @@ -0,0 +1,365 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +-- | Interface for JSON-RPC. +module Network.JSONRPC.Interface +( -- * Establish JSON-RPC context + JSONRPCT +, runJSONRPCT + + -- * Conduits for encoding/decoding +, decodeConduit +, encodeConduit + + -- * Communicate with remote party +, receiveRequest +, receiveBatchRequest +, sendResponse +, sendBatchResponse +, sendRequest +, sendBatchRequest + + -- * Transports + -- ** Client +, jsonrpcTCPClient + -- ** Server +, jsonrpcTCPServer + + -- * Internal data and functions +, SentRequests +, Session(..) +, initSession +, processIncoming +, sendMessage +) where + +import Control.Monad +import Control.Monad.Logger +import Control.Monad.Reader +import Control.Monad.State +import Data.Aeson +import Data.Aeson.Types (parseMaybe) +import Data.Attoparsec.ByteString +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as B8 +import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.Network +import Data.Conduit.TMChan +import Data.Either +import qualified Data.Foldable as F +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as M +import Data.Maybe +import qualified Data.Vector as V +import Network.JSONRPC.Data +import UnliftIO + +type SentRequests = HashMap Id (TMVar (Maybe Response)) + +data Session = Session { inCh :: TBMChan (Either Response Value) + , outCh :: TBMChan Message + , reqCh :: Maybe (TBMChan BatchRequest) + , lastId :: TVar Id + , sentReqs :: TVar SentRequests + , rpcVer :: Ver + , dead :: TVar Bool + } + +-- Context for JSON-RPC connection. Connection will remain active as long +-- as context is maintaned. +type JSONRPCT = ReaderT Session + +initSession :: Ver -> Bool -> STM Session +initSession v ignore = + Session <$> newTBMChan 128 + <*> newTBMChan 128 + <*> (if ignore then return Nothing else Just <$> newTBMChan 128) + <*> newTVar (IdInt 0) + <*> newTVar M.empty + <*> return v + <*> newTVar False + +-- Conduit to encode JSON to ByteString. +encodeConduit :: (ToJSON j, MonadLogger m) => ConduitT j ByteString m () +encodeConduit = CL.mapM $ \m -> return . L8.toStrict $ encode m + +-- | Conduit to decode incoming messages. Left Response indicates +-- a response to send back to sender if parsing JSON fails. +decodeConduit :: MonadLogger m + => Ver -> ConduitT ByteString (Either Response Value) m () +decodeConduit ver = evalStateT loop Nothing where + loop = lift await >>= maybe flush (process False) + flush = get >>= maybe (return ()) (handl True . ($ B8.empty)) + process b = runParser >=> handl b + runParser ck = maybe (parse json ck) ($ ck) <$> get <* put Nothing + + handl True (Fail "" _ _) = + $(logDebug) "ignoring null string at end of incoming data" + handl b (Fail i _ _) = do + $(logError) "error parsing incoming message" + lift . yield . Left $ OrphanError ver (errorParse i) + unless b loop + handl _ (Partial k) = put (Just k) >> loop + handl b (Done rest v) = do + lift $ yield $ Right v + if B8.null rest + then unless b loop + else process b rest + +-- | Process incoming messages. Do not use this directly unless you know +-- what you are doing. This is an internal function. +processIncoming :: (Functor m, MonadLoggerIO m) => JSONRPCT m () +processIncoming = + ask >>= \qs -> + join . liftIO . atomically $ + readTBMChan (inCh qs) >>= \case + Nothing -> flush qs + Just vE -> + case vE of + Right v@Object {} -> do + single qs v + return $ do + $(logDebug) "received message" + processIncoming + Right v@(Array a) -> do + if V.null a + then do + let e = OrphanError (rpcVer qs) (errorInvalid v) + writeTBMChan (outCh qs) $ MsgResponse e + else batch qs (V.toList a) + return $ do + $(logDebug) "received batch" + processIncoming + Right v -> do + let e = OrphanError (rpcVer qs) (errorInvalid v) + writeTBMChan (outCh qs) $ MsgResponse e + return $ do + $(logWarn) "got invalid message" + processIncoming + Left e -> do + writeTBMChan (outCh qs) $ MsgResponse e + return $ do + $(logWarn) "error parsing JSON" + processIncoming + where + flush qs = do + m <- readTVar $ sentReqs qs + F.forM_ (reqCh qs) closeTBMChan + closeTBMChan $ outCh qs + writeTVar (dead qs) True + mapM_ ((`putTMVar` Nothing) . snd) $ M.toList m + return $ do + $(logDebug) "session is now dead" + unless (M.null m) $ $(logError) "requests remained unfulfilled" + batch qs vs = do + ts <- catMaybes <$> forM vs (process qs) + unless (null ts) $ + if any isRight ts + then do + let ch = fromJust $ reqCh qs + writeTBMChan ch $ BatchRequest $ rights ts + else writeTBMChan (outCh qs) $ MsgBatch $ lefts ts + single qs v = do + tM <- process qs v + case tM of + Nothing -> return () + Just (Right t) -> do + let ch = fromJust $ reqCh qs + writeTBMChan ch $ SingleRequest t + Just (Left e) -> writeTBMChan (outCh qs) e + process qs v = do + let qM = parseMaybe parseJSON v + case qM of + Just q -> request qs q + Nothing -> do + let rM = parseMaybe parseJSON v + case rM of + Just r -> response qs r >> return Nothing + Nothing -> do + let e = OrphanError (rpcVer qs) (errorInvalid v) + m = MsgResponse e + return $ Just $ Left m + request qs t = + case reqCh qs of + Just _ -> return $ Just $ Right t + Nothing -> + case t of + Notif {} -> return Nothing + Request {} -> do + let e = errorMethod (getReqMethod t) + v = getReqVer t + i = getReqId t + m = MsgResponse $ ResponseError v e i + return $ Just $ Left m + response qs r = do + let hasid = + case r of + Response {} -> True + ResponseError {} -> True + OrphanError {} -> False -- Ignore orphan errors + when hasid $ do + let x = getResId r + m <- readTVar (sentReqs qs) + case x `M.lookup` m of + Nothing -> return () -- Ignore orphan responses + Just p -> do + writeTVar (sentReqs qs) $ M.delete x m + putTMVar p $ Just r + +-- | Returns Nothing if did not receive response, could not parse it, or +-- request is a notification. Just Left contains the error object returned +-- by server if any. Just Right means response was received just right. +sendRequest :: (MonadLoggerIO m , ToJSON q, ToRequest q, FromResponse r) + => q -> JSONRPCT m (Maybe (Either ErrorObj r)) +sendRequest q = head `liftM` sendBatchRequest [q] + +-- | Send multiple requests in a batch. If only a single request, do not +-- put it in a batch. +sendBatchRequest :: (MonadLoggerIO m, ToJSON q, ToRequest q, FromResponse r) + => [q] -> JSONRPCT m [Maybe (Either ErrorObj r)] +sendBatchRequest qs = do + v <- reader rpcVer + l <- reader lastId + s <- reader sentReqs + o <- reader outCh + k <- reader dead + aps <- liftIO . atomically $ do + d <- readTVar k + aps <- forM qs $ \q -> + if requestIsNotif q + then return (buildRequest v q undefined, Nothing) + else do + p <- newEmptyTMVar + i <- succ <$> readTVar l + m <- readTVar s + unless d $ writeTVar s $ M.insert i p m + unless d $ writeTVar l i + if d + then return (buildRequest v q i, Nothing) + else return (buildRequest v q i, Just p) + case map fst aps of + [] -> return () + [a] -> unless d $ writeTBMChan o $ MsgRequest a + as -> unless d $ writeTBMChan o $ MsgBatch $ map MsgRequest as + return aps + if null aps + then $(logDebug) "no responses pending" + else $(logDebug) "listening for responses if pending" + liftIO . atomically $ forM aps $ \(a, pM) -> + case pM of + Nothing -> return Nothing + Just p -> do + rM <- takeTMVar p + case rM of + Nothing -> return Nothing + Just r@Response{} -> + case fromResponse (getReqMethod a) r of + Nothing -> return Nothing + Just x -> return $ Just $ Right x + Just e -> return $ Just $ Left $ getError e + +-- | Receive requests from remote endpoint. Returns Nothing if incoming +-- channel is closed or has never been opened. Will reject incoming request +-- if sent in a batch. +receiveRequest :: MonadLoggerIO m => JSONRPCT m (Maybe Request) +receiveRequest = do + bt <- receiveBatchRequest + case bt of + Nothing -> return Nothing + Just (SingleRequest q) -> return $ Just q + Just BatchRequest{} -> do + v <- reader rpcVer + let e = errorInvalid $ String "not accepting batches" + m = OrphanError v e + sendResponse m + return Nothing + +-- | Receive batch of requests. Will also accept single requests. +receiveBatchRequest :: MonadLoggerIO m => JSONRPCT m (Maybe BatchRequest) +receiveBatchRequest = do + chM <- reader reqCh + case chM of + Just ch -> do + $(logDebug) "listening for a new request" + liftIO . atomically $ readTBMChan ch + Nothing -> do + $(logError) "ignoring requests from remote endpoint" + return Nothing + +-- | Send response message. Do not use to respond to a batch of requests. +sendResponse :: MonadLoggerIO m => Response -> JSONRPCT m () +sendResponse r = do + o <- reader outCh + liftIO . atomically . writeTBMChan o $ MsgResponse r + +-- | Send batch of responses. Use to respond to a batch of requests. +sendBatchResponse :: MonadLoggerIO m => BatchResponse -> JSONRPCT m () +sendBatchResponse (BatchResponse rs) = do + o <- reader outCh + liftIO . atomically . writeTBMChan o $ MsgBatch $ map MsgResponse rs +sendBatchResponse (SingleResponse r) = do + o <- reader outCh + liftIO . atomically . writeTBMChan o $ MsgResponse r + +-- | Send any message. Do not use this. Use the other high-level functions +-- instead. Will not track request ids. Incoming responses to requests sent +-- using this method will be ignored. +sendMessage :: MonadLoggerIO m => Message -> JSONRPCT m () +sendMessage msg = reader outCh >>= liftIO . atomically . (`writeTBMChan` msg) + +-- | Create JSON-RPC session around conduits from transport layer. When +-- context exits session disappears. +runJSONRPCT :: + (MonadLoggerIO m, MonadUnliftIO m) + => Ver -- ^ JSON-RPC version + -> Bool -- ^ Ignore incoming requests/notifs + -> ConduitT ByteString Void m () -- ^ Sink to send messages + -> ConduitT () ByteString m () -- ^ Source to receive messages from + -> JSONRPCT m a -- ^ JSON-RPC action + -> m a -- ^ Output of action +runJSONRPCT ver ignore snk src f = do + qs <- liftIO . atomically $ initSession ver ignore + let inSnk = sinkTBMChan (inCh qs) + outSrc = sourceTBMChan (outCh qs) + withAsync (runConduit $ src .| decodeConduit ver .| inSnk) $ const $ + withAsync (runConduit $ outSrc .| encodeConduit .| snk) $ \o -> + withAsync (runReaderT processIncoming qs) $ const $ do + a <- runReaderT f qs + liftIO $ do + atomically . closeTBMChan $ outCh qs + _ <- wait o + return a + + +cr :: Monad m => ConduitT ByteString ByteString m () +cr = CL.map (`B8.snoc` '\n') + +-- +-- Transports +-- + +-- | TCP client transport for JSON-RPC. +jsonrpcTCPClient + :: (MonadLoggerIO m, MonadUnliftIO m) + => Ver -- ^ JSON-RPC version + -> Bool -- ^ Ignore incoming requests or notifications + -> ClientSettings -- ^ Connection settings + -> JSONRPCT m a -- ^ JSON-RPC action + -> m a -- ^ Output of action +jsonrpcTCPClient ver ignore cs f = runGeneralTCPClient cs $ \ad -> + runJSONRPCT ver ignore (cr .| appSink ad) (appSource ad) f + +-- | TCP server transport for JSON-RPC. +jsonrpcTCPServer + :: (MonadLoggerIO m, MonadUnliftIO m) + => Ver -- ^ JSON-RPC version + -> Bool -- ^ Ignore incoming requests or notifications + -> ServerSettings -- ^ Connection settings + -> JSONRPCT m () -- ^ Action to perform on connecting client thread + -> m a +jsonrpcTCPServer ver ignore ss f = runGeneralTCPServer ss $ \cl -> + runJSONRPCT ver ignore (cr .| appSink cl) (appSource cl) f diff --git a/test/Network/JsonRpc/Tests.hs b/test/Network/JsonRpc/Tests.hs deleted file mode 100644 --- a/test/Network/JsonRpc/Tests.hs +++ /dev/null @@ -1,532 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Rank2Types #-} -module Network.JsonRpc.Tests (tests) where - -import Control.Applicative -import Control.Arrow -import Control.Concurrent.Async.Lifted -import Control.Concurrent.STM -import Control.Monad -import Control.Monad.Logger -import Control.Monad.Trans -import Control.Monad.Reader -import Data.Aeson -import Data.Aeson.Types -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Conduit -import qualified Data.Conduit.List as CL -import Data.Conduit.TMChan -import qualified Data.Foldable as F -import Data.Function -import Data.List -import Data.Either -import qualified Data.HashMap.Strict as M -import Data.Maybe -import Data.Word -import System.IO -import Network.JsonRpc -import Test.QuickCheck -import Test.QuickCheck.Monadic -import Test.Framework -import Test.Framework.Providers.QuickCheck2 - -tests :: [Test] -tests = - [ testGroup "Messages" - [ testProperty "Check request fields" - (reqFields :: Request -> Bool) - , testProperty "Encode/decode request" - (testEncodeDecode :: Request -> Bool) - , testProperty "Check response fields" - (resFields :: Response -> Bool) - , testProperty "Encode/decode response" - (testEncodeDecode :: Response -> Bool) - , testProperty "Encode/decode message" - (testEncodeDecode :: Message -> Bool) - ] - , testGroup "Conduits" - [ testProperty "Encoding" testEncodeConduit - , testProperty "Decoding" testDecodeConduit - , testProperty "Decode Garbage" testDecodeGarbageConduit - ] - , testGroup "Functions" - [ testProperty "Processing incoming messages" testProcessIncoming - , testProperty "Processing incoming responses" testIncomingResponse - , testProperty "Receiving incoming requests" testReceiveRequest - , testProperty "Receiving incoming batch requests" - testReceiveBatchRequest - , testProperty "Sending responses" testSendResponse - , testProperty "Sending batch responses" testSendBatchResponse - , testProperty "Sending request batch" testSendBatchRequest - ] - , testGroup "Network" - [ testProperty "Client/server talk" clientTest - , testProperty "Notifications" notifTest - ] - ] - -data ReqList = ReqList { getReqList :: [Req] } deriving (Show, Eq) - -instance Arbitrary ReqList where - arbitrary = resize 3 $ ReqList <$> arbitrary - -data Req = Req { getReq :: Request } deriving (Show, Eq) - -instance Arbitrary Req where - arbitrary = do - rq <- Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - return $ Req rq - -data ReqNot = ReqNotReq { getReqNotParams :: Value } - | ReqNotNot { getReqNotParams :: Value } - deriving (Show, Eq) - -instance ToJSON ReqNot where - toJSON = toJSON . getReqNotParams - -instance Arbitrary ReqNot where - arbitrary = oneof [ ReqNotReq <$> arbitrary , ReqNotNot <$> arbitrary ] - -instance ToRequest ReqNot where - requestMethod ReqNotReq{} = "request" - requestMethod ReqNotNot{} = "notification" - requestIsNotif ReqNotReq{} = False - requestIsNotif ReqNotNot{} = True - -data Struct = Struct Value deriving (Show, Eq) - -instance Arbitrary Struct where - arbitrary = resize 10 $ Struct <$> oneof [lsn, objn] where - nonull = oneof - [ toJSON <$> (arbitrary :: Gen String) - , toJSON <$> (arbitrary :: Gen Int) - , toJSON <$> (arbitrary :: Gen Double) - , toJSON <$> (arbitrary :: Gen Bool) - ] - val = oneof [ nonull, return Null ] - 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] - -reqFields :: Request -> Bool -reqFields rq = testFields (checkFieldsReq rq) rq - -resFields :: Response -> Bool -resFields rs = testFields (checkFieldsRes rs) rs - -fromRight :: Either a b -> b -fromRight (Right x) = x -fromRight _ = undefined - -checkVerId :: Ver -> Maybe Id -> Object -> Parser Bool -checkVerId ver i o = do - j <- o .:? "jsonrpc" - guard $ if ver == V2 then j == Just (String "2.0") else isNothing j - o .:? "id" >>= guard . (==i) - return True - -checkFieldsReqNotif - :: Ver -> Method -> Value -> Maybe Id -> Object -> Parser Bool -checkFieldsReqNotif ver m v i o = do - checkVerId ver i o >>= guard - o .: "method" >>= guard . (==m) - o .: "params" >>= guard . (==v) - return True - -checkFieldsReq :: Request -> Object -> Parser Bool -checkFieldsReq (Request ver m v i) = checkFieldsReqNotif ver m v (Just i) -checkFieldsReq (Notif ver m v) = checkFieldsReqNotif ver m v Nothing - -checkFieldsRes :: Response -> Object -> Parser Bool -checkFieldsRes (Response ver v i) o = do - checkVerId ver (Just i) o >>= guard - o .: "result" >>= guard . (==v) - return True -checkFieldsRes (ResponseError ver e i) o = do - checkVerId ver (Just i) o >>= guard - o .: "error" >>= guard . (==e) - return True -checkFieldsRes (OrphanError ver e) o = do - checkVerId ver Nothing o >>= guard - o .: "error" >>= guard . (==e) - return True - -testFields :: ToJSON r => (Object -> Parser Bool) -> r -> Bool -testFields ck r = fromMaybe False . parseMaybe f $ toJSON r where - f = withObject "json" ck - -testEncodeDecode :: (Eq r, ToJSON r, FromJSON r) => r -> Bool -testEncodeDecode r = maybe False (==r) $ parseMaybe parseJSON (toJSON r) - -testEncodeConduit :: [Message] -> Property -testEncodeConduit msgs = monadicIO $ do - rt <- run $ runNoLoggingT $ do - bs <- CL.sourceList msgs =$ encodeConduit $$ CL.consume - return $ map decodeStrict' bs - assert $ msgs == map fromJust rt - -testDecodeConduit :: ([Message], Ver) -> Property -testDecodeConduit (msgs, ver) = monadicIO $ do - rt <- run $ runNoLoggingT $ - CL.sourceList (buffer encoded) =$ decodeConduit ver $$ CL.consume - assert $ rt == map (Right . toJSON) msgs - where - encoded = B.concat $ map (L.toStrict . encode) msgs - buffer bs | B.null bs = [] - | otherwise = B.take 16 bs : buffer (B.drop 16 bs) - -testDecodeGarbageConduit :: ([[Word8]], Ver) -> Property -testDecodeGarbageConduit (ss, ver) = monadicIO $ do - _ <- run $ runNoLoggingT $ - CL.sourceList bss =$ decodeConduit ver $$ CL.consume - -- Just getting here without crashing is enough - assert True - where - bss = map B.pack ss - -testProcessIncoming :: ([Either Response Message], Ver, Bool) - -> Property -testProcessIncoming (msgs, ver, ignore) = monadicIO $ do - rt <- run $ runNoLoggingT $ do - expect <- liftIO . atomically $ newTMChan - qs <- liftIO . atomically $ initSession ver ignore - withAsync (cli qs expect msgs) $ \c -> do - runReaderT processIncoming qs - wait c - validate expect True - assert rt - where - validate expect state = do - newM <- liftIO . atomically $ readTMChan expect - case newM of - Just new -> validate expect $ new && state - Nothing -> return state - cli qs expect [] = liftIO . atomically $ do - closeTMChan expect - closeTBMChan $ inCh qs - cli qs expect (x:xs) = do - liftIO . atomically $ writeTBMChan (inCh qs) (toJSON <$> x) - liftIO . atomically $ case x of - Left e -> - caseLeftResponse qs e >>= writeTMChan expect - Right (MsgRequest req@Request{}) -> - caseSingleRequest req qs >>= writeTMChan expect - Right (MsgRequest nt@Notif{}) -> - caseSingleNotif nt qs >>= writeTMChan expect - Right MsgResponse{} -> - writeTMChan expect True - Right (MsgBatch []) -> - caseEmptyBatch qs >>= writeTMChan expect - Right (MsgBatch ms) -> - caseBatch qs ms >>= writeTMChan expect - cli qs expect xs - caseLeftResponse qs e = do - m <- readTBMChan $ outCh qs - case m of - Just (MsgResponse err) -> return $ err == e - _ -> return False - caseEmptyBatch qs = do - m <- readTBMChan $ outCh qs - case m of - Just (MsgResponse (OrphanError v (ErrorObj _ i _))) -> - return $ v == rpcVer qs && i == (-32600) - _ -> return False - caseBatch qs ms = do - let isrq (MsgRequest Request{}) = True - isrq _ = False - isnotif (MsgRequest Notif{}) = True - isnotif _ = False - if any isrq ms - then - if ignore - then do - m <- readTBMChan $ outCh qs - case m of - Just MsgBatch{} -> return True - _ -> return False - else do - m <- readTBMChan $ fromJust $ reqCh qs - case m of - Just BatchRequest{} -> return True - _ -> return False - else - if any isnotif ms - then - if ignore - then return True - else do - m <- readTBMChan $ fromJust $ reqCh qs - case m of - Just BatchRequest{} -> return True - _ -> return False - else return True - caseSingleRequest req qs = - if ignore - then do - m <- readTBMChan $ outCh qs - case m of - Just (MsgResponse (ResponseError _ e@ErrorObj{} _)) -> - return $ getErrCode e == (-32601) - _ -> return False - else do - m <- readTBMChan (fromJust $ reqCh qs) - return $ m == Just (SingleRequest req) - caseSingleNotif nt qs = - if ignore - then return True - else do - m <- readTBMChan (fromJust $ reqCh qs) - return $ m == Just (SingleRequest nt) - -testIncomingResponse :: ([ReqList], Ver, Bool) -> Property -testIncomingResponse (reqss', ver, ignore) = nodup ==> monadicIO $ do - rt <- run $ runNoLoggingT $ do - expect <- liftIO . atomically $ newTMChan - qs <- liftIO . atomically $ do - qs <- initSession ver ignore - s <- sent - writeTVar (sentReqs qs) s - return qs - withAsync (cli qs expect msgs) $ \c -> do - runReaderT processIncoming qs - wait c - valid <- validate expect responses True - mapempty <- liftIO . atomically $ M.null <$> readTVar (sentReqs qs) - return $ valid && mapempty - assert rt - where - reqss = map getReqList reqss' - reqs = let f [q] = SingleRequest (getReq q) - f qs = BatchRequest (map getReq qs) - in map f reqss - flatreqs = let f (BatchRequest bt) = bt - f (SingleRequest rt) = [rt] - in concatMap f reqs - nodup = length (nubBy ((==) `on` getReqId) flatreqs) == length flatreqs - respond (Request v _ p i) = Response v p i - respond _ = undefined - responses = map respond flatreqs - msgs = map MsgResponse responses - sent = do - promises <- forM flatreqs $ - \Request{getReqId = i} -> (,) i <$> newEmptyTMVar - return $ M.fromList promises - validate _ [] state = return state - validate expect (x:xs) state = do - newM <- liftIO . atomically $ readTMChan expect - case newM of - Just new -> validate expect xs (new == x && state) - Nothing -> return state - cli qs expect [] = liftIO . atomically $ do - closeTMChan expect - closeTBMChan $ inCh qs - cli qs expect (x:xs) = - case x of - MsgResponse res -> do - p <- getpromise qs res - liftIO . atomically $ writeTBMChan (inCh qs) (Right $ toJSON x) - liftIO . atomically $ do - rE <- readTMVar p - F.forM_ rE $ writeTMChan expect - cli qs expect xs - MsgBatch resps -> do - ps <- mapM (getpromise qs . getMsgResponse) resps - liftIO . atomically $ writeTBMChan (inCh qs) (Right $ toJSON x) - forM_ ps $ \p -> liftIO . atomically $ do - rE <- readTMVar p - F.forM_ rE $ writeTMChan expect - _ -> undefined - getpromise qs res = do - let i = getResId res - liftIO . atomically $ do - snt <- readTVar (sentReqs qs) - return . fromJust $ M.lookup i snt - -testSendBatchRequest :: ([(ReqNot, Either ErrorObj Value)], Ver, Bool) - -> Property -testSendBatchRequest (reqnotres, ver, ignore) = nonull ==> monadicIO $ do - rs <- run $ runNoLoggingT $ do - qs <- liftIO . atomically $ initSession ver ignore - withAsync (cli qs) $ \c -> do - rs <- runReaderT (sendBatchRequest $ map fst reqnotres) qs - wait c - return (rs :: [Maybe (Either ErrorObj Value)]) - assert $ length rs == length reqnotres - where - nonull = not $ null reqnotres - resmap = M.fromList $ map (first toJSON) reqnotres - respond (Request v _ _ i) (Left y) = Just $ ResponseError v y i - respond (Request v _ _ i) (Right y) = Just $ Response v y i - respond _ _ = undefined - fulfill req sent = F.forM_ (getReqId req `M.lookup` sent) $ \p -> - putTMVar p $ respond req $ fromJust $ getReqParams req `M.lookup` resmap - cli qs = liftIO . atomically $ do - msg <- readTBMChan (outCh qs) - sent <- readTVar (sentReqs qs) - case msg of - Just (MsgRequest req@Request{}) -> fulfill req sent - Just (MsgBatch bt) -> - forM_ bt $ \m -> - case m of - MsgRequest req@Request{} -> fulfill req sent - _ -> return () - _ -> return () - -testReceiveRequest :: ([BatchRequest], Ver, Bool) -> Property -testReceiveRequest (reqs, ver, ignore) = monadicIO $ do - rt <- run $ runNoLoggingT $ do - qs <- liftIO . atomically $ initSession ver ignore - withAsync (send qs) $ \c -> do - res <- runReaderT receive qs - wait c - return res - assert $ and rt - where - send qs = F.forM_ (reqCh qs) $ \qch -> do - forM_ reqs $ liftIO . atomically . writeTBMChan qch - liftIO . atomically $ closeTBMChan qch - receive = forM reqs $ \q -> do - t <- receiveRequest - if ignore - then return $ isNothing t - else - case q of - SingleRequest{} -> - return $ Just q == fmap SingleRequest t - BatchRequest{} -> do - ch <- reader outCh - m <- liftIO . atomically $ readTBMChan ch - case m of - Just (MsgResponse OrphanError{}) -> - return $ isNothing t - _ -> return $ isNothing t - - -testReceiveBatchRequest :: ([BatchRequest], Ver, Bool) -> Property -testReceiveBatchRequest (reqs, ver, ignore) = monadicIO $ do - rt <- run $ runNoLoggingT $ do - qs <- liftIO . atomically $ initSession ver ignore - withAsync (send qs) $ \c -> do - rt <- runReaderT receive qs - wait c - return rt - if ignore - then assert $ all isNothing rt - else assert $ all isJust rt && map fromJust rt == reqs - where - send qs = F.forM_ (reqCh qs) $ \qch -> do - forM_ reqs $ liftIO . atomically . writeTBMChan qch - liftIO . atomically $ closeTBMChan qch - receive = forM reqs $ const receiveBatchRequest - -testSendResponse :: ([Response], Ver, Bool) -> Property -testSendResponse (responses, ver, ignore) = monadicIO $ do - ex <- run $ runNoLoggingT $ do - qs <- liftIO . atomically $ initSession ver ignore - withAsync (receive qs) $ \c -> do - runReaderT send qs - wait c - assert $ length ex == length responses - assert $ all isJust ex && map fromJust ex == map MsgResponse responses - where - send = forM_ responses sendResponse - receive qs = forM responses $ const $ liftIO . atomically $ - readTBMChan (outCh qs) - -testSendBatchResponse :: ([BatchResponse], Ver, Bool) -> Property -testSendBatchResponse (responses, ver, ignore) = monadicIO $ do - ex <- run $ runNoLoggingT $ do - qs <- liftIO . atomically $ initSession ver ignore - withAsync (receive qs) $ \c -> do - runReaderT send qs - wait c - assert $ length ex == length responses - assert $ all isJust ex && map fromJust ex == map msg responses - where - msg (BatchResponse bt) = MsgBatch $ map MsgResponse bt - msg (SingleResponse r) = MsgResponse r - send = forM_ responses sendBatchResponse - receive qs = forM responses $ const $ liftIO . atomically $ - readTBMChan (outCh qs) - -createChans :: MonadIO m - => m ((TBMChan a, TBMChan b), (Sink a m (), Source m b)) -createChans = do - (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16 <*> newTBMChan 16 - let (snk, src) = (sinkTBMChan bso False, sourceTBMChan bsi) - return ((bso, bsi), (snk, src)) - -clientTest :: ([Value], Ver) -> Property -clientTest (qs, ver) = monadicIO $ do - rt <- run $ runNoLoggingT $ do - ((bso, bsi), (snk, src)) <- createChans - let csnk = sinkTBMChan bsi False :: Sink B.ByteString (NoLoggingT IO) () - csrc = sourceTBMChan bso :: Source (NoLoggingT IO) B.ByteString - withAsync (server snk src) $ const $ cli csnk csrc - assert $ length rt == length qs - assert $ null rt || all correct rt - assert $ qs == results rt - where - respond q = return $ Right (q :: Value) - server snk src = runJsonRpcT ver False snk src (srv respond) - cli snk src = runJsonRpcT ver True snk src . forM qs $ sendRequest - results = map $ fromRight . fromJust - correct (Just (Right _)) = True - correct _ = False - -notifTest :: ([Request], Ver) -> Property -notifTest (qs, ver) = monadicIO $ do - nt <- run $ runNoLoggingT $ do - ((bso, bsi), (snk, src)) <- createChans - let csnk = sinkTBMChan bsi False - csrc = sourceTBMChan bso - (sig, notifs) <- liftIO . atomically $ - (,) <$> newEmptyTMVar <*> newTVar [] - withAsync (server snk src sig notifs) $ const $ cli sig csnk csrc - liftIO . atomically $ readTVar notifs - assert $ length nt == length ntfs - assert $ reverse nt == ntfs - where - respond q = return $ Right (q :: Value) - server snk src sig notifs = - runJsonRpcT ver False snk src (process sig notifs) - process sig notifs = do - qM <- receiveRequest - case qM of - Nothing -> return () - Just q -> do - case q of - Notif{} -> liftIO . atomically $ - readTVar notifs >>= writeTVar notifs . (q:) - Request{ getReqParams = String "disconnect" } -> - liftIO . atomically $ putTMVar sig () - Request{} -> return () - rM <- buildResponse respond q - case rM of - Nothing -> process sig notifs - Just r -> sendResponse r >> process sig notifs - reqs = map MsgRequest qs - cli sig snk src = runJsonRpcT ver True snk src $ do - forM_ reqs sendMessage - _ <- sendRequest $ String "disconnect" - :: JsonRpcT (NoLoggingT IO) (Maybe (Either ErrorObj Value)) - liftIO . atomically $ takeTMVar sig - ntfs = flip filter qs $ \q -> case q of Notif{} -> True; _ -> False - -srv :: (MonadLoggerIO m, FromRequest q, ToJSON r) - => Respond q (JsonRpcT m) r -> JsonRpcT m () -srv respond = do - qM <- receiveRequest - case qM of - Nothing -> return () - Just q -> do - rM <- buildResponse respond q - case rM of - Nothing -> srv respond - Just r -> sendResponse r >> srv respond diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,558 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Rank2Types #-} +{-# LANGUAGE ScopedTypeVariables #-} +import Control.Arrow +import Control.Monad +import Control.Monad.Logger +import Control.Monad.Reader +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Data.Conduit +import qualified Data.Conduit.List as CL +import Data.Conduit.TMChan +import qualified Data.Foldable as F +import Data.Function +import qualified Data.HashMap.Strict as M +import Data.List +import Data.Maybe +import Data.Word +import Network.JSONRPC +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Monadic +import UnliftIO hiding (assert) + +main :: IO () +main = hspec $ do + describe "encoder/decoder" $ do + prop "checks request fields" (reqFields :: Request -> Bool) + prop "encodes and decodes requests" (testEncodeDecode :: Request -> Bool) + prop "checks response fields" (resFields :: Response -> Bool) + prop "encodes and decodes responses" (testEncodeDecode :: Response -> Bool) + prop "encodes and decodes messages" (testEncodeDecode :: Message -> Bool) + describe "conduits" $ do + prop "encodes messages" testEncodeConduit + prop "decodes messages" testDecodeConduit + prop "tries to decode garbage" testDecodeGarbageConduit + describe "processor" $ do + prop "processes incoming messages" testProcessIncoming + prop "processes incoming responses" testIncomingResponse + prop "receives incoming requests" testReceiveRequest + prop "receives incoming batch requests" testReceiveBatchRequest + prop "sends responses" testSendResponse + prop "sends batch responses" testSendBatchResponse + prop "sends request batch" testSendBatchRequest + describe "network client and server" $ do + prop "communicates" clientTest + prop "sends and receives notifications" notifTest + +newtype ReqList = ReqList { getReqList :: [Req] } deriving (Show, Eq) + +instance Arbitrary ReqList where + arbitrary = resize 3 $ ReqList <$> arbitrary + +newtype Req = Req { getReq :: Request } deriving (Show, Eq) + +instance Arbitrary Req where + arbitrary = do + rq <- Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary + return $ Req rq + +data ReqNot = ReqNotReq { getReqNotParams :: Value } + | ReqNotNot { getReqNotParams :: Value } + deriving (Show, Eq) + +instance ToJSON ReqNot where + toJSON = toJSON . getReqNotParams + +instance Arbitrary ReqNot where + arbitrary = oneof [ ReqNotReq <$> arbitrary , ReqNotNot <$> arbitrary ] + +instance ToRequest ReqNot where + requestMethod ReqNotReq{} = "request" + requestMethod ReqNotNot{} = "notification" + requestIsNotif ReqNotReq{} = False + requestIsNotif ReqNotNot{} = True + +newtype Struct = Struct Value deriving (Show, Eq) + +instance Arbitrary Struct where + arbitrary = resize 10 $ Struct <$> oneof [lsn, objn] where + nonull = oneof + [ toJSON <$> (arbitrary :: Gen String) + , toJSON <$> (arbitrary :: Gen Int) + , toJSON <$> (arbitrary :: Gen Double) + , toJSON <$> (arbitrary :: Gen Bool) + ] + val = oneof [ nonull, return Null ] + 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] + +reqFields :: Request -> Bool +reqFields rq = testFields (checkFieldsReq rq) rq + +resFields :: Response -> Bool +resFields rs = testFields (checkFieldsRes rs) rs + +checkVerId :: Ver -> Maybe Id -> Object -> Parser Bool +checkVerId ver i o = do + j <- o .:? "jsonrpc" + guard $ if ver == V2 then j == Just (String "2.0") else isNothing j + o .:? "id" >>= guard . (==i) + return True + +checkFieldsReqNotif + :: Ver -> Method -> Value -> Maybe Id -> Object -> Parser Bool +checkFieldsReqNotif ver m v i o = do + checkVerId ver i o >>= guard + o .: "method" >>= guard . (==m) + o .: "params" >>= guard . (==v) + return True + +checkFieldsReq :: Request -> Object -> Parser Bool +checkFieldsReq (Request ver m v i) = checkFieldsReqNotif ver m v (Just i) +checkFieldsReq (Notif ver m v) = checkFieldsReqNotif ver m v Nothing + +checkFieldsRes :: Response -> Object -> Parser Bool +checkFieldsRes (Response ver v i) o = do + checkVerId ver (Just i) o >>= guard + o .: "result" >>= guard . (==v) + return True +checkFieldsRes (ResponseError ver e i) o = do + checkVerId ver (Just i) o >>= guard + o .: "error" >>= guard . (==e) + return True +checkFieldsRes (OrphanError ver e) o = do + checkVerId ver Nothing o >>= guard + o .: "error" >>= guard . (==e) + return True + +testFields :: ToJSON r => (Object -> Parser Bool) -> r -> Bool +testFields ck r = fromMaybe False . parseMaybe f $ toJSON r where + f = withObject "json" ck + +testEncodeDecode :: (Eq r, ToJSON r, FromJSON r) => r -> Bool +testEncodeDecode r = (== Just r) $ parseMaybe parseJSON (toJSON r) + +testEncodeConduit :: [Message] -> Property +testEncodeConduit msgs = + monadicIO $ do + rt <- + run . runNoLoggingT $ do + bs <- + runConduit $ + CL.sourceList msgs .| encodeConduit .| CL.consume + return $ map decodeStrict' bs + assert $ msgs == map fromJust rt + +testDecodeConduit :: ([Message], Ver) -> Property +testDecodeConduit (msgs, ver) = + monadicIO $ do + rt <- + run . runNoLoggingT . runConduit $ + CL.sourceList (buffer encoded) .| decodeConduit ver .| CL.consume + assert $ rt == map (Right . toJSON) msgs + where + encoded = B.concat $ map (L.toStrict . encode) msgs + buffer bs + | B.null bs = [] + | otherwise = B.take 16 bs : buffer (B.drop 16 bs) + +testDecodeGarbageConduit :: ([[Word8]], Ver) -> Property +testDecodeGarbageConduit (ss, ver) = + monadicIO $ do + _ <- + run . runNoLoggingT . runConduit $ + CL.sourceList bss .| decodeConduit ver .| CL.consume + -- Just getting here without crashing is enough + assert True + where + bss = map B.pack ss + +testProcessIncoming :: ([Either Response Message], Ver, Bool) + -> Property +testProcessIncoming (msgs, ver, ignore) = monadicIO $ do + rt <- run $ runNoLoggingT $ do + expect <- liftIO . atomically $ newTMChan + qs <- liftIO . atomically $ initSession ver ignore + withAsync (cli qs expect msgs) $ \c -> do + runReaderT processIncoming qs + wait c + validate expect True + assert rt + where + validate expect state = do + newM <- liftIO . atomically $ readTMChan expect + case newM of + Just new -> validate expect $ new && state + Nothing -> return state + cli qs expect [] = liftIO . atomically $ do + closeTMChan expect + closeTBMChan $ inCh qs + cli qs expect (x:xs) = do + liftIO . atomically $ writeTBMChan (inCh qs) (toJSON <$> x) + liftIO . atomically $ case x of + Left e -> + caseLeftResponse qs e >>= writeTMChan expect + Right (MsgRequest req@Request{}) -> + caseSingleRequest req qs >>= writeTMChan expect + Right (MsgRequest nt@Notif{}) -> + caseSingleNotif nt qs >>= writeTMChan expect + Right MsgResponse{} -> + writeTMChan expect True + Right (MsgBatch []) -> + caseEmptyBatch qs >>= writeTMChan expect + Right (MsgBatch ms) -> + caseBatch qs ms >>= writeTMChan expect + cli qs expect xs + caseLeftResponse qs e = do + m <- readTBMChan $ outCh qs + case m of + Just (MsgResponse err) -> return $ err == e + _ -> return False + caseEmptyBatch qs = do + m <- readTBMChan $ outCh qs + case m of + Just (MsgResponse (OrphanError v (ErrorObj _ i _))) -> + return $ v == rpcVer qs && i == (-32600) + _ -> return False + caseBatch qs ms = do + let isrq (MsgRequest Request{}) = True + isrq _ = False + isnotif (MsgRequest Notif{}) = True + isnotif _ = False + if any isrq ms + then + if ignore + then do + m <- readTBMChan $ outCh qs + case m of + Just MsgBatch{} -> return True + _ -> return False + else do + m <- readTBMChan $ fromJust $ reqCh qs + case m of + Just BatchRequest{} -> return True + _ -> return False + else + if any isnotif ms + then + if ignore + then return True + else do + m <- readTBMChan $ fromJust $ reqCh qs + case m of + Just BatchRequest{} -> return True + _ -> return False + else return True + caseSingleRequest req qs = + if ignore + then do + m <- readTBMChan $ outCh qs + case m of + Just (MsgResponse (ResponseError _ e@ErrorObj{} _)) -> + return $ getErrCode e == (-32601) + _ -> return False + else do + m <- readTBMChan (fromJust $ reqCh qs) + return $ m == Just (SingleRequest req) + caseSingleNotif nt qs = + if ignore + then return True + else do + m <- readTBMChan (fromJust $ reqCh qs) + return $ m == Just (SingleRequest nt) + +testIncomingResponse :: ([ReqList], Ver, Bool) -> Property +testIncomingResponse (reqss', ver, ignore) = + nodup ==> monadicIO . run . runNoLoggingT $ do + expect <- liftIO $ atomically newTMChan + qs <- + liftIO . atomically $ do + qs <- initSession ver ignore + s <- sent + writeTVar (sentReqs qs) s + return qs + withAsync (cli qs expect msgs) $ \c -> do + runReaderT processIncoming qs + wait c + valid <- validate expect responses + unless valid (error "Could not validate expected responses") + mapempty <- liftIO . atomically $ M.null <$> readTVar (sentReqs qs) + unless mapempty (error "Sent requests still found in state") + where + reqss = map getReqList reqss' + reqs = + let f [q] = SingleRequest (getReq q) + f qs = BatchRequest (map getReq qs) + in map f reqss + flatreqs = + let f (BatchRequest bt) = bt + f (SingleRequest rt) = [rt] + in concatMap f reqs + nodup = length (nubBy ((==) `on` getReqId) flatreqs) == length flatreqs + respond (Request v _ p i) = Response v p i + respond _ = undefined + responses = map respond flatreqs + msgs = map MsgResponse responses + sent = do + promises <- + forM flatreqs $ \Request {getReqId = i} -> (,) i <$> newEmptyTMVar + return $ M.fromList promises + validate _ [] = return True + validate expect (x:xs) = + liftIO (atomically (readTMChan expect)) >>= \case + Nothing -> return False + Just new + | new == x -> validate expect xs + | otherwise -> return False + cli qs expect [] = + liftIO . atomically $ do + closeTMChan expect + closeTBMChan $ inCh qs + cli qs expect (x:xs) = + case x of + MsgResponse res -> + getpromise qs res >>= \case + Nothing -> error "Could not find promise" + Just p -> do + liftIO . atomically $ + writeTBMChan (inCh qs) (Right $ toJSON x) + liftIO . atomically $ do + rE <- readTMVar p + F.forM_ rE $ writeTMChan expect + cli qs expect xs + MsgBatch resps -> do + ps <- catMaybes <$> mapM (getpromise qs . getMsgResponse) resps + when + (length ps /= length resps) + (error "Could not find a promise for a batch response") + liftIO . atomically $ writeTBMChan (inCh qs) (Right $ toJSON x) + forM_ ps $ \p -> + liftIO . atomically $ do + rE <- readTMVar p + F.forM_ rE $ writeTMChan expect + _ -> error "Unexpected response type" + getpromise qs res = + liftIO . atomically $ do + let i = getResId res + snt <- readTVar (sentReqs qs) + return $ M.lookup i snt + +testSendBatchRequest :: ([(ReqNot, Either ErrorObj Value)], Ver, Bool) + -> Property +testSendBatchRequest (reqnotres, ver, ignore) = + nonull ==> monadicIO $ do + rs <- + run $ + runNoLoggingT $ do + qs <- liftIO . atomically $ initSession ver ignore + withAsync (cli qs) $ \c -> do + rs <- runReaderT (sendBatchRequest $ map fst reqnotres) qs + wait c + return (rs :: [Maybe (Either ErrorObj Value)]) + assert $ length rs == length reqnotres + where + nonull = not $ null reqnotres + resmap = M.fromList $ map (first toJSON) reqnotres + respond (Request v _ _ i) (Left y) = Just $ ResponseError v y i + respond (Request v _ _ i) (Right y) = Just $ Response v y i + respond _ _ = undefined + fulfill req sent = + F.forM_ (getReqId req `M.lookup` sent) $ \p -> + putTMVar p $ + respond req $ fromJust $ getReqParams req `M.lookup` resmap + cli qs = + liftIO . atomically $ do + msg <- readTBMChan (outCh qs) + sent <- readTVar (sentReqs qs) + case msg of + Just (MsgRequest req@Request {}) -> fulfill req sent + Just (MsgBatch bt) -> + forM_ bt $ \case + MsgRequest req@Request {} -> fulfill req sent + _ -> return () + _ -> return () + +testReceiveRequest :: ([BatchRequest], Ver, Bool) -> Property +testReceiveRequest (reqs, ver, ignore) = + monadicIO $ do + rt <- + run . runNoLoggingT $ do + qs <- liftIO . atomically $ initSession ver ignore + withAsync (send qs) $ \c -> do + res <- runReaderT receive qs + wait c + return res + assert $ and rt + where + send qs = + F.forM_ (reqCh qs) $ \qch -> do + forM_ reqs $ liftIO . atomically . writeTBMChan qch + liftIO . atomically $ closeTBMChan qch + receive = + forM reqs $ \q -> do + t <- receiveRequest + if ignore + then return $ isNothing t + else case q of + SingleRequest {} -> + return $ Just q == fmap SingleRequest t + BatchRequest {} -> do + ch <- reader outCh + m <- liftIO . atomically $ readTBMChan ch + case m of + Just (MsgResponse OrphanError {}) -> + return $ isNothing t + _ -> return $ isNothing t + + +testReceiveBatchRequest :: ([BatchRequest], Ver, Bool) -> Property +testReceiveBatchRequest (reqs, ver, ignore) = monadicIO $ do + rt <- run $ runNoLoggingT $ do + qs <- liftIO . atomically $ initSession ver ignore + withAsync (send qs) $ \c -> do + rt <- runReaderT receive qs + wait c + return rt + if ignore + then assert $ all isNothing rt + else assert $ all isJust rt && map fromJust rt == reqs + where + send qs = F.forM_ (reqCh qs) $ \qch -> do + forM_ reqs $ liftIO . atomically . writeTBMChan qch + liftIO . atomically $ closeTBMChan qch + receive = forM reqs $ const receiveBatchRequest + +testSendResponse :: ([Response], Ver, Bool) -> Property +testSendResponse (responses, ver, ignore) = monadicIO $ do + ex <- run $ runNoLoggingT $ do + qs <- liftIO . atomically $ initSession ver ignore + withAsync (receive qs) $ \c -> do + runReaderT send qs + wait c + assert $ length ex == length responses + assert $ all isJust ex && map fromJust ex == map MsgResponse responses + where + send = forM_ responses sendResponse + receive qs = forM responses $ const $ liftIO . atomically $ + readTBMChan (outCh qs) + +testSendBatchResponse :: ([BatchResponse], Ver, Bool) -> Property +testSendBatchResponse (responses, ver, ignore) = monadicIO $ do + ex <- run $ runNoLoggingT $ do + qs <- liftIO . atomically $ initSession ver ignore + withAsync (receive qs) $ \c -> do + runReaderT send qs + wait c + assert $ length ex == length responses + assert $ all isJust ex && map fromJust ex == map msg responses + where + msg (BatchResponse bt) = MsgBatch $ map MsgResponse bt + msg (SingleResponse r) = MsgResponse r + send = forM_ responses sendBatchResponse + receive qs = forM responses $ const $ liftIO . atomically $ + readTBMChan (outCh qs) + +createChans :: + MonadIO m + => m ((TBMChan a, TBMChan b), (ConduitT a Void m (), ConduitT () b m ())) +createChans = do + (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16 <*> newTBMChan 16 + let (snk, src) = (sinkTBMChan bso, sourceTBMChan bsi) + return ((bso, bsi), (snk, src)) + +clientTest :: ([Value], Ver) -> Property +clientTest (qs, ver) = + monadicIO $ do + rt <- + run $ + runNoLoggingT $ do + ((bso, bsi), (snk, src)) <- createChans + let csnk = + sinkTBMChan bsi :: ConduitT B.ByteString Void (NoLoggingT IO) () + csrc = + sourceTBMChan bso :: ConduitT () B.ByteString (NoLoggingT IO) () + withAsync (server snk src) $ const $ cli csnk csrc + assert $ length rt == length qs + assert $ null rt || all correct rt + assert $ qs == results rt + where + respond q = return $ Right (q :: Value) + server snk src = runJSONRPCT ver False snk src (srv respond) + cli snk src = runJSONRPCT ver True snk src . forM qs $ sendRequest + results = + map $ \case + (Just (Right r)) -> r + _ -> error "Bad result" + correct (Just (Right _)) = True + correct _ = False + +notifTest :: ([Request], Ver) -> Property +notifTest (qs, ver) = + monadicIO $ do + nt <- + run $ + runNoLoggingT $ do + ((bso, bsi), (snk, src)) <- createChans + let csnk = sinkTBMChan bsi + csrc = sourceTBMChan bso + (sig, notifs) <- + liftIO . atomically $ (,) <$> newEmptyTMVar <*> newTVar [] + withAsync (server snk src sig notifs) $ + const $ cli sig csnk csrc + liftIO . atomically $ readTVar notifs + assert $ length nt == length ntfs + assert $ reverse nt == ntfs + where + respond q = return $ Right (q :: Value) + server snk src sig notifs = + runJSONRPCT ver False snk src (process sig notifs) + process sig notifs = do + qM <- receiveRequest + case qM of + Nothing -> return () + Just q -> do + case q of + Notif {} -> + liftIO . atomically $ + readTVar notifs >>= writeTVar notifs . (q :) + Request {getReqParams = String "disconnect"} -> + liftIO . atomically $ putTMVar sig () + Request {} -> return () + rM <- buildResponse respond q + case rM of + Nothing -> process sig notifs + Just r -> sendResponse r >> process sig notifs + reqs = map MsgRequest qs + cli sig snk src = + runJSONRPCT ver True snk src $ do + forM_ reqs sendMessage + _ <- + sendRequest $ String "disconnect" :: JSONRPCT (NoLoggingT IO) (Maybe (Either ErrorObj Value)) + liftIO . atomically $ takeTMVar sig + ntfs = + flip filter qs $ \case + Notif {} -> True + _ -> False + +srv :: (MonadLoggerIO m, FromRequest q, ToJSON r) + => Respond q (JSONRPCT m) r -> JSONRPCT m () +srv respond = do + qM <- receiveRequest + case qM of + Nothing -> return () + Just q -> do + rM <- buildResponse respond q + case rM of + Nothing -> srv respond + Just r -> sendResponse r >> srv respond diff --git a/test/main.hs b/test/main.hs deleted file mode 100644 --- a/test/main.hs +++ /dev/null @@ -1,6 +0,0 @@ -import Test.Framework -import Network.JsonRpc.Tests - -main :: IO () -main = defaultMain tests -