jsonrpc-conduit 0.2.7 → 0.3.0

raw patch · 8 files changed

+289/−283 lines, 8 filesdep +hspecdep +jsonrpc-conduitPVP ok

version bump matches the API change (PVP)

Dependencies added: hspec, jsonrpc-conduit

API changes (from Hackage documentation)

Files

• Data/Conduit/JsonRpc/Demo.hs +0/−35
• Data/Conduit/JsonRpc/Methods.hs +0/−66
• Data/Conduit/JsonRpc/Server.hs +0/−162
• jsonrpc-conduit.cabal +15/−20
• src/Data/Conduit/JsonRpc/Internal/Types.hs +79/−0
• src/Data/Conduit/JsonRpc/Methods.hs +66/−0
• src/Data/Conduit/JsonRpc/Server.hs +128/−0
• test/Spec.hs +1/−0

@@ -1,35 +0,0 @@--- |--- Copyright   : (c) 2012-2013 Gabriele Sales <gbrsales@gmail.com>------ An example JSON-RPC server implementing the "echo" and "sum" methods.--{-# LANGUAGE OverloadedStrings #-}--module Main-  ( main )-where--import           Data.Aeson-import           Data.ByteString              (ByteString)-import           Data.Conduit-import           Data.Conduit.Binary-import           Data.Conduit.JsonRpc.Methods-import           Data.Conduit.JsonRpc.Server-import           System.IO---main :: IO ()-main = do-  hSetBuffering stdin NoBuffering-  hSetBuffering stdout NoBuffering-  sourceHandle stdin $= server $$ sinkHandle stdout--server :: Conduit ByteString IO ByteString-server = serve (fromList [ method "echo" echo-                         , method "sum"  sum' ])--echo :: Value -> IO (Either MethodError Value)-echo = return . Right . id--sum' :: [Int] -> IO (Either MethodError Int)-sum' = return . Right . sum

@@ -1,66 +0,0 @@--- |--- Module      : Data.Conduit.JsonRpc.Methods--- Copyright   : (c) 2012-2013 Gabriele Sales <gbrsales@gmail.com>------ JSON-RPC methods.--{-# LANGUAGE GADTs      #-}-{-# LANGUAGE RankNTypes #-}--module Data.Conduit.JsonRpc.Methods-  ( Method(..)-  , MethodError(..)--  , NamedMethod-  , method--  , Methods-  , fromList-  , lookup )-where--import           Data.Aeson-import qualified Data.HashMap.Strict as M-import           Data.Text           (Text)-import           Prelude             hiding (lookup)---{-|-A wrapper over a monadic function that can either succeed or fail with a-'MethodError'.--Hides the input and output types.--}-data Method m where-  Method :: forall i m o. (FromJSON i, ToJSON o)-         => (i -> m (Either MethodError o)) -> Method m---- | Represents an error with an integer code and a textual message.-data MethodError = MethodError !Int !Text-  deriving (Eq, Show)----- | A 'Method' with a name.-newtype NamedMethod m = NamedMethod { unWrap :: (Text, Method m) }--{-|-Builds a 'NamedMethod' given its name and function.--Useful in conjuction with 'fromList'.--}-method :: (FromJSON i, ToJSON o)-       => Text-       -> (i -> m (Either MethodError o))-       -> NamedMethod m-method name f = NamedMethod (name, Method f)---- | Collection of 'NamedMethod's.-newtype Methods m = Methods (M.HashMap Text (Method m))---- | Builds a collection from a list of 'NamedMethod's.-fromList :: [NamedMethod m] -> Methods m-fromList = Methods . M.fromList . map unWrap---- | Looks up the method corresponding to the given name.-lookup :: Methods m -> Text -> Maybe (Method m)-lookup (Methods m) name = M.lookup name m

@@ -1,162 +0,0 @@--- |--- Module      : Data.Conduit.JsonRpc.Server--- Copyright   : (c) 2012-2013 Gabriele Sales <gbrsales@gmail.com>------ JSON-RPC 2.0 server 'Conduit'.--{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Conduit.JsonRpc.Server-  ( serve )-where--import           Control.Applicative-import           Control.Monad                (guard, (>=>))-import           Control.Monad.Trans          (lift)-import           Control.Monad.Trans.State-import           Data.Aeson                   hiding (Error)-import           Data.Aeson.Types             (emptyArray, parseMaybe)-import           Data.Attoparsec.ByteString-import           Data.ByteString              (ByteString)-import qualified Data.ByteString              as B-import qualified Data.ByteString.Lazy         as L-import           Data.Conduit-import           Data.Conduit.JsonRpc.Methods hiding (method)-import qualified Data.Conduit.List            as C-import           Data.Monoid-import           Data.Text                    (Text)-import           Prelude                      hiding (lookup)---data Request a = Request { method    :: Text-                         , params    :: a-                         , requestId :: Value }--instance FromJSON (Request Value) where-    parseJSON (Object v) = do-      version <- v .: "jsonrpc"-      guard (version == ("2.0" :: Text))-      Request <$> v .:  "method" <*>-                  (v .:? "params") .!= emptyArray <*>-                  v .:  "id"--    parseJSON _ = mempty---data Processed a = Correct !a-                 | InvalidRequest-                 | ParseError---data Response a = Result { result   :: a-                         , resultId :: Value }-                | Error  { code    :: Int-                         , message :: Text-                         , refId   :: Maybe Value }-  deriving (Show)--instance ToJSON (Response Value) where-    toJSON (Result x id) = object [ "jsonrpc" .= ("2.0" :: Text)-                                  , "result"  .= x-                                  , "id"      .= id ]-    toJSON (Error code msg id) =-        let err = object [ "code"    .= code-                         , "message" .= msg ]-        in object [ "jsonrpc" .= ("2.0" :: Text)-                  , "error"   .= err-                  , "id"      .= id ]--{- |-A 'Conduit' that consumes a stream of JSON-RPC requests, tries to process them-with the provided 'Methods' and writes back the results.--Current limitations:--  * does not support batch requests--  * it is not possible to set the @data@ attribute of error objects--}-serve :: (Applicative m, Monad m) => Methods m -> Conduit ByteString m ByteString-serve methods = parseRequests =$=-                C.concatMapM (\r -> encodeResponse <$> handleRequest methods r)---parseRequests :: (Monad m)-              => ConduitM ByteString (Processed (Request Value)) m ()-parseRequests = evalStateT loop Nothing-  where-    loop = lift await >>= maybe flush process--    process = runParser >=> handle--    flush = do-      p <- get-      case p of-        Nothing -> return ()-        Just k  -> handle (k B.empty)--    runParser chunk = do-      p <- getPartialParser-      return $ case p of-                 Nothing -> parse json' chunk-                 Just k  -> k chunk--    getPartialParser = get <* put Nothing--    handle (Fail {})     = lift (yield ParseError)-    handle (Partial k)   = put (Just k) >> loop-    handle (Done rest r) = do-      lift (yieldResponse r)-      if B.null rest-         then loop-         else process rest--    yieldResponse r = yield $ case parseMaybe parseJSON r of-                                Nothing -> InvalidRequest-                                Just r' -> Correct r'--handleRequest :: (Applicative m, Monad m)-              => Methods m-              -> Processed (Request Value)-              -> m (Response Value)-handleRequest _       InvalidRequest    = invalidRequest-handleRequest _       ParseError        = parseError-handleRequest methods (Correct request) =-  case lookup methods (method request) of-    Nothing -> methodNotFound (requestId request)-    Just m  -> runMethod m request--runMethod :: (Applicative m, Monad m)-          => Method m-          -> Request Value-          -> m (Response Value)-runMethod (Method f) request = do-  let reqId = requestId request-  case parseMaybe parseJSON (params request) of-    Nothing -> invalidParams reqId-    Just ps -> processResult reqId <$> f ps--processResult :: (ToJSON a) => Value -> Either MethodError a -> Response Value-processResult reqId (Left (MethodError code msg)) = Error code msg (Just reqId)-processResult reqId (Right res)                   = Result (toJSON res) reqId---invalidRequest :: (Monad m) => m (Response Value)-invalidRequest = mkError (-32600) "Invalid request" Nothing--methodNotFound :: (Monad m) => Value -> m (Response Value)-methodNotFound = mkError (-32601) "Method not found" . Just--invalidParams :: (Monad m) => Value -> m (Response Value)-invalidParams = mkError (-32602) "Invalid params" . Just--parseError :: (Monad m) => m (Response Value)-parseError = mkError (-32700) "Parse error" Nothing--mkError :: (Monad m) => Int -> Text -> Maybe Value -> m (Response Value)-mkError code msg id = return (Error code msg id)---encodeResponse :: Response Value -> [ByteString]-encodeResponse = L.toChunks . encode

@@ -1,5 +1,5 @@ name:                jsonrpc-conduit-version:             0.2.7+version:             0.3.0 synopsis:            JSON-RPC 2.0 server over a Conduit. description:   @jsonrpc-conduit@ implements the basic building block of a JSON-RPC 2.0 server.@@ -25,38 +25,33 @@   type:     git   location: https://github.com/gbrsales/jsonrpc-conduit.git -flag demo-  description: Build the demo executable.-  default:     False- library-  exposed-modules:     Data.Conduit.JsonRpc.Methods,+  hs-source-dirs:      src+  exposed-modules:     Data.Conduit.JsonRpc.Internal.Types,+                       Data.Conduit.JsonRpc.Methods,                        Data.Conduit.JsonRpc.Server   build-depends:       base >=4 && <5,                        aeson >=0.7 && <0.11,                        attoparsec >=0.11 && <0.14,-                       bytestring ==0.10.*,+                       bytestring >=0.10 && <0.11,                        conduit >=1.1 && <1.3,                        conduit-extra >=1.1 && <1.3,                        mtl >=2.1 && <2.3,                        text >=1.1 && <1.3,                        transformers >=0.3 && <0.5,                        unordered-containers ==0.2.*--executable jsonrpc-conduit-demo-  if !flag(demo)-    buildable: False+  ghc-options:         -Wall -fno-warn-name-shadowing -  main-is:             Data/Conduit/JsonRpc/Demo.hs-  other-modules:       Data.Conduit.JsonRpc.Methods,-                       Data.Conduit.JsonRpc.Server+test-suite spec+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs   build-depends:       base >=4 && <5,                        aeson >=0.7 && <0.11,-                       attoparsec >=0.11 && <0.14,-                       bytestring ==0.10.*,+                       bytestring >=0.10 && <0.11,                        conduit >=1.1 && <1.3,                        conduit-extra >=1.1 && <1.3,-                       mtl >=2.1 && <2.3,-                       text >=1.1 && <1.3,-                       transformers >=0.3 && <0.5,-                       unordered-containers ==0.2.*+                       hspec >=2.1 && <2.3,+                       jsonrpc-conduit,+                       text >=1.1 && <1.3+  ghc-options:         -Wall -fno-warn-name-shadowing

@@ -0,0 +1,79 @@+{- |+Module      :  Data.Conduit.JsonRpc.Internal.Types+Description :  Types used internally to encode requests and responses.+Copyright   :  (c) 2015 Gabriele Sales+-}++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Conduit.JsonRpc.Internal.Types+  ( Request(..)+  , Response(..) )+where++import           Control.Applicative+import           Control.Monad+import           Data.Aeson          hiding (Error)+import           Data.Aeson.Types    (emptyArray)+import           Data.Monoid         as M (mempty)+import           Data.Text           (Text)+++data Request a = Request { reqMethod :: Text+                         , reqParams :: a+                         , reqId     :: Value }++instance FromJSON (Request Value) where+  parseJSON (Object v) = do+    version <- v .: "jsonrpc"+    guard (version == ("2.0" :: Text))+    Request <$> v .:  "method" <*>+                (v .:? "params") .!= emptyArray <*>+                v .:  "id"++  parseJSON _ = M.mempty++instance ToJSON a => ToJSON (Request a) where+  toJSON (Request m ps id) =+    object [ "jsonrpc" .= ("2.0" :: Text)+           , "method"  .= m+           , "params"  .= toJSON ps+           , "id"      .= id ]+++data Response a = Result { result   :: a+                         , resultId :: Value }+                | Error  { errCode  :: Int+                         , errMsg   :: Text+                         , errRefId :: Maybe Value }+  deriving (Show)++instance FromJSON a => FromJSON (Response a) where+  parseJSON (Object v) = do+    version <- v .: "jsonrpc"+    guard (version == ("2.0" :: Text))+    fromResult <|> fromError++    where+      fromResult = Result <$> (v .: "result" >>= parseJSON)+                          <*> v .: "id"++      fromError = do+        err <- v .: "error"+        Error <$> err .: "code"+              <*> err .: "message"+              <*> v   .: "id"++  parseJSON _ = mempty++instance ToJSON (Response Value) where+  toJSON (Result x id) = object [ "jsonrpc" .= ("2.0" :: Text)+                                , "result"  .= x+                                , "id"      .= id ]+  toJSON (Error code msg id) =+    let err = object [ "code"    .= code+                     , "message" .= msg ]+    in object [ "jsonrpc" .= ("2.0" :: Text)+              , "error"   .= err+              , "id"      .= id ]

@@ -0,0 +1,66 @@+-- |+-- Module      : Data.Conduit.JsonRpc.Methods+-- Copyright   : (c) 2012-2013 Gabriele Sales <gbrsales@gmail.com>+--+-- JSON-RPC methods.++{-# LANGUAGE GADTs      #-}+{-# LANGUAGE RankNTypes #-}++module Data.Conduit.JsonRpc.Methods+  ( Method(..)+  , MethodError(..)++  , NamedMethod+  , method++  , Methods+  , fromList+  , lookup )+where++import           Data.Aeson+import qualified Data.HashMap.Strict as M+import           Data.Text           (Text)+import           Prelude             hiding (lookup)+++{-|+A wrapper over a monadic function that can either succeed or fail with a+'MethodError'.++Hides the input and output types.+-}+data Method m where+  Method :: forall i m o. (FromJSON i, ToJSON o)+         => (i -> m (Either MethodError o)) -> Method m++-- | Represents an error with an integer code and a textual message.+data MethodError = MethodError !Int !Text+  deriving (Eq, Show)+++-- | A 'Method' with a name.+newtype NamedMethod m = NamedMethod { unWrap :: (Text, Method m) }++{-|+Builds a 'NamedMethod' given its name and function.++Useful in conjuction with 'fromList'.+-}+method :: (FromJSON i, ToJSON o)+       => Text+       -> (i -> m (Either MethodError o))+       -> NamedMethod m+method name f = NamedMethod (name, Method f)++-- | Collection of 'NamedMethod's.+newtype Methods m = Methods (M.HashMap Text (Method m))++-- | Builds a collection from a list of 'NamedMethod's.+fromList :: [NamedMethod m] -> Methods m+fromList = Methods . M.fromList . map unWrap++-- | Looks up the method corresponding to the given name.+lookup :: Methods m -> Text -> Maybe (Method m)+lookup (Methods m) name = M.lookup name m

@@ -0,0 +1,128 @@+-- |+-- Module      : Data.Conduit.JsonRpc.Server+-- Copyright   : (c) 2012-2013,2015 Gabriele Sales <gbrsales@gmail.com>+--+-- JSON-RPC 2.0 server 'Conduit'.++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.Conduit.JsonRpc.Server+  ( serve )+where++import           Control.Applicative+import           Control.Monad                       ((>=>))+import           Control.Monad.Trans                 (lift)+import           Control.Monad.Trans.State+import           Data.Aeson                          hiding (Error)+import           Data.Aeson.Types                    (parseMaybe)+import           Data.Attoparsec.ByteString+import           Data.ByteString                     (ByteString)+import qualified Data.ByteString                     as B+import qualified Data.ByteString.Lazy                as L+import           Data.Conduit+import           Data.Conduit.JsonRpc.Internal.Types+import           Data.Conduit.JsonRpc.Methods        hiding (method)+import qualified Data.Conduit.List                   as C+import           Data.Text                           (Text)+import           Prelude                             hiding (lookup)+++data Processed a = Correct !a+                 | InvalidRequest+                 | ParseError++{- |+A 'Conduit' that consumes a stream of JSON-RPC requests, tries to process them+with the provided 'Methods' and writes back the results.++Current limitations:++  * does not support batch requests++  * it is not possible to set the @data@ attribute of error objects+-}+serve :: (Applicative m, Monad m) => Methods m -> Conduit ByteString m ByteString+serve methods = parseRequests =$=+                C.concatMapM (\r -> encodeResponse <$> handleRequest methods r)+++parseRequests :: (Monad m)+              => ConduitM ByteString (Processed (Request Value)) m ()+parseRequests = evalStateT loop Nothing+  where+    loop = lift await >>= maybe flush process++    process = runParser >=> handle++    flush = do+      p <- get+      case p of+        Nothing -> return ()+        Just k  -> handle (k B.empty)++    runParser chunk = do+      p <- getPartialParser+      return $ case p of+                 Nothing -> parse json' chunk+                 Just k  -> k chunk++    getPartialParser = get <* put Nothing++    handle Fail{}        = lift (yield ParseError)+    handle (Partial k)   = put (Just k) >> loop+    handle (Done rest r) = do+      lift (yieldResponse r)+      if B.null rest+         then loop+         else process rest++    yieldResponse r = yield $ case parseMaybe parseJSON r of+                                Nothing -> InvalidRequest+                                Just r' -> Correct r'++handleRequest :: (Applicative m, Monad m)+              => Methods m+              -> Processed (Request Value)+              -> m (Response Value)+handleRequest _       InvalidRequest    = invalidRequest+handleRequest _       ParseError        = parseError+handleRequest methods (Correct request) =+  case lookup methods (reqMethod request) of+    Nothing -> methodNotFound (reqId request)+    Just m  -> runMethod m request++runMethod :: (Applicative m, Monad m)+          => Method m+          -> Request Value+          -> m (Response Value)+runMethod (Method f) request = do+  let ri = reqId request+  case parseMaybe parseJSON (reqParams request) of+    Nothing -> invalidParams ri+    Just ps -> processResult ri <$> f ps++processResult :: (ToJSON a) => Value -> Either MethodError a -> Response Value+processResult reqId (Left (MethodError code msg)) = Error code msg (Just reqId)+processResult reqId (Right res)                   = Result (toJSON res) reqId+++invalidRequest :: (Monad m) => m (Response Value)+invalidRequest = mkError (-32600) "Invalid request" Nothing++methodNotFound :: (Monad m) => Value -> m (Response Value)+methodNotFound = mkError (-32601) "Method not found" . Just++invalidParams :: (Monad m) => Value -> m (Response Value)+invalidParams = mkError (-32602) "Invalid params" . Just++parseError :: (Monad m) => m (Response Value)+parseError = mkError (-32700) "Parse error" Nothing++mkError :: (Monad m) => Int -> Text -> Maybe Value -> m (Response Value)+mkError code msg id = return (Error code msg id)+++encodeResponse :: Response Value -> [ByteString]+encodeResponse = L.toChunks . encode

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}