diff --git a/Network/JsonRpc/Conduit.hs b/Network/JsonRpc/Conduit.hs --- a/Network/JsonRpc/Conduit.hs +++ b/Network/JsonRpc/Conduit.hs @@ -42,7 +42,7 @@ import Data.Text (Text) import Network.JsonRpc.Data --- | Conduits of sending and receiving JSON-RPC messages. +-- | Conduits for sending and receiving JSON-RPC messages. type AppConduits qo no ro qi ni ri m = (Source m (IncomingMsg qo qi ni ri), Sink (Message qo no ro) m ()) @@ -93,7 +93,7 @@ -> Session qo -> Conduit (Message qo no ro) m (Message qo no ro) msgConduit c qs = await >>= \nqM -> case nqM of - Nothing -> do + Nothing -> when c . liftIO . atomically $ writeTQueue (isLast qs) True Just (MsgRequest rq) -> do msg <- MsgRequest <$> liftIO (atomically $ addId rq) @@ -132,7 +132,7 @@ f re = if c && re then do l <- liftIO . atomically $ readTQueue (isLast qs) - if l then return () else loop + unless l loop else loop loop = lift await >>= maybe flush process @@ -236,7 +236,7 @@ -- Will create JSON-RPC conduits around 'ByteString' conduits from a transport -- layer. -runConduits :: ( FromRequest qi, FromNotif ni, FromResponse ri +runConduits :: ( FromRequest qi, FromNotif ni, FromResponse ri , ToJSON qo, ToJSON no, ToJSON ro ) => Ver -- ^ JSON-RPC version -> Bool -- ^ Disconnect on last response @@ -246,7 +246,8 @@ -- ^ JSON-RPC action -> IO a -- ^ Output of action runConduits ver d rpcSnk rpcSrc f = do - (reqChan, msgChan) <- atomically $ (,) <$> newTBMChan 128 <*> newTBMChan 128 + (reqChan, msgChan) <- atomically $ (,) <$> newTBMChan 128 + <*> newTBMChan 128 let inbSrc = sourceTBMChan msgChan inbSnk = sinkTBMChan msgChan True outSrc = sourceTBMChan reqChan @@ -275,11 +276,19 @@ -> (AppConduits qo no ro qi ni ri IO -> IO a) -- ^ JSON-RPC action -> IO a -- ^ Output of action -tcpClient ver d cs f = runTCPClient cs $ \ad -> do +tcpClient ver d cs f = runTCPClient cs $ \ad -> runConduits ver d (cr =$ appSink ad) (appSource ad $= ln) f where - cr = CL.map (flip B8.snoc '\n') - ln = CL.mapFoldable B8.lines + cr = CL.map (`B8.snoc` '\n') + ln = await >>= \bsM -> case bsM of + Nothing -> return () + Just bs -> let (l, ls) = B8.break (=='\n') bs in case ls of + "" -> await >>= \bsM' -> case bsM' of + Nothing -> if B8.null l then return () else yield l + Just bs' -> leftover (bs `B8.append` bs') >> ln + _ -> case l of + "" -> leftover (B8.tail ls) >> ln + _ -> leftover (B8.tail ls) >> yield l >> ln -- JSON-RPC-over-TCP server. tcpServer :: ( FromRequest qi, FromNotif ni, FromResponse ri @@ -289,8 +298,7 @@ -> (AppConduits qo no ro qi ni ri IO -> IO ()) -- ^ JSON-RPC action to perform on connecting client thread -> IO () -tcpServer ver ss f = runTCPServer ss $ \cl -> do +tcpServer ver ss f = runTCPServer ss $ \cl -> runConduits ver False (cr =$ appSink cl) (appSource cl) f where - cr = CL.map (flip B8.snoc '\n') - + cr = CL.map (`B8.snoc` '\n') diff --git a/Network/JsonRpc/Data.hs b/Network/JsonRpc/Data.hs --- a/Network/JsonRpc/Data.hs +++ b/Network/JsonRpc/Data.hs @@ -287,11 +287,11 @@ -- | Invalid params. errorParams :: Ver -> Value -> Id -> ErrorObj -errorParams ver v i = ErrorObj ver "Invalid params" (-32602) v i +errorParams ver v = ErrorObj ver "Invalid params" (-32602) v -- | Method not found. errorMethod :: Ver -> Method -> Id -> ErrorObj -errorMethod ver m i = ErrorObj ver "Method not found" (-32601) (toJSON m) i +errorMethod ver m = ErrorObj ver "Method not found" (-32601) (toJSON m) -- | Id not recognized. errorId :: Ver -> Id -> ErrorObj @@ -344,14 +344,14 @@ rnf _ = () instance Enum Id where - toEnum i = IdInt i + toEnum = IdInt fromEnum (IdInt i) = i - fromEnum _ = error $ "Can't enumerate non-integral ids" + fromEnum _ = error "Can't enumerate non-integral ids" instance FromJSON Id where parseJSON s@(String _) = IdTxt <$> parseJSON s parseJSON n@(Number _) = IdInt <$> parseJSON n - parseJSON Null = return $ IdNull + parseJSON Null = return IdNull parseJSON _ = mzero instance ToJSON Id where diff --git a/json-rpc.cabal b/json-rpc.cabal --- a/json-rpc.cabal +++ b/json-rpc.cabal @@ -1,5 +1,5 @@ name: json-rpc -version: 0.2.1.5 +version: 0.2.1.6 synopsis: Fully-featured JSON-RPC 2.0 library description: This JSON-RPC library is fully-compatible with JSON-RPC 2.0 and diff --git a/test/Network/JsonRpc/Tests.hs b/test/Network/JsonRpc/Tests.hs --- a/test/Network/JsonRpc/Tests.hs +++ b/test/Network/JsonRpc/Tests.hs @@ -53,9 +53,9 @@ (newMsgConduit :: [Message Value Value Value] -> Property) , testProperty "Decode requests" (decodeReqConduit :: ([Request Value], Ver) -> Property) - , testProperty "Decode responses" + , testProperty "Decode responses" (decodeResConduit :: ([ReqRes Value Value], Ver) -> Property) - , testProperty "Bad responses" + , testProperty "Bad responses" (decodeErrConduit :: ([ReqRes Value Value], Ver) -> Property) , testProperty "Sending messages" sendMsgNet , testProperty "Two-way communication" twoWayNet @@ -79,13 +79,13 @@ vals m p i = fromMaybe False $ parseMaybe (f m p i) o f m p i _ = do j <- o .:? "jsonrpc" - guard $ fromMaybe True $ fmap (== ("2.0" :: Text)) j + guard $ maybe True (== ("2.0" :: Text)) j i' <- o .: "id" guard $ i == i' m' <- o .: "method" guard $ m == m' p' <- o .:? "params" .!= Null - guard $ (toJSON p) == p' + guard $ toJSON p == p' return True reqDecode :: (Eq a, ToRequest a, ToJSON a, FromRequest a) => Request a -> Bool @@ -111,11 +111,11 @@ i <- o .:? "id" .!= Null guard $ i == Null j <- o .:? "jsonrpc" - guard $ fromMaybe True $ fmap (== ("2.0" :: Text)) j + guard $ maybe True (== ("2.0" :: Text)) j m' <- o .: "method" guard $ m == m' p' <- o .:? "params" .!= Null - guard $ (toJSON p) == p' + guard $ toJSON p == p' return True notifDecode :: (Eq a, ToNotif a, ToJSON a, FromNotif a) @@ -141,7 +141,7 @@ i' <- o .: "id" guard $ i == i' j <- o .:? "jsonrpc" - guard $ fromMaybe True $ fmap (== ("2.0" :: Text)) j + guard $ maybe True (== ("2.0" :: Text)) j s' <- o .: "result" guard $ s == s' e <- o .:? "error" .!= Null @@ -209,7 +209,7 @@ $= encodeConduit $= decodeConduit ver False qs' $$ CL.consume - assert $ null $ filter unexpected inmsgs + assert $ not (any unexpected inmsgs) assert $ all (uncurry match) (zip vs inmsgs) where unexpected :: IncomingMsg () q () () -> Bool @@ -237,7 +237,7 @@ $= encodeConduit $= decodeConduit ver False qs $$ CL.consume - assert $ null $ filter unexpected inmsgs + assert $ not (any unexpected inmsgs) assert $ all (uncurry match) (zip vs inmsgs) where unexpected :: IncomingMsg q () () r -> Bool @@ -277,7 +277,7 @@ $= encodeConduit $= decodeConduit ver False qs $$ CL.consume - assert $ null $ filter unexpected inmsgs + assert $ not (any unexpected inmsgs) assert $ all (uncurry match) (zip vs inmsgs) where unexpected :: IncomingMsg q () () r -> Bool @@ -396,8 +396,7 @@ realNet :: ([Request Value], Ver) -> Property realNet (rr, ver) = monadicIO $ do - rs <- run $ do - withAsync (tcpServer ver ss srvApp) $ \_ -> cli + rs <- run $ withAsync (tcpServer ver ss srvApp) $ const cli assert $ length rs == length rr assert $ map (getReqParams . fromJust . matchingReq) rs == map getReqParams rr