json-rpc 0.3.0.2 → 0.4.0.0

raw patch · 5 files changed

+26/−119 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Network/JsonRpc.hs +0/−83
• Network/JsonRpc/Interface.hs +20/−30
• README.md +3/−2
• json-rpc.cabal +2/−2
• test/Network/JsonRpc/Tests.hs +1/−2

@@ -2,12 +2,6 @@ ( -- * Introduction   -- $introduction -  -- ** Server Example-  -- $server--  -- ** Client Example-  -- $client-   module Network.JsonRpc.Interface , module Network.JsonRpc.Data ) where@@ -26,80 +20,3 @@ -- 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.----- $server------ This JSON-RPC server returns the current time.------ >{-# LANGUAGE OverloadedStrings #-}--- >import Control.Applicative--- >import Data.Aeson.Types hiding (Error)--- >import Data.Conduit.Network--- >import Data.Time.Clock--- >import Data.Time.Format--- >import Network.JsonRpc--- >import System.Locale--- >--- >data TimeReq = TimeReq--- >data TimeRes = TimeRes { timeRes :: UTCTime }--- >--- >instance FromRequest TimeReq where--- >    parseParams "time" = Just $ const $ return TimeReq --- >    parseParams _ = Nothing--- >--- >instance ToJSON TimeRes where--- >    toJSON (TimeRes t) = toJSON $ formatTime defaultTimeLocale "%c" t--- >--- >respond :: Respond TimeReq IO TimeRes--- >respond TimeReq = Right . TimeRes <$> getCurrentTime--- >--- >main :: IO ()--- >main = jsonRpcTcpServer V2 (serverSettings 31337 "::1") respond dummySrv------ $client------ Corresponding TCP client to get time from server.------ >{-# LANGUAGE OverloadedStrings #-}--- >import Control.Concurrent--- >import Control.Concurrent.STM--- >import Control.Monad--- >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 System.Locale--- >--- >data TimeReq = TimeReq--- >data TimeRes = TimeRes { timeRes :: UTCTime }--- >--- >instance ToRequest TimeReq where--- >    requestMethod TimeReq = "time"--- >--- >instance ToJSON TimeReq where--- >    toJSON TimeReq = emptyArray--- >--- >instance FromResponse TimeRes where--- >    parseResult "time" = Just $ withText "time" $ \t -> case f t of--- >        Just t' -> return $ TimeRes t'--- >        Nothing -> mzero--- >      where--- >        f t = parseTime defaultTimeLocale "%c" (T.unpack t)--- >    parseResult _ = Nothing--- >--- >req :: JsonRpcT IO UTCTime--- >req = sendRequest TimeReq >>= liftIO . atomically >>= \ts -> case ts of--- >    Left e -> error $ fromError e--- >    Right (Just (TimeRes r)) -> return r--- >    _ -> error "Could not parse response"--- >--- >main :: IO ()--- >main = jsonRpcTcpClient V2 (clientSettings 31337 "::1") dummyRespond .--- >    replicateM_ 4 $ req >>= liftIO . print >> liftIO (threadDelay 1000000)

@@ -128,15 +128,14 @@                     writeTVar s (x `M.delete` m) >> putTMVar p (Left err)             return $ processIncoming r --- | Returns Right Nothing if could not parse response. Run output in STM--- monad. STM will block until response arrives.+-- | Returns Right Nothing if could not parse response. sendRequest :: (ToJSON q, ToRequest q, FromResponse r, MonadIO m)-            => q -> JsonRpcT m (STM (Either ErrorObj (Maybe r)))+            => q -> JsonRpcT m (Either ErrorObj (Maybe r)) sendRequest q = do-    o <- reader outCh     v <- reader rpcVer     l <- reader lastId     s <- reader sentReqs+    o <- reader outCh     p <- liftIO . atomically $ do         p <- newEmptyTMVar          i <- succ <$> readTVar l@@ -146,41 +145,32 @@         writeTBMChan o $ MsgRequest req          writeTVar l i         return p-    return $ takeTMVar p >>= \pE -> case pE of+    liftIO . atomically $ takeTMVar p >>= \pE -> case pE of         Left e -> return . Left $ getErrObj e-        Right y@(Response ver r _) -> -            case fromResponse (requestMethod q) y of-                Nothing -> do-                    let err = MsgError $ RpcError ver (errorInvalid r) IdNull-                    writeTBMChan o err-                    return $ Right Nothing-                Just x -> return . Right $ Just x+        Right y -> case fromResponse (requestMethod q) y of+            Nothing -> return $ Right Nothing+            Just x -> return . Right $ Just x --- | Send notification. Run output in STM monad. Will not block.-sendNotif :: (ToJSON no, ToNotif no, Monad m) => no -> JsonRpcT m (STM ())+-- | Send notification. Will not block.+sendNotif :: (ToJSON no, ToNotif no, MonadIO m) => no -> JsonRpcT m () sendNotif n = do     o <- reader outCh     v <- reader rpcVer     let notif = buildNotif v n-    return $ writeTBMChan o (MsgNotif notif)+    liftIO . atomically $ writeTBMChan o (MsgNotif notif) --- | Receive notifications from peer.+-- | 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.--- Run output in STM monad. Will not block.-receiveNotif :: (Monad m, FromNotif n)-             => JsonRpcT m (STM (Maybe (Either ErrorObj (Maybe n))))+receiveNotif :: (MonadIO m, FromNotif n)+             => JsonRpcT m (Maybe (Either ErrorObj (Maybe n))) receiveNotif = do     c <- reader notifCh-    o <- reader outCh-    return $ readTBMChan c >>= \nM -> case nM of+    liftIO . atomically $ readTBMChan c >>= \nM -> case nM of         Nothing -> return Nothing         Just (Left e) -> return . Just . Left $ getErrObj e-        Just (Right n@(Notif v _ p)) -> case fromNotif n of-            Nothing -> do-                let err = MsgError $ RpcError v (errorParse p) IdNull-                writeTBMChan o err-                return . Just $ Right Nothing+        Just (Right n) -> case fromNotif n of+            Nothing -> return . Just $ Right Nothing             Just x -> return . Just . Right $ Just x  -- | Create JSON-RPC session around ByteString conduits from transport@@ -243,11 +233,11 @@     runJsonRpcT ver r (cr =$ appSink cl) (appSource cl $= ln) f  -- | Dummy server for servers not expecting client to send notifications,--- that is most cases.+-- that is true in most cases. dummySrv :: MonadIO m => JsonRpcT m ()-dummySrv = forever $ do-    n <- receiveNotif-    liftIO (atomically n :: IO (Maybe (Either ErrorObj (Maybe ()))))+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.

@@ -13,7 +13,9 @@ peer-to-peer, as it can send and receive all types of JSON-RPC message independent of whether it originated the connection. +[Hackage documentation](http://hackage.haskell.org/package/json-rpc) + Server Example -------------- @@ -55,7 +57,6 @@ ``` haskell {-# LANGUAGE OverloadedStrings #-} import Control.Concurrent-import Control.Concurrent.STM import Control.Monad import Control.Monad.Trans import Data.Aeson@@ -85,7 +86,7 @@     parseResult _ = Nothing  req :: JsonRpcT IO UTCTime-req = sendRequest TimeReq >>= liftIO . atomically >>= \ts -> case ts of+req = sendRequest TimeReq >>= \ts -> case ts of     Left e -> error $ fromError e     Right (Just (TimeRes r)) -> return r     _ -> error "Could not parse response"

@@ -1,5 +1,5 @@ name:                   json-rpc-version:                0.3.0.2+version:                0.4.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.3.0.2+  tag:                  0.4.0.0  library   exposed-modules:      Network.JsonRpc

@@ -145,8 +145,7 @@   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 >=> liftIO . atomically+    cli snk src = runJsonRpcT ver r snk src . forM qs $ sendRequest     results = map fromJust . rights     correct (Right (Just _)) = True     correct _ = False