diff --git a/Data/Conduit/JsonRpc/Demo.hs b/Data/Conduit/JsonRpc/Demo.hs deleted file mode 100644 --- a/Data/Conduit/JsonRpc/Demo.hs +++ /dev/null @@ -1,35 +0,0 @@ --- | --- Copyright : (c) 2012-2013 Gabriele Sales --- --- 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 diff --git a/Data/Conduit/JsonRpc/Methods.hs b/Data/Conduit/JsonRpc/Methods.hs deleted file mode 100644 --- a/Data/Conduit/JsonRpc/Methods.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | --- Module : Data.Conduit.JsonRpc.Methods --- Copyright : (c) 2012-2013 Gabriele Sales --- --- 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 diff --git a/Data/Conduit/JsonRpc/Server.hs b/Data/Conduit/JsonRpc/Server.hs deleted file mode 100644 --- a/Data/Conduit/JsonRpc/Server.hs +++ /dev/null @@ -1,162 +0,0 @@ --- | --- Module : Data.Conduit.JsonRpc.Server --- Copyright : (c) 2012-2013 Gabriele Sales --- --- 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 diff --git a/jsonrpc-conduit.cabal b/jsonrpc-conduit.cabal --- a/jsonrpc-conduit.cabal +++ b/jsonrpc-conduit.cabal @@ -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 diff --git a/src/Data/Conduit/JsonRpc/Internal/Types.hs b/src/Data/Conduit/JsonRpc/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/JsonRpc/Internal/Types.hs @@ -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 ] diff --git a/src/Data/Conduit/JsonRpc/Methods.hs b/src/Data/Conduit/JsonRpc/Methods.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/JsonRpc/Methods.hs @@ -0,0 +1,66 @@ +-- | +-- Module : Data.Conduit.JsonRpc.Methods +-- Copyright : (c) 2012-2013 Gabriele Sales +-- +-- 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 diff --git a/src/Data/Conduit/JsonRpc/Server.hs b/src/Data/Conduit/JsonRpc/Server.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/JsonRpc/Server.hs @@ -0,0 +1,128 @@ +-- | +-- Module : Data.Conduit.JsonRpc.Server +-- Copyright : (c) 2012-2013,2015 Gabriele Sales +-- +-- 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}