json-rpc 0.5.0.0 → 0.6.0.0

raw patch · 6 files changed

+417/−431 lines, 6 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Network/JsonRpc/Arbitrary.hs +11/−26
• Network/JsonRpc/Data.hs +113/−154
• Network/JsonRpc/Interface.hs +190/−179
• README.md +45/−14
• json-rpc.cabal +2/−2
• test/Network/JsonRpc/Tests.hs +56/−56

@@ -1,10 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Arbitrary instances and data types for use in test suites.-module Network.JsonRpc.Arbitrary-( -- * Arbitrary Data-  ReqRes(..)-) where+module Network.JsonRpc.Arbitrary where  import Control.Applicative import Data.Aeson.Types@@ -15,18 +12,6 @@ import Test.QuickCheck.Arbitrary import Test.QuickCheck.Gen --- | A pair of a request and its corresponding response.--- Id and version should match.-data ReqRes = ReqRes !Request !Response-    deriving (Show, Eq)--instance Arbitrary ReqRes where-    arbitrary = do-        rq <- arbitrary-        rs <- arbitrary-        let rs' = rs { getResId = getReqId rq, getResVer = getReqVer rq }-        return $ ReqRes rq rs'- instance Arbitrary Text where     arbitrary = T.pack <$> arbitrary @@ -34,29 +19,29 @@     arbitrary = elements [V1, V2]  instance Arbitrary Request where-    arbitrary = Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary--instance Arbitrary Notif where-    arbitrary = Notif <$> arbitrary <*> arbitrary <*> arbitrary+    arbitrary = oneof+        [ Request <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary+        , Notif <$> arbitrary <*> arbitrary <*> arbitrary+        ]  instance Arbitrary Response where-    arbitrary = Response <$> arbitrary <*> arbitrary <*> arbitrary+    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 Err where-    arbitrary = Err <$> arbitrary <*> arbitrary <*> arbitrary- instance Arbitrary Message where     arbitrary = oneof         [ MsgRequest  <$> arbitrary-        , MsgNotif    <$> arbitrary         , MsgResponse <$> arbitrary-        , MsgError    <$> arbitrary         ]  instance Arbitrary Id where

@@ -19,21 +19,10 @@   -- ** Encoding , Respond , buildResponse--  -- * Notifications-, Notif(..)-  -- ** Parsing-, FromNotif(..)-, fromNotif-  -- ** Encoding-, ToNotif(..)-, buildNotif--  -- * Errors-, Err(..)+  -- ** Errors , ErrorObj(..) , fromError-  -- ** Error Messages+  -- ** Error messages , errorParse , errorInvalid , errorParams@@ -50,19 +39,20 @@ ) 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 Data.Text.Encoding import qualified Data.Text as T+import Data.Text.Encoding import GHC.Generics (Generic)  - -- -- Requests --@@ -71,10 +61,16 @@                        , getReqMethod   :: !Method                        , getReqParams   :: !Value                        , getReqId       :: !Id-                       } deriving (Eq, Show)+                       }+             | Notif   { getReqVer      :: !Ver+                       , getReqMethod   :: !Method+                       , getReqParams   :: !Value+                       }+             deriving (Eq, Show)  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@@ -83,13 +79,29 @@     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 -> Maybe q-fromRequest (Request _ m p _) = parseParams m >>= flip parseMaybe p+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@@ -99,46 +111,77 @@  instance FromJSON Request where     parseJSON = withObject "request" $ \o -> do-        (v, i, m, p) <- parseVerIdMethParams o-        guard $ i /= IdNull-        return $ Request v m p i+        (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 <- parseId o+    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 = Request ver (requestMethod q) (toJSON q)--+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-                         } deriving (Eq, Show)+data Response = Response      { getResVer :: !Ver+                              , getResult :: !Value+                              , getResId  :: !Id+                              }+              | ResponseError { getResVer :: !Ver+                              , getError  :: !ErrorObj+                              , getResId  :: !Id+                              }+              | OrphanError   { getResVer :: !Ver+                              , getError  :: !ErrorObj+                              }+              deriving (Eq, Show)+               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.@@ -147,96 +190,51 @@  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 . Just . const $ return ()+    parseResult = const Nothing  instance FromJSON Response where     parseJSON = withObject "response" $ \o -> do-        i <- o .: "id"-        guard $ i /= IdNull-        r <- o .: "result"-        guard $ r /= Null-        v <- parseVer o-        return $ Response v r i+        (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 <- parseId o+    r <- o .:? "result" .!= Null+    p <- if r == Null then Left <$> o .: "error" else return $ Right r+    return (v, i, p)+ buildResponse :: (Monad m, FromRequest q, ToJSON r)               => Respond q m r               -> Request-              -> m (Either Err Response)-buildResponse f req@(Request v _ p i) = case fromRequest req of-    Nothing -> return . Left $ Err v (errorInvalid p) i-    Just q -> do-        rE <- f q-        return $ either (\e -> Left $ Err v e i)-                        (\r -> Right $ Response v (toJSON r) i) rE+              -> 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 Respond q m r = q -> m (Either ErrorObj r) ------- Notifications-----data Notif = Notif  { getNotifVer    :: !Ver-                    , getNotifMethod :: !Method-                    , getNotifParams :: !Value-                    } deriving (Eq, Show)--instance NFData Notif where-    rnf (Notif v m n) = rnf v `seq` rnf m `seq` rnf n--instance ToJSON Notif where-    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 FromNotif n where-    -- | Parser for notification params Value.-    parseNotif :: Method -> Maybe (Value -> Parser n)--fromNotif :: FromNotif n => Notif -> Maybe n-fromNotif (Notif _ m n) = parseNotif m >>= flip parseMaybe n--instance FromNotif Value where-    parseNotif = const $ Just return--instance FromNotif () where-    parseNotif = const . Just . const $ return ()--instance FromJSON Notif where-    parseJSON = withObject "notification" $ \o -> do-        (v, i, m, p) <- parseVerIdMethParams o-        guard $ i == IdNull-        return $ Notif v m p--class ToNotif n where-    notifMethod :: n -> Method--instance ToNotif Value where-    notifMethod = const "json"--instance ToNotif () where-    notifMethod = const "json"--buildNotif :: (ToJSON n, ToNotif n)-           => Ver-           -> n-           -> Notif-buildNotif ver n = Notif ver (notifMethod n) (toJSON n)--------- Errors---- -- Error object from JSON-RPC 2.0. ErrorVal for backwards compatibility. data ErrorObj = ErrorObj  { getErrMsg  :: !String                           , getErrCode :: !Int@@ -266,33 +264,16 @@     toJSON (ErrorVal v) = v  fromError :: ErrorObj -> String-fromError (ErrorObj m _ _) = m-fromError (ErrorVal v) = T.unpack $ decodeUtf8 $ L.toStrict $ encode v--data Err = Err { getErrVer  :: !Ver-                         , getErrObj  :: !ErrorObj-                         , getErrId   :: !Id-                         } deriving (Eq, Show)--instance NFData Err where-    rnf (Err v o i) = rnf v `seq` rnf o `seq` rnf i--instance FromJSON Err where-    parseJSON = withObject "error" $ \o -> do-        v <- parseVer o-        e <- o .: "error"-        i <- o .:? "id" .!= IdNull-        return $ Err v e i+fromError (ErrorObj m c v) = show c ++ ": " ++ m ++ ": " ++ valueAsString v+fromError (ErrorVal (String t)) = T.unpack t+fromError (ErrorVal v) = valueAsString v -instance ToJSON Err where-    toJSON (Err V1 o i) =-        object ["id" .= i, "result" .= Null, "error" .= o]-    toJSON (Err V2 o i) =-        object ["id" .= i, "error" .= o, jr2]+valueAsString :: Value -> String+valueAsString = T.unpack . decodeUtf8 . L.toStrict . encode  -- | Parse error.-errorParse :: Value -> ErrorObj-errorParse = ErrorObj "Parse error" (-32700)+errorParse :: ByteString -> ErrorObj+errorParse = ErrorObj "Parse error" (-32700) . String . decodeUtf8  -- | Invalid request. errorInvalid :: Value -> ErrorObj@@ -318,27 +299,19 @@ data Message     = MsgRequest   { getMsgRequest  :: !Request  }     | MsgResponse  { getMsgResponse :: !Response }-    | MsgNotif     { getMsgNotif    :: !Notif    }-    | MsgError     { getMsgError    :: !Err }     deriving (Eq, Show)  instance NFData Message where     rnf (MsgRequest  q) = rnf q     rnf (MsgResponse r) = rnf r-    rnf (MsgNotif    n) = rnf n-    rnf (MsgError    e) = rnf e  instance ToJSON Message where     toJSON (MsgRequest  q) = toJSON q     toJSON (MsgResponse r) = toJSON r-    toJSON (MsgNotif    n) = toJSON n-    toJSON (MsgError    e) = toJSON e  instance FromJSON Message where     parseJSON v = (MsgRequest  <$> parseJSON v)               <|> (MsgResponse <$> parseJSON v)-              <|> (MsgNotif    <$> parseJSON v)-              <|> (MsgError    <$> parseJSON v)  -- -- Types@@ -348,7 +321,6 @@  data Id = IdInt { getIdInt :: !Int  }         | IdTxt { getIdTxt :: !Text }-        | IdNull     deriving (Eq, Show, Read, Generic)  instance Hashable Id@@ -356,7 +328,6 @@ instance NFData Id where     rnf (IdInt i) = rnf i     rnf (IdTxt t) = rnf t-    rnf _ = ()  instance Enum Id where     toEnum = IdInt@@ -366,18 +337,20 @@ instance FromJSON Id where     parseJSON s@(String _) = IdTxt <$> parseJSON s     parseJSON n@(Number _) = IdInt <$> parseJSON n-    parseJSON Null = return IdNull     parseJSON _ = mzero  instance ToJSON Id where     toJSON (IdTxt s) = toJSON s     toJSON (IdInt n) = toJSON n-    toJSON IdNull = Null +parseId :: Object -> Parser (Maybe Id)+parseId o = do+    d <- o .:? "id" .!= Null+    if d == Null then return Nothing else parseJSON d+ fromId :: Id -> String fromId (IdInt i) = show i fromId (IdTxt t) = T.unpack t-fromId IdNull = "null"  data Ver = V1 -- ^ JSON-RPC 1.0          | V2 -- ^ JSON-RPC 2.0@@ -386,12 +359,6 @@ instance NFData Ver where     rnf v = v `seq` () -------- Helpers---- jr2 :: Pair jr2 = "jsonrpc" .= ("2.0" :: Text) @@ -399,11 +366,3 @@ parseVer o = do     j <- o .:? "jsonrpc"     return $ if j == Just ("2.0" :: Text) then V2 else V1--parseVerIdMethParams :: Object -> Parser (Ver, Id, Method, Value)-parseVerIdMethParams o = do-    v <- parseVer o-    i <- o .:? "id" .!= IdNull-    m <- o .: "method"-    p <- o .:? "params" .!= Null-    return (v, i, m, p)

@@ -12,18 +12,21 @@ , encodeConduit    -- * Communicate with remote party+, receiveRequest+, sendResponse , sendRequest-, sendNotif-, receiveNotif-  -- ** Dummies-, dummyRespond-, dummySrv    -- * Transports   -- ** Client , jsonRpcTcpClient   -- ** Server , jsonRpcTcpServer++  -- * Internal data and functions+, SentRequests+, Session(..)+, initSession+, processIncoming ) where  import Control.Applicative@@ -50,11 +53,11 @@ import qualified Data.Text as T import Network.JsonRpc.Data -type SentRequests = HashMap Id (TMVar (Either Err Response))+type SentRequests = HashMap Id (TMVar (Maybe Response)) -data Session = Session { inCh     :: TBMChan (Either Err Message)+data Session = Session { inCh     :: TBMChan (Either Response Message)                        , outCh    :: TBMChan Message-                       , notifCh  :: TBMChan (Either Err Notif)+                       , reqCh    :: Maybe (TBMChan Request)                        , lastId   :: TVar Id                        , sentReqs :: TVar SentRequests                        , rpcVer   :: Ver@@ -64,234 +67,242 @@ -- as context is maintaned. type JsonRpcT = ReaderT Session -initSession :: Ver -> STM Session-initSession v = Session <$> newTBMChan 16-                        <*> newTBMChan 16-                        <*> newTBMChan 16-                        <*> newTVar (IdInt 0)-                        <*> newTVar M.empty-                        <*> return v+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  encodeConduit :: MonadLogger m => Conduit Message m ByteString encodeConduit = CL.mapM $ \m -> do     $(logDebug) $ T.pack $ unwords $ case m of-        MsgError e -> [ "Sending error id:", fromId (getErrId e) ]-        MsgRequest q -> [ "Sending request id:", fromId (getReqId q) ]-        MsgNotif _ -> [ "Sending notification" ]-        MsgResponse r -> [ "Sending response id:", fromId (getResId r) ]+        MsgRequest Request{getReqId = i} ->+            [ "encoding request id:", fromId i ]+        MsgRequest Notif{} ->+            [ "encoding notification" ]+        MsgResponse Response{getResId = i} ->+            [ "encoding response id:", fromId i ]+        MsgResponse ResponseError{getResId = i} ->+            [ "encoding error id:", fromId i ]+        MsgResponse OrphanError{} ->+            [ "encoding error without id" ]     return . L8.toStrict $ encode m  decodeConduit :: MonadLogger m-              => Ver -> Conduit ByteString m (Either Err Message)+              => Ver -> Conduit ByteString m (Either Response Message) decodeConduit ver = evalStateT loop Nothing where     loop = lift await >>= maybe flush process--    flush = get >>= \kM -> case kM of Nothing -> return ()-                                      Just k  -> handle (k B8.empty)-    process = runParser >=> handle-+    flush = get >>= maybe (return ()) (handle True . ($ B8.empty))+    process = runParser >=> handle False     runParser ck = maybe (parse json' ck) ($ ck) <$> get <* put Nothing -    handle (Fail {}) = do-        $(logWarn) "Error parsing incoming message"-        lift . yield . Left $ Err ver (errorParse Null) IdNull+    handle True (Fail "" _ _) =+        $(logDebug) "ignoring null string at end of incoming data"+    handle _ (Fail i _ _) = do+        $(logError) "error parsing incoming message"+        lift . yield . Left $ OrphanError ver (errorParse i)         loop-    handle (Partial k) = put (Just k) >> loop-    handle (Done rest v) = do+    handle _ (Partial k) = put (Just k) >> loop+    handle _ (Done rest v) = do         let msg = decod v-        when (isLeft msg) $ $(logWarn) "Received invalid message"+        when (isLeft msg) $ $(logError) "received invalid message"         lift $ yield msg         if B8.null rest then loop else process rest      decod v = case parseMaybe parseJSON v of         Just msg -> Right msg-        Nothing -> Left $ Err ver (errorInvalid v) IdNull+        Nothing -> Left $ OrphanError ver (errorInvalid v) -processIncoming :: (Functor m, MonadLoggerIO m, FromRequest q, ToJSON r)-                => Respond q m r -> JsonRpcT m ()-processIncoming r = do-    i <- reader inCh-    o <- reader outCh-    n <- reader notifCh-    s <- reader sentReqs-    v <- reader rpcVer-    join . liftIO . atomically $ readTBMChan i >>= \inc -> case inc of-        Nothing -> return $ do-            $(logDebug) "Closed incoming channel"-            return ()-        Just (Left e) -> do-            writeTBMChan o (MsgError e)-            return $ processIncoming r-        Just (Right (MsgNotif t)) -> do-            writeTBMChan n (Right t)-            return $ do-                $(logDebug) "Received notification"-                processIncoming r-        Just (Right (MsgRequest q)) -> return $ do-            $(logDebug) $ T.pack $ unwords-                [ "Received request id:", fromId (getReqId q) ]-            msg <- lift $ either MsgError MsgResponse <$> buildResponse r q-            liftIO . atomically $ writeTBMChan o msg-            processIncoming r-        Just (Right (MsgResponse res@(Response _ _ x))) -> do-            m <- readTVar s-            let pM = x `M.lookup` m-            case pM of-                Nothing ->-                    writeTBMChan o . MsgError $ Err v (errorId x) IdNull-                Just p ->-                    writeTVar s (x `M.delete` m) >> putTMVar p (Right res)-            return $ do-                case pM of-                    Nothing -> $(logWarn) $ T.pack $ unwords-                        [ "Got response with unkwnown id:", fromId x ]-                    _ -> $(logDebug) $ T.pack $ unwords-                        [ "Received response id:", fromId x ]-                processIncoming r-        Just (Right (MsgError err@(Err _ _ IdNull))) -> do-            writeTBMChan n $ Left err-            return $ do-                $(logWarn) "Got standalone error message"-                processIncoming r-        Just (Right (MsgError err@(Err _ _ x))) -> do-            m <- readTVar s-            let pM = x `M.lookup` m-            case pM of-                Nothing ->-                    writeTBMChan o . MsgError $ Err v (errorId x) IdNull-                Just p ->-                    writeTVar s (x `M.delete` m) >> putTMVar p (Left err)-            return $ do-                case pM of-                    Nothing -> $(logWarn) $ T.pack $ unwords-                        [ "Got error with unknown id:", fromId x ]-                    _ -> $(logWarn) $ T.pack $ unwords-                        [ "Received error id:", fromId x ]-                processIncoming r+processIncoming :: (Functor m, MonadLoggerIO m) => JsonRpcT m ()+processIncoming = do+    i  <- reader inCh+    o  <- reader outCh+    qM <- reader reqCh+    s  <- reader sentReqs+    join . liftIO . atomically $ readTBMChan i >>= \inc ->+        case inc of+            Nothing -> do+                m <- readTVar s+                mapM_ ((`putTMVar` Nothing) . snd) $ M.toList m+                return $ do+                    $(logDebug) "closed incoming channel"+                    unless (M.null m) $+                        $(logError) "some requests did not get responses"+                    return ()+            Just (Left e) -> do+                writeTBMChan o (MsgResponse e)+                return $ do+                    $(logError) "replied to sender with error"+                    processIncoming+            Just (Right (MsgRequest req)) ->+                case qM of+                    Just q -> do+                        writeTBMChan q req+                        return $ do+                            $(logDebug) "received request"+                            processIncoming+                    Nothing ->+                        case req of+                            Request v m _ d -> do+                                let e = ResponseError v (errorMethod m) d+                                writeTBMChan o (MsgResponse e)+                                return $ do+                                    $(logError) $ T.pack $ unwords+                                        [ "rejected incoming request id:"+                                        , fromId d+                                        ]+                                    processIncoming+                            Notif{} -> return $ do+                                $(logError) $ "rejected incoming notification"+                                processIncoming+            Just (Right (MsgResponse res)) -> do+                let hasId = case res of+                                Response{}      -> True+                                ResponseError{} -> True+                                OrphanError{}   -> False+                if hasId+                    then do+                        let x = getResId res+                        m <- readTVar s+                        let pM = x `M.lookup` m+                        case pM of+                            Nothing -> do+                                let v = getResVer res+                                    e = errorId x+                                    err = OrphanError v e+                                writeTBMChan o $ MsgResponse err+                                return $ do+                                    $(logError) $ T.pack $ unwords+                                        [ "got response with unknown id:"+                                        , fromId x+                                        ]+                                    processIncoming+                            Just p -> do+                                writeTVar s $ M.delete x m+                                putTMVar p $ Just res+                                return $ do+                                    $(logDebug) $ T.pack $ unwords+                                        [ "received response id:"+                                        , fromId x+                                        ]+                                    processIncoming+                    else return $ do+                        $(logError) $ T.pack $ unwords+                            [ "ignoring orhpan error:"+                            , fromError (getError res)+                            ]+                        processIncoming --- | Returns Right Nothing if could not parse response.+-- | Returns Nothing if did not receive response, could not parse it, or+-- request was 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 (Either ErrorObj (Maybe r))+            => q -> JsonRpcT m (Maybe (Either ErrorObj r)) sendRequest q = do     v <- reader rpcVer     l <- reader lastId     s <- reader sentReqs     o <- reader outCh-    p <- liftIO . atomically $ do-        p <- newEmptyTMVar -        i <- succ <$> readTVar l-        m <- readTVar s-        let req = buildRequest v q i-        writeTVar s $ M.insert i p m-        writeTBMChan o $ MsgRequest req -        writeTVar l i-        return p-    liftIO . atomically $ takeTMVar p >>= \pE -> case pE of-        Left e -> return . Left $ getErrObj e-        Right y -> case fromResponse (requestMethod q) y of-            Nothing -> return $ Right Nothing-            Just x -> return . Right $ Just x+    if requestIsNotif q+        then do+            $(logDebug) "sending notification"+            liftIO . atomically $ do+                let req = buildRequest v q undefined+                writeTBMChan o $ MsgRequest req+            $(logDebug) "notification sent"+            return Nothing+        else do+            $(logDebug) "sending request"+            p <- liftIO . atomically $ do+                p <- newEmptyTMVar +                i <- succ <$> readTVar l+                m <- readTVar s+                let req = buildRequest v q i+                writeTVar s $ M.insert i p m+                writeTBMChan o $ MsgRequest req +                writeTVar l i+                return p+            $(logDebug) "request sent, awaiting for response"+            liftIO . atomically $ takeTMVar p >>= \rM -> case rM of+                Nothing -> return Nothing+                Just y@Response{} ->+                    case fromResponse (requestMethod q) y of+                        Nothing -> return Nothing+                        Just x -> return . Just $ Right x+                Just e@ResponseError{} ->+                    return . Just $ Left $ getError e+                _ -> undefined --- | Send notification. Will not block.-sendNotif :: (ToJSON no, ToNotif no, MonadLoggerIO m) => no -> JsonRpcT m ()-sendNotif n = do-    o <- reader outCh-    v <- reader rpcVer-    let notif = buildNotif v n-    liftIO . atomically $ writeTBMChan o (MsgNotif notif)+-- | Receive requests from remote endpoint. Returns Nothing if incoming+-- channel is closed or has never been opened.+receiveRequest :: MonadLoggerIO m => JsonRpcT m (Maybe Request)+receiveRequest = 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 --- | Receive notifications from peer. Will not block.--- Returns Nothing if incoming channel is closed and empty.--- Result is Right Nothing if it failed to parse notification.-receiveNotif :: (MonadLoggerIO m, FromNotif n)-             => JsonRpcT m (Maybe (Either ErrorObj (Maybe n)))-receiveNotif = do-    c <- reader notifCh-    liftIO . atomically $ readTBMChan c >>= \nM -> case nM of-        Nothing -> return Nothing-        Just (Left e) -> return . Just . Left $ getErrObj e-        Just (Right n) -> case fromNotif n of-            Nothing -> return . Just $ Right Nothing-            Just x -> return . Just . Right $ Just x+sendResponse :: MonadLoggerIO m => Response -> JsonRpcT m ()+sendResponse r = do+    o <- reader outCh+    liftIO . atomically . writeTBMChan o $ MsgResponse r  -- | Create JSON-RPC session around conduits from transport -- layer. When context exits session disappears.-runJsonRpcT :: ( MonadLoggerIO m, MonadBaseControl IO m-               , FromRequest q, ToJSON r-               )-            => Ver                    -- ^ JSON-RPC version-            -> Respond q m r          -- ^ Respond to incoming requests-            -> Sink Message m ()      -- ^ Sink to send messages-            -> Source m (Either Err Message)-            -- ^ Source of incoming messages-            -> JsonRpcT m a           -- ^ JSON-RPC action-            -> m a                    -- ^ Output of action-runJsonRpcT ver r snk src f = do-    qs <- liftIO . atomically $ initSession ver+runJsonRpcT :: (MonadLoggerIO m, MonadBaseControl IO m)+            => Ver               -- ^ JSON-RPC version+            -> Bool              -- ^ Ignore incoming requests or notifications+            -> Sink Message m () -- ^ Sink to send messages+            -> Source m (Either Response Message)+            -- ^ Incoming messages or error responses to be returned to sender+            -> 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 $$ inSnk) $ const $         withAsync (outSrc $$ snk) $ const $-            withAsync (runReaderT (processIncoming r) qs) $ const $+            withAsync (runReaderT processIncoming qs) $ const $                 runReaderT f qs   cr :: Monad m => Conduit ByteString m ByteString cr = CL.map (`B8.snoc` '\n') -ln :: Monad m => Conduit ByteString m ByteString-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  -> unless (B8.null l) $ 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----- | Dummy action for servers not expecting clients to send notifications,--- which is true in most cases.-dummySrv :: MonadLoggerIO m => JsonRpcT m ()-dummySrv = receiveNotif >>= \nM -> case nM of-        Just n -> (n :: Either ErrorObj (Maybe ())) `seq` dummySrv-        Nothing -> return ()---- | Respond function for systems that do not reply to requests, as usual--- in clients.-dummyRespond :: MonadLoggerIO m => Respond () m ()-dummyRespond = const . return $ Right () - -- -- Transports --  -- | TCP client transport for JSON-RPC. jsonRpcTcpClient-    :: ( MonadLoggerIO m, MonadBaseControl IO m-       , FromRequest q, ToJSON r-       )+    :: (MonadLoggerIO m, MonadBaseControl IO m)     => Ver            -- ^ JSON-RPC version+    -> Bool           -- ^ Ignore incoming requests or notifications     -> ClientSettings -- ^ Connection settings-    -> Respond q m r  -- ^ Respond to incoming requests     -> JsonRpcT m a   -- ^ JSON-RPC action     -> m a            -- ^ Output of action-jsonRpcTcpClient ver cs r f = runGeneralTCPClient cs $ \ad ->-    runJsonRpcT ver r+jsonRpcTcpClient ver ignore cs f = runGeneralTCPClient cs $ \ad ->+    runJsonRpcT ver ignore         (encodeConduit =$ cr =$ appSink ad)-        (appSource ad $= ln $= decodeConduit ver) f+        (appSource ad $= decodeConduit ver) f  -- | TCP server transport for JSON-RPC. jsonRpcTcpServer-    :: ( MonadLoggerIO m, MonadBaseControl IO m-       , FromRequest q, ToJSON r)+    :: (MonadLoggerIO m, MonadBaseControl IO m)     => Ver             -- ^ JSON-RPC version+    -> Bool            -- ^ Ignore incoming requests or notifications     -> ServerSettings  -- ^ Connection settings-    -> Respond q m r   -- ^ Respond to incoming requests     -> JsonRpcT m ()   -- ^ Action to perform on connecting client thread     -> m a-jsonRpcTcpServer ver ss r f = runGeneralTCPServer ss $ \cl ->-    runJsonRpcT ver r+jsonRpcTcpServer ver ignore ss f = runGeneralTCPServer ss $ \cl ->+    runJsonRpcT ver ignore         (encodeConduit =$ cr =$ appSink cl)-        (appSource cl $= ln $= decodeConduit ver) f+        (appSource cl $= decodeConduit ver) f

@@ -23,7 +23,7 @@  ``` haskell {-# LANGUAGE OverloadedStrings #-}-import Control.Applicative+{-# LANGUAGE TemplateHaskell #-} import Control.Monad.Trans import Control.Monad.Logger import Data.Aeson.Types hiding (Error)@@ -38,17 +38,39 @@  instance FromRequest TimeReq where     parseParams "time" = Just $ const $ return TimeReq -    parseParams _ = Nothing+    parseParams _      = Nothing  instance ToJSON TimeRes where     toJSON (TimeRes t) = toJSON $ formatTime defaultTimeLocale "%c" t -respond :: (Functor m, MonadLoggerIO m) => Respond TimeReq m TimeRes-respond TimeReq = Right . TimeRes <$> liftIO getCurrentTime+respond :: MonadLoggerIO m => Respond TimeReq m TimeRes+respond TimeReq = do+    t <- liftIO getCurrentTime+    return . Right $ TimeRes t  main :: IO ()-main = runStderrLoggingT $-    jsonRpcTcpServer V2 (serverSettings 31337 "::1") respond dummySrv+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 <- receiveRequest+    case qM of+        Nothing -> do+            $(logDebug) "closed request channel, exting"+            return ()+        Just q -> do+            $(logDebug) "got request"+            rM <- buildResponse respond q+            case rM of+                Nothing -> do+                    $(logDebug) "no response for this request"+                    srv+                Just r -> do+                    $(logDebug) "sending response"+                    sendResponse r >> srv ```  Client Example@@ -57,6 +79,7 @@ Corresponding TCP client to get time from server.  ``` haskell+{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} import Control.Concurrent import Control.Monad@@ -72,10 +95,11 @@ import System.Locale  data TimeReq = TimeReq-data TimeRes = TimeRes { timeRes :: UTCTime }+data TimeRes = TimeRes { timeRes :: UTCTime } deriving Show  instance ToRequest TimeReq where     requestMethod TimeReq = "time"+    requestIsNotif = const False  instance ToJSON TimeReq where     toJSON TimeReq = emptyArray@@ -88,14 +112,21 @@         f t = parseTime defaultTimeLocale "%c" (T.unpack t)     parseResult _ = Nothing -req :: MonadLoggerIO m => JsonRpcT m UTCTime-req = sendRequest TimeReq >>= \ts -> case ts of-    Left e -> error $ fromError e-    Right (Just (TimeRes r)) -> return r-    _ -> error "Could not parse response"+req :: MonadLoggerIO m => JsonRpcT m (Either String UTCTime)+req = do+    $(logDebug) "sending time request"+    ts <- sendRequest TimeReq+    $(logDebug) "received response"+    case ts of+        Nothing -> return $ Left "could not parse response"+        Just (Left e) -> return . Left $ fromError e+        Just (Right (TimeRes r)) -> return $ Right r  main :: IO () main = runStderrLoggingT $-    jsonRpcTcpClient V2 (clientSettings 31337 "::1") dummyRespond .-        replicateM_ 4 $ req >>= liftIO . print >> liftIO (threadDelay 1000000)+    jsonRpcTcpClient V2 True (clientSettings 31337 "::1") $ do+        $(logDebug) "sending four time requests one second apart"+        replicateM_ 4 $ do+            req >>= liftIO . print+            liftIO (threadDelay 1000000) ```

@@ -1,5 +1,5 @@ name:                   json-rpc-version:                0.5.0.0+version:                0.6.0.0 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@@ -24,7 +24,7 @@ source-repository this   type:                 git   location:             https://github.com/xenog/json-rpc.git-  tag:                  0.5.0.0+  tag:                  0.6.0.0  library   exposed-modules:      Network.JsonRpc,

@@ -15,7 +15,6 @@ import Control.Monad.Trans import Data.Aeson import Data.Aeson.Types-import Data.Either import Data.Maybe import Network.JsonRpc import Network.JsonRpc.Arbitrary()@@ -32,38 +31,27 @@         , testProperty "Encode/decode"             (testEncodeDecode :: Request -> Bool)         ]-    , testGroup "JSON-RPC Notifications"-        [ testProperty "Check fields"-            (notifFields :: Notif -> Bool)-        , testProperty "Encode/decode"-            (testEncodeDecode :: Notif -> Bool)-        ]     , testGroup "JSON-RPC Responses"         [ testProperty "Check fields"             (resFields :: Response -> Bool)         , testProperty "Encode/decode"             (testEncodeDecode :: Response -> Bool)         ]-    , testGroup "JSON-RPC Errors"-        [ testProperty "Check fields"-            (errFields :: Err -> Bool)-        , testProperty "Encode/decode"-            (testEncodeDecode :: Err -> Bool)-        ]     , testGroup "Network"         [ testProperty "Test server" serverTest         , testProperty "Test client" clientTest         ]     ] -checkVerId :: Ver -> Id -> Object -> Parser Bool+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" .!= IdNull >>= guard . (==i)+    o .:? "id" >>= guard . (==i)     return True -checkFieldsReqNotif :: Ver -> Method -> Value -> Id -> Object -> Parser Bool+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)@@ -71,22 +59,22 @@     return True  checkFieldsReq :: Request -> Object -> Parser Bool-checkFieldsReq (Request ver m v i) = checkFieldsReqNotif ver m v i--checkFieldsNotif :: Notif -> Object -> Parser Bool-checkFieldsNotif (Notif ver m v) = checkFieldsReqNotif ver m v IdNull+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 i o >>= guard+    checkVerId ver (Just i) o >>= guard     o .: "result" >>= guard . (==v)     return True--checkFieldsErr :: Err -> Object -> Parser Bool-checkFieldsErr (Err ver e i) o = do-    checkVerId ver i o >>= guard+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@@ -98,63 +86,75 @@ reqFields :: Request -> Bool reqFields rq = testFields (checkFieldsReq rq) rq -notifFields :: Notif -> Bool-notifFields nt = testFields (checkFieldsNotif nt) nt- resFields :: Response -> Bool resFields rs = testFields (checkFieldsRes rs) rs -errFields :: Err -> Bool-errFields er = testFields (checkFieldsErr er) er- serverTest :: ([Request], Ver) -> Property serverTest (reqs, ver) = monadicIO $ do     rt <- run $ runNoLoggingT $ do-        (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16-                                                <*> newTBMChan 16+        (bso, bsi) <- liftIO . atomically $+            (,) <$> newTBMChan 16 <*> newTBMChan 16         let snk = sinkTBMChan bso False             src = sourceTBMChan bsi-        withAsync (srv snk src) $ const $-            withAsync (sender bsi) $ const $-                receiver bso []-    assert $ length rt == length reqs+        withAsync (server snk src) $ const $ withAsync (sender bsi) $ const $+            receiver bso []+    assert $ length rt == length nonotif     assert $ null rt || all isJust rt     assert $ params == reverse (results rt)   where-    r q = return $ Right (q :: Value)-    srv snk src = runJsonRpcT ver r-        (encodeConduit =$ snk) (src =$ decodeConduit ver) dummySrv+    respond q = return $ Right (q :: Value)+    server snk src = runJsonRpcT ver False+        (encodeConduit =$ snk) (src =$ decodeConduit ver) (srv respond)     sender bsi = forM_ reqs $ liftIO . atomically .         writeTBMChan bsi . L.toStrict . encode . MsgRequest-    receiver bso xs = if length xs == length reqs-        then return xs-        else liftIO (atomically $ readTBMChan bso) >>= \b -> case b of-            Just x -> do-                let res = decodeStrict' x :: Maybe Response-                receiver bso (res:xs)-            Nothing -> undefined-    params = map getReqParams reqs+    receiver bso xs =+        if length xs == length nonotif+            then return xs+            else liftIO (atomically $ readTBMChan bso) >>= \b -> case b of+                Just x -> do+                    let res = decodeStrict' x :: Maybe Response+                    receiver bso (res:xs)+                Nothing -> undefined+    params = map getReqParams nonotif     results = map $ getResult . fromJust+    nonotif = flip filter reqs $ \q -> case q of Request{} -> True+                                                 Notif{} -> False  clientTest :: ([Value], Ver) -> Property clientTest (qs, ver) = monadicIO $ do     rt <- run $ runNoLoggingT $ do-        (bso, bsi) <- liftIO . atomically $ (,) <$> newTBMChan 16-                                                <*> newTBMChan 16+        (bso, bsi) <- liftIO . atomically $+            (,) <$> newTBMChan 16 <*> newTBMChan 16         let snk = sinkTBMChan bso False             src = sourceTBMChan bsi             csnk = sinkTBMChan bsi False             csrc = sourceTBMChan bso-        withAsync (srv snk src) $ const $ cli+        withAsync (server snk src) $ const $ cli             (CL.map Right =$ csnk)             (csrc $= CL.map Right)     assert $ length rt == length qs     assert $ null rt || all correct rt     assert $ qs == results rt   where-    r q = return $ Right (q :: Value)-    srv snk src = runJsonRpcT ver r snk src dummySrv-    cli snk src = runJsonRpcT ver r snk src . forM qs $ sendRequest-    results = map fromJust . rights-    correct (Right (Just _)) = True+    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++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++fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = undefined