diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,3 +1,3 @@ json-rpc-server =============== -An implemation of the server side of JSON RPC 2.0. See . This library uses ByteString for input and output, leaving the choice of transport up to the user. See the demo folder for an example. +An implementation of the server side of JSON RPC 2.0. See . This library uses ByteString for input and output, leaving the choice of transport up to the user. See the demo folder for an example. diff --git a/demo/Demo.hs b/demo/Demo.hs --- a/demo/Demo.hs +++ b/demo/Demo.hs @@ -3,14 +3,15 @@ module Main (main) where import Network.JsonRpc.Server -import Happstack.Server.SimpleHTTP hiding (Method, body, result) +import Happstack.Server.SimpleHTTP( ServerPartT, simpleHTTP, nullConf + , askRq, rqBody, unBody, toResponse) import Data.List (intercalate) import Data.Maybe (fromMaybe) import Control.Monad (when) import Control.Monad.Trans (liftIO) import Control.Monad.Error (throwError) import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Concurrent.MVar +import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar) main :: IO () main = newMVar 0 >>= \count -> diff --git a/json-rpc-server.cabal b/json-rpc-server.cabal --- a/json-rpc-server.cabal +++ b/json-rpc-server.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: json-rpc-server -version: 0.1.0.0 +version: 0.1.1.0 license: MIT license-file: LICENSE category: Network, JSON @@ -12,7 +12,7 @@ extra-source-files: README.md cabal-version: >=1.8 tested-with: GHC == 7.4.1, GHC == 7.6.3 -description: An implemation of the server side of JSON RPC 2.0. +description: An implementation of the server side of JSON RPC 2.0. See . This library uses 'ByteString' for input and output, leaving the choice of transport up to the user. @@ -31,13 +31,12 @@ exposed-modules: Network.JsonRpc.Server other-modules: Network.JsonRpc.Types build-depends: base >=4.5 && <4.7, - aeson >=0.6 && <0.7, + aeson >=0.6 && <0.8, bytestring >=0.9 && <0.11, mtl >=2.1 && <2.2, - text >=0.11 && <0.12, + text >=0.11 && <1.2, vector >=0.8 && <0.11, - unordered-containers >=0.1 && <0.3, - attoparsec >=0.8 && <0.11 + unordered-containers >=0.1 && <0.3 hs-source-dirs: src ghc-options: -Wall @@ -45,9 +44,9 @@ main-is: Demo.hs hs-source-dirs: demo if flag (demo) - build-depends: base, + build-depends: base >=4.5 && <4.7, json-rpc-server, - mtl, + mtl >=2.1 && <2.2, happstack-server >=7.3 && <7.4 ghc-options: -Wall else @@ -58,16 +57,15 @@ main-is: TestSuite.hs other-modules: TestTypes type: exitcode-stdio-1.0 - build-depends: base, + build-depends: base >=4.5 && <4.7, json-rpc-server, HUnit >=1.2 && <1.3, test-framework >=0.7 && <0.9, test-framework-hunit >=0.3 && <0.4, - aeson, - bytestring, - mtl, - text, - vector, - unordered-containers, - attoparsec + aeson >=0.6 && <0.8, + bytestring >=0.9 && <0.11, + mtl >=2.1 && <2.2, + text >=0.11 && <1.2, + vector >=0.8 && <0.11, + unordered-containers >=0.1 && <0.3 ghc-options: -Wall -fno-warn-incomplete-patterns diff --git a/src/Network/JsonRpc/Server.hs b/src/Network/JsonRpc/Server.hs --- a/src/Network/JsonRpc/Server.hs +++ b/src/Network/JsonRpc/Server.hs @@ -35,7 +35,7 @@ import Data.Text (Text, append, pack) import Data.Maybe (catMaybes) import qualified Data.ByteString.Lazy as B -import Data.Aeson +import qualified Data.Aeson as A import qualified Data.Vector as V import qualified Data.HashMap.Strict as H import Control.Applicative ((<$>)) @@ -70,14 +70,15 @@ -- > module Main (main) where -- > -- > import Network.JsonRpc.Server --- > import Happstack.Server.SimpleHTTP hiding (Method, body, result) +-- > import Happstack.Server.SimpleHTTP( ServerPartT, simpleHTTP, nullConf +-- > , askRq, rqBody, unBody, toResponse) -- > import Data.List (intercalate) -- > import Data.Maybe (fromMaybe) -- > import Control.Monad (when) -- > import Control.Monad.Trans (liftIO) -- > import Control.Monad.Error (throwError) -- > import Control.Monad.Reader (ReaderT, ask, runReaderT) --- > import Control.Concurrent.MVar +-- > import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar) -- > -- > main :: IO () -- > main = newMVar 0 >>= \count -> @@ -118,8 +119,8 @@ -- | Creates a method from a name, function, and parameter descriptions. -- The parameter names must be unique. -toMethod :: (MethodParams f p m r, ToJSON r, Monad m) => Text -> f -> p -> Method m -toMethod name f params = let f' args = toJSON <$> apply f params args +toMethod :: (MethodParams f p m r, A.ToJSON r, Monad m) => Text -> f -> p -> Method m +toMethod name f params = let f' args = A.toJSON <$> apply f params args in Method name f' -- | Creates a set of methods to be called by name. The names must be unique. @@ -146,22 +147,22 @@ -- 'Nothing' in the case of a notification, -- all wrapped in the given monad. callWithBatchStrategy strategy fs input = either returnErr callMethod request - where request :: Either RpcError (Either Value [Value]) + where request :: Either RpcError (Either A.Value [A.Value]) request = runIdentity $ runErrorT $ parseVal =<< parseJson input - parseJson = maybe invalidJson return . decode + parseJson = maybe invalidJson return . A.decode parseVal val = case val of - obj@(Object _) -> return $ Left obj - Array vec | V.null vec -> throwError $ invalidRpcError "Empty batch request" + obj@(A.Object _) -> return $ Left obj + A.Array vec | V.null vec -> throwError $ invalidRpcError "Empty batch request" | otherwise -> return $ Right $ V.toList vec _ -> throwError $ invalidRpcError "Not a JSON object or array" callMethod rq = case rq of Left val -> encodeJust `liftM` singleCall fs val Right vals -> encodeJust `liftM` batchCall strategy fs vals - where encodeJust r = (encode . toJSON) <$> r - returnErr = return . Just . encode . toJSON . nullIdResponse + where encodeJust r = (A.encode . A.toJSON) <$> r + returnErr = return . Just . A.encode . A.toJSON . nullIdResponse invalidJson = throwError $ rpcError (-32700) "Invalid JSON" -singleCall :: Monad m => Methods m -> Value -> m (Maybe Response) +singleCall :: Monad m => Methods m -> A.Value -> m (Maybe Response) singleCall (Methods fs) val = case parsed of Left err -> return $ nullIdResponse err Right (Request name args i) -> @@ -173,10 +174,10 @@ nullIdResponse :: RpcError -> Maybe Response nullIdResponse err = toResponse (Just IdNull) (Left err :: Either RpcError ()) -parseValue :: (FromJSON a, Monad m) => Value -> RpcResult m a -parseValue val = case fromJSON val of - Error msg -> throwError $ invalidRpcError $ pack msg - Success x -> return x +parseValue :: (A.FromJSON a, Monad m) => A.Value -> RpcResult m a +parseValue val = case A.fromJSON val of + A.Error msg -> throwError $ invalidRpcError $ pack msg + A.Success x -> return x lookupMethod :: Monad m => Text -> H.HashMap Text (Method m) -> RpcResult m (Method m) lookupMethod name = maybe notFound return . H.lookup name @@ -187,12 +188,12 @@ batchCall :: Monad m => (forall a. [m a] -> m [a]) -> Methods m - -> [Value] + -> [A.Value] -> m (Maybe [Response]) batchCall strategy mths vals = (noNull . catMaybes) `liftM` results where results = strategy $ map (singleCall mths) vals noNull rs = if null rs then Nothing else Just rs -toResponse :: ToJSON a => Maybe Id -> Either RpcError a -> Maybe Response -toResponse (Just i) r = Just $ Response i $ toJSON <$> r +toResponse :: A.ToJSON a => Maybe Id -> Either RpcError a -> Maybe Response +toResponse (Just i) r = Just $ Response i $ A.toJSON <$> r toResponse Nothing _ = Nothing diff --git a/src/Network/JsonRpc/Types.hs b/src/Network/JsonRpc/Types.hs --- a/src/Network/JsonRpc/Types.hs +++ b/src/Network/JsonRpc/Types.hs @@ -22,11 +22,11 @@ import Data.String (fromString) import Data.Maybe (catMaybes) import Data.Text (Text, append, unpack) -import Data.Aeson +import qualified Data.Aeson as A +import Data.Aeson ((.=), (.:), (.:?), (.!=)) import Data.Aeson.Types (emptyObject) import qualified Data.Vector as V import qualified Data.HashMap.Strict as H -import Data.Attoparsec.Number (Number) import Control.Applicative ((<$>), (<*>), (<|>), (*>), empty) import Control.Monad (when) import Control.Monad.Error (Error, ErrorT, throwError, strMsg, noMsg) @@ -51,15 +51,15 @@ -- monad ('m'), and return type ('r'). 'p' has one 'Parameter' for -- every argument of 'f' and is terminated by @()@. The return type -- of 'f' is @RpcResult m r@. This class is treated as closed. -class (Monad m, Functor m, ToJSON r) => MethodParams f p m r | f -> p m r where +class (Monad m, Functor m, A.ToJSON r) => MethodParams f p m r | f -> p m r where apply :: f -> p -> Args -> RpcResult m r -instance (Monad m, Functor m, ToJSON r) => MethodParams (RpcResult m r) () m r where +instance (Monad m, Functor m, A.ToJSON r) => MethodParams (RpcResult m r) () m r where apply r _ args | Left _ <- args = r | Right ar <- args, V.null ar = r | otherwise = throwError $ rpcError (-32602) "Too many unnamed arguments" -instance (FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where +instance (A.FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where apply f (param :+: ps) args = arg >>= \a -> apply (f a) ps nextArgs where arg = either (parseArg name) return =<< (Left <$> lookupValue <|> Right <$> paramDefault param) @@ -67,22 +67,22 @@ nextArgs = tailOrEmpty <$> args name = paramName param -lookupArg :: Monad m => Text -> Object -> RpcResult m Value +lookupArg :: Monad m => Text -> A.Object -> RpcResult m A.Value lookupArg name hm = case H.lookup name hm of Nothing -> throwError $ missingArgError name Just v -> return v -headArg :: Monad m => Text -> V.Vector a -> RpcResult m a +headArg :: Monad m => Text -> A.Array -> RpcResult m A.Value headArg name vec | V.null vec = throwError $ missingArgError name | otherwise = return $ V.head vec -tailOrEmpty :: V.Vector a -> V.Vector a +tailOrEmpty :: A.Array -> A.Array tailOrEmpty vec = if V.null vec then V.empty else V.tail vec -parseArg :: (Monad m, FromJSON r) => Text -> Value -> RpcResult m r -parseArg name val = case fromJSON val of - Error msg -> throwError $ rpcErrorWithData (-32602) ("Wrong type for argument: " `append` name) msg - Success x -> return x +parseArg :: (Monad m, A.FromJSON r) => Text -> A.Value -> RpcResult m r +parseArg name val = case A.fromJSON val of + A.Error msg -> throwError $ rpcErrorWithData (-32602) ("Wrong type for argument: " `append` name) msg + A.Success x -> return x paramDefault :: Monad m => Parameter a -> RpcResult m a paramDefault (Optional _ d) = return d @@ -96,62 +96,63 @@ paramName (Required n) = n -- | Single method. -data Method m = Method Text (Args -> RpcResult m Value) +data Method m = Method Text (Args -> RpcResult m A.Value) -- | Multiple methods. newtype Methods m = Methods (H.HashMap Text (Method m)) -type Args = Either Object Array +type Args = Either A.Object A.Array data Request = Request Text Args (Maybe Id) -instance FromJSON Request where - parseJSON (Object x) = (checkVersion =<< x .:? versionKey .!= jsonRpcVersion) *> +instance A.FromJSON Request where + parseJSON (A.Object x) = (checkVersion =<< x .:? versionKey .!= jsonRpcVersion) *> (Request <$> - x .: methodKey <*> - (parseParams =<< x .:? paramsKey .!= emptyObject) <*> + x .: "method" <*> + (parseParams =<< x .:? "params" .!= emptyObject) <*> (Just <$> x .: idKey <|> return Nothing)) -- (.:?) parses Null value as Nothing - where parseParams (Object obj) = return $ Left obj - parseParams (Array ar) = return $ Right ar + where parseParams (A.Object obj) = return $ Left obj + parseParams (A.Array ar) = return $ Right ar parseParams _ = empty checkVersion ver = when (ver /= jsonRpcVersion) (fail $ "Wrong JSON RPC version: " ++ unpack ver) parseJSON _ = empty -data Response = Response Id (Either RpcError Value) +data Response = Response Id (Either RpcError A.Value) -instance ToJSON Response where - toJSON (Response i result) = object pairs +instance A.ToJSON Response where + toJSON (Response i result) = A.object pairs where pairs = [ versionKey .= jsonRpcVersion - , either (errorKey .=) (resultKey .=) result + , either ("error" .=) ("result" .=) result , idKey .= i] -data Id = IdString Text | IdNumber Number | IdNull +-- IdNumber cannot directly reference the type stored in A.Number, +-- since it changes between aeson-0.6 and 0.7. +data Id = IdString A.Value | IdNumber A.Value | IdNull -instance FromJSON Id where - parseJSON (String x) = return $ IdString x - parseJSON (Number x) = return $ IdNumber x - parseJSON Null = return IdNull +instance A.FromJSON Id where + parseJSON x@(A.String _) = return $ IdString x + parseJSON x@(A.Number _) = return $ IdNumber x + parseJSON A.Null = return IdNull parseJSON _ = empty -instance ToJSON Id where - toJSON i = case i of - IdString x -> toJSON x - IdNumber x -> toJSON x - IdNull -> Null +instance A.ToJSON Id where + toJSON (IdString x) = x + toJSON (IdNumber x) = x + toJSON IdNull = A.Null -- | Error to be returned to the client. -data RpcError = RpcError Int Text (Maybe Value) +data RpcError = RpcError Int Text (Maybe A.Value) deriving Show instance Error RpcError where noMsg = strMsg "unknown error" strMsg msg = RpcError (-32000) (fromString msg) Nothing -instance ToJSON RpcError where - toJSON (RpcError code msg data') = object pairs - where pairs = catMaybes [ Just $ codeKey .= code - , Just $ msgKey .= msg - , (dataKey .=) <$> data' ] +instance A.ToJSON RpcError where + toJSON (RpcError code msg data') = A.object pairs + where pairs = catMaybes [ Just $ "code" .= code + , Just $ "message" .= msg + , ("data" .=) <$> data' ] -- | Creates an 'RpcError' with the given error code and message. -- According to the specification, server error codes should be @@ -162,23 +163,10 @@ -- | Creates an 'RpcError' with the given code, message, and additional data. -- See 'rpcError' for the recommended error code ranges. -rpcErrorWithData :: ToJSON a => Int -> Text -> a -> RpcError -rpcErrorWithData code msg errorData = RpcError code msg $ Just $ toJSON errorData +rpcErrorWithData :: A.ToJSON a => Int -> Text -> a -> RpcError +rpcErrorWithData code msg errorData = RpcError code msg $ Just $ A.toJSON errorData jsonRpcVersion, versionKey, idKey :: Text jsonRpcVersion = "2.0" versionKey = "jsonrpc" idKey = "id" - -methodKey, paramsKey :: Text -methodKey = "method" -paramsKey = "params" - -resultKey, errorKey :: Text -resultKey = "result" -errorKey = "error" - -codeKey, msgKey, dataKey :: Text -codeKey = "code" -msgKey = "message" -dataKey = "data" diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -4,7 +4,7 @@ import Network.JsonRpc.Server import TestTypes -import Data.List ((\\), sort) +import Data.List ((\\)) import Data.Aeson import Data.Aeson.Types import Data.Text (Text) @@ -49,59 +49,59 @@ , testCase "parallelize tasks" testParallelizingTasks ] testEncodeError :: Assertion -testEncodeError = (fromByteString $ encode $ toJSON err) @?= Just testError +testEncodeError = fromByteString (encode $ toJSON err) @?= Just testError where err = rpcError (-1) "error" testError = TestRpcError (-1) "error" Nothing testEncodeErrorWithData :: Assertion -testEncodeErrorWithData = (fromByteString $ encode $ toJSON err) @?= Just testError +testEncodeErrorWithData = fromByteString (encode $ toJSON err) @?= Just testError where err = rpcErrorWithData 1 "my message" errorData testError = TestRpcError 1 "my message" $ Just $ toJSON errorData - errorData = (['\x03BB'], True, ()) + errorData = ('\x03BB', [True], ()) testInvalidJson :: Assertion -testInvalidJson = checkResponseWithSubtract "5" IdNull (-32700) +testInvalidJson = checkResponseWithSubtract "5" idNull (-32700) testInvalidJsonRpc :: Assertion -testInvalidJsonRpc = checkResponseWithSubtract (encode $ object ["id" .= (10 :: Int)]) IdNull (-32600) +testInvalidJsonRpc = checkResponseWithSubtract (encode $ object ["id" .= (10 :: Int)]) idNull (-32600) testEmptyBatchCall :: Assertion -testEmptyBatchCall = checkResponseWithSubtract (encode emptyArray) IdNull (-32600) +testEmptyBatchCall = checkResponseWithSubtract (encode emptyArray) idNull (-32600) testWrongVersion :: Assertion -testWrongVersion = checkResponseWithSubtract (encode requestWrongVersion) IdNull (-32600) +testWrongVersion = checkResponseWithSubtract (encode requestWrongVersion) idNull (-32600) where requestWrongVersion = Object $ H.insert versionKey (String "1") hm - Object hm = toJSON $ subtractRequestNamed [("a1", Number 4)] (IdNumber 10) + Object hm = toJSON $ subtractRequestNamed [("a1", Number 4)] (idNumber 10) testMethodNotFound :: Assertion testMethodNotFound = checkResponseWithSubtract (encode request) i (-32601) where request = TestRequest "ad" Nothing (Just i) - i = IdNumber 3 + i = idNumber 3 testWrongMethodNameCapitalization :: Assertion testWrongMethodNameCapitalization = checkResponseWithSubtract (encode request) i (-32601) where request = TestRequest "Add" Nothing (Just i) - i = IdNull + i = idNull testMissingRequiredNamedArg :: Assertion testMissingRequiredNamedArg = checkResponseWithSubtract (encode request) i (-32602) where request = subtractRequestNamed [("A1", Number 1), ("a2", Number 20)] i - i = IdNumber 2 + i = idNumber 2 testMissingRequiredUnnamedArg :: Assertion testMissingRequiredUnnamedArg = checkResponseWithSubtract (encode request) i (-32602) where request = TestRequest "subtract 2" (Just $ Right $ V.fromList [Number 0]) (Just i) - i = IdString "" + i = idString "" testWrongArgType :: Assertion testWrongArgType = checkResponseWithSubtract (encode request) i (-32602) where request = subtractRequestNamed [("a1", Number 1), ("a2", Bool True)] i - i = IdString "ABC" + i = idString "ABC" testDisallowExtraUnnamedArg :: Assertion testDisallowExtraUnnamedArg = checkResponseWithSubtract (encode request) i (-32602) where request = subtractRequestUnnamed (map Number [1, 2, 3]) i - i = IdString "i" + i = idString "i" testNoResponseToInvalidNotification :: Assertion testNoResponseToInvalidNotification = runIdentity response @?= Nothing @@ -114,8 +114,8 @@ response = call (toMethods [subtractMethod]) $ encode request request = [subtractRequestNamed (toArgs 10 8) i1, subtractRequestNamed (toArgs 24 20) i2] toArgs x y = [("a1", Number x), ("a2", Number y)] - i1 = IdString "1" - i2 = IdString "2" + i1 = idString "1" + i2 = idString "2" testBatchNotifications :: Assertion testBatchNotifications = runState response 0 @?= (Nothing, 10) @@ -127,32 +127,32 @@ where requestNoVersion = Object $ H.delete versionKey hm Object hm = toJSON $ subtractRequestNamed [("a1", Number 1)] i response = call (toMethods [subtractMethod]) $ encode requestNoVersion - i = IdNumber (-1) + i = idNumber (-1) testAllowExtraNamedArg :: Assertion testAllowExtraNamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number (-10))) where response = call (toMethods [subtractMethod]) $ encode request request = subtractRequestNamed args i args = [("a1", Number 10), ("a2", Number 20), ("a3", String "extra")] - i = IdString "ID" + i = idString "ID" testDefaultNamedArg :: Assertion testDefaultNamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 1000)) where response = call (toMethods [subtractMethod]) $ encode request request = subtractRequestNamed args i args = [("a", Number 500), ("a1", Number 1000)] - i = IdNumber 3 + i = idNumber 3 testDefaultUnnamedArg :: Assertion testDefaultUnnamedArg = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse i (Right $ Number 4)) where response = call (toMethods [subtractMethod]) $ encode request request = subtractRequestUnnamed [Number 4] i - i = IdNumber 0 + i = idNumber 0 testNullId :: Assertion -testNullId = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse IdNull (Right $ Number (-80))) +testNullId = (fromByteString =<< runIdentity response) @?= (Just $ TestResponse idNull (Right $ Number (-80))) where response = call (toMethods [subtractMethod]) $ encode request - request = subtractRequestNamed args IdNull + request = subtractRequestNamed args idNull args = [("a2", Number 70), ("a1", Number (-10))] testNoArgs :: Assertion @@ -167,14 +167,14 @@ testParallelizingTasks :: Assertion testParallelizingTasks = assert $ do a <- actual - let ids = map fromIdNumber a + let ids = map rspId a vals = map fromResult a - return $ (sort ids == [1, 2]) && - (sort vals == ["A", "B"]) + return $ equalContents ids (map idNumber [1, 2]) && + equalContents vals ["A", "B"] where actual = (fromJust . fromByteString . fromJust) <$> (flip (callWithBatchStrategy parallelize) input =<< methods) input = encode [ lockRequest 1, unlockRequest (String "A") , unlockRequest (String "B"), lockRequest 2] - lockRequest i = TestRequest "lock" Nothing (Just $ IdNumber i) + lockRequest i = TestRequest "lock" Nothing (Just $ idNumber i) unlockRequest str = TestRequest "unlock" (Just $ Right $ V.fromList [str]) Nothing methods = createMethods <$> newEmptyMVar createMethods lock = toMethods [lockMethod lock, unlockMethod lock] @@ -185,7 +185,6 @@ where f :: String -> RpcResult IO () f val = liftIO $ putMVar lock val fromResult r | Right (String str) <- rspResult r = str - fromIdNumber r | IdNumber i <- rspId r = i parallelize :: [IO a] -> IO [a] parallelize tasks = do @@ -205,7 +204,7 @@ ((fromByteString . fromJust) <$> call (toMethods [getTimeMethod]) (encode getTimeRequest)) where expected = Just $ TestResponse i (Right $ Number 100) getTimeRequest = TestRequest "get_time_seconds" requestArgs (Just i) - i = IdString "Id 1" + i = idString "Id 1" subtractRequestNamed :: [(Text, Value)] -> TestId -> TestRequest subtractRequestNamed args i = TestRequest "subtract 1" (Just $ Left $ H.fromList args) (Just i) diff --git a/tests/TestTypes.hs b/tests/TestTypes.hs --- a/tests/TestTypes.hs +++ b/tests/TestTypes.hs @@ -3,75 +3,78 @@ module TestTypes ( TestRequest (..) , TestResponse (..) , TestRpcError (..) - , TestId (..) - , jsonRpcVersion + , TestId + , idString + , idNumber + , idNull , versionKey) where -import Data.Aeson -import Data.Aeson.Types +import qualified Data.Aeson as A +import Data.Aeson ((.=), (.:), (.:?)) import Data.Maybe (catMaybes) -import Data.Text (Text) -import Data.Attoparsec.Number (Number) +import Data.String (IsString, fromString) +import Data.Text (Text, pack) import Data.HashMap.Strict (size) -import Control.Applicative +import Control.Applicative ((<$>), (<*>), (<|>), pure, empty) +import Control.Monad (when, guard) data TestRpcError = TestRpcError { errCode :: Int , errMsg :: Text - , errData :: Maybe Value} + , errData :: Maybe A.Value} deriving (Eq, Show) -instance FromJSON TestRpcError where - parseJSON (Object err) = (TestRpcError <$> - err .: "code" <*> - err .: "message" <*> - err .:? "data") >>= checkKeys - where checkKeys e = let checkSize s = failIf $ size err /= s - in pure e <* checkSize (case errData e of - Nothing -> 2 - Just _ -> 3) +instance A.FromJSON TestRpcError where + parseJSON (A.Object obj) = do + d <- obj .:? "data" + when (size obj /= maybe 2 (const 3) d) $ fail "Wrong number of keys" + TestRpcError <$> obj .: "code" <*> obj .: "message" <*> pure d parseJSON _ = empty -data TestRequest = TestRequest Text (Maybe (Either Object Array)) (Maybe TestId) +data TestRequest = TestRequest Text (Maybe (Either A.Object A.Array)) (Maybe TestId) -instance ToJSON TestRequest where - toJSON (TestRequest name params i) = object pairs - where pairs = catMaybes [Just $ "method" .= toJSON name, idPair, paramsPair] +instance A.ToJSON TestRequest where + toJSON (TestRequest name params i) = A.object pairs + where pairs = catMaybes [Just $ "method" .= name, idPair, paramsPair] idPair = ("id" .=) <$> i paramsPair = either toPair toPair <$> params - where toPair v = "params" .= toJSON v + where toPair v = "params" .= v data TestResponse = TestResponse { rspId :: TestId - , rspResult :: Either TestRpcError Value } + , rspResult :: Either TestRpcError A.Value } deriving (Eq, Show) -instance FromJSON TestResponse where - parseJSON (Object r) = failIf (size r /= 3) *> checkVersion *> - (TestResponse <$> - r .: "id" <*> - ((Left <$> r .: "error") <|> (Right <$> r .: "result"))) - where checkVersion = r .: versionKey >>= failIf . (/= jsonRpcVersion) +instance A.FromJSON TestResponse where + parseJSON (A.Object obj) = do + guard (size obj == 3) + guard . (pack "2.0" ==) =<< obj .: versionKey + TestResponse <$> obj .: "id" <*> + ((Left <$> obj .: "error") <|> (Right <$> obj .: "result")) parseJSON _ = empty -failIf :: Bool -> Parser () -failIf b = if b then empty else pure () - -data TestId = IdString Text | IdNumber Number | IdNull +-- IdNumber cannot directly reference the type stored in A.Number, +-- since it changes between aeson-0.6 and 0.7. +data TestId = IdString A.Value | IdNumber A.Value | IdNull deriving (Eq, Show) -instance FromJSON TestId where - parseJSON (String x) = return $ IdString x - parseJSON (Number x) = return $ IdNumber x - parseJSON Null = return IdNull +idString :: String -> TestId +idString = IdString . A.String . fromString + +idNumber :: Integer -> TestId +idNumber = IdNumber . A.Number . fromInteger + +idNull :: TestId +idNull = IdNull + +instance A.FromJSON TestId where + parseJSON x@(A.String _) = return $ IdString x + parseJSON x@(A.Number _) = return $ IdNumber x + parseJSON A.Null = return IdNull parseJSON _ = empty -instance ToJSON TestId where - toJSON i = case i of - IdString x -> toJSON x - IdNumber x -> toJSON x - IdNull -> Null +instance A.ToJSON TestId where + toJSON (IdString x) = x + toJSON (IdNumber x) = x + toJSON IdNull = A.Null versionKey :: Text versionKey = "jsonrpc" - -jsonRpcVersion :: Text -jsonRpcVersion = "2.0"