diff --git a/json-rpc-generic.cabal b/json-rpc-generic.cabal --- a/json-rpc-generic.cabal +++ b/json-rpc-generic.cabal @@ -1,5 +1,5 @@ name: json-rpc-generic -version: 0.0.1.0 +version: 0.1.0.0 synopsis: Generic encoder and decode for JSON-RPC description: This package contains generic encoder and decode for JSON-RPC homepage: http://github.com/khibino/haskell-json-rpc-generic @@ -41,8 +41,11 @@ build-depends: base >=4.6 && <5 , transformers + , containers + , unordered-containers , bytestring >=0.10 , text + , dlist , scientific , vector >=0.10 , aeson >=0.7 diff --git a/src/Data/JsonRpc/Generic.hs b/src/Data/JsonRpc/Generic.hs --- a/src/Data/JsonRpc/Generic.hs +++ b/src/Data/JsonRpc/Generic.hs @@ -1,16 +1,29 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} module Data.JsonRpc.Generic ( GFromArrayJSON, genericParseJSONRPC, + GFieldSetJSON, genericFieldSetParseJSON, + JsonRpcOptions (..), defaultJsonRpcOptions, + GToArrayJSON, genericToArrayJSON, ) where import GHC.Generics -import Control.Applicative ((<$>), (<*>), (<*), empty) +import Control.Applicative ((<$>), pure, (<*>), (<*), empty, (<|>)) +import Control.Monad (guard) import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.State (StateT, evalStateT, get, put) +import Control.Monad.Trans.Writer (Writer, runWriter, tell) +import Control.Monad.Trans.State (StateT, runStateT, get, put) +import Data.DList (DList) +import qualified Data.DList as DList +import Data.Set ((\\)) +import qualified Data.Set as Set +import qualified Data.HashMap.Strict as HashMap +import Data.Text (Text) +import qualified Data.Text as T import Data.Aeson.Types (FromJSON (..), ToJSON (..), GFromJSON, genericParseJSON, Parser, Options, Value (..)) import Data.Vector (Vector) @@ -37,13 +50,87 @@ [] -> lift $ parseJSON Null -genericParseJSONRPC :: (Generic a, GFromJSON (Rep a), GFromArrayJSON (Rep a)) - => Options -> Value -> Parser a -genericParseJSONRPC opt = d where - d (Array vs) = (to <$>) . evalStateT gFromArrayJSON $ Vector.toList vs - -- check state to check too many arguments - d v@(Object _) = genericParseJSON opt v +type FieldName = Text +type FieldsW = Writer (DList FieldName) + +class GFieldSetJSON f where + gFieldSet :: FieldsW (f a) + +instance GFieldSetJSON U1 where + gFieldSet = return U1 + +instance (GFieldSetJSON a, GFieldSetJSON b) => GFieldSetJSON (a :*: b) where + gFieldSet = do + x <- gFieldSet + y <- gFieldSet + return (x :*: y) + +instance GFieldSetJSON a => GFieldSetJSON (D1 c a) where + gFieldSet = do + x <- gFieldSet + return $ M1 x + +instance GFieldSetJSON a => GFieldSetJSON (C1 c a) where + gFieldSet = do + x <- gFieldSet + return $ M1 x + +instance (GFieldSetJSON a, Selector s) => GFieldSetJSON (S1 s a) where + gFieldSet = do + x <- gFieldSet + saveQueriedField $ M1 x + +saveQueriedField :: (GFieldSetJSON a, Selector s) + => S1 s a p + -> FieldsW (S1 s a p) +saveQueriedField m1 = do + tell (pure . T.pack $ selName m1) + return m1 + +instance GFieldSetJSON (K1 i a) where + gFieldSet = return $ K1 undefined + +genericFieldSetParseJSON :: (Generic a, GFromJSON (Rep a), GFieldSetJSON (Rep a)) + => JsonRpcOptions + -> Options + -> Value + -> Parser a +genericFieldSetParseJSON = d where + d rpcOpts opts v@(Object m) = do + let (px, fs) = runWriter gFieldSet + inv = Set.fromList (HashMap.keys m) \\ + Set.fromList (DList.toList fs) + guard (allowNonExistField rpcOpts || Set.null inv) + <|> fail ("object has illegal field: " ++ show (Set.toList inv)) + j <- genericParseJSON opts v + let _ = from j `asTypeOf` px + return j + d _ opts v = + genericParseJSON opts v + + +genericParseJSONRPC :: (Generic a, GFromJSON (Rep a), GFromArrayJSON (Rep a), GFieldSetJSON (Rep a)) + => JsonRpcOptions -> Options -> Value -> Parser a +genericParseJSONRPC rpcOpt opt = d where + d (Array vs) = do (a, s) <- runStateT gFromArrayJSON $ Vector.toList vs + guard (allowSpilledArguemnts rpcOpt || null s) + <|> fail ("Too many arguments! Spilled arguments: " ++ show s) + return $ to a + d v@(Object _) = genericFieldSetParseJSON rpcOpt opt v d _ = empty + +data JsonRpcOptions = + JsonRpcOptions + { allowSpilledArguemnts :: Bool + , allowNonExistField :: Bool + } + +defaultJsonRpcOptions :: JsonRpcOptions +defaultJsonRpcOptions = + JsonRpcOptions + { allowSpilledArguemnts = True + , allowNonExistField = True + } class GToArrayJSON f where diff --git a/test/Eq.hs b/test/Eq.hs --- a/test/Eq.hs +++ b/test/Eq.hs @@ -3,11 +3,12 @@ module Eq (tests) where -import Test.QuickCheck.Simple (Test, boolTest) +import Test.QuickCheck.Simple (Test, eqTest) import GHC.Generics (Generic) import Prelude hiding (id) +import Control.Applicative ((<$>)) import Data.Maybe (fromMaybe) import Data.Aeson (FromJSON) import qualified Data.Aeson as Aeson @@ -16,7 +17,7 @@ import Data.JsonRpc (Id(..), numberId, Request (..), Success, success, Failure, failure, Response (..), - genericParseJSONRPC) + genericParseJSONRPC, JsonRpcOptions (..), defaultJsonRpcOptions, ) import qualified Data.JsonRpc.Failure as Failure @@ -28,30 +29,85 @@ } deriving (Eq, Show, Generic) instance FromJSON Foo where - parseJSON = genericParseJSONRPC Aeson.defaultOptions + parseJSON = genericParseJSONRPC defaultJsonRpcOptions Aeson.defaultOptions -eqDecode0 :: Bool -eqDecode0 = - Aeson.decode - "{\"jsonrpc\": \"2.0\", \"method\": \"foo\", \"params\": { \"bar\": \"Hello\", \"foo\": 234, \"baz\": [5, 6, 7, 8] }, \"id\": 3}" - == - Just (Request { jsonrpc = "2.0" +eqDecodeO :: Test +eqDecodeO = + eqTest "eq - decode object" + (Aeson.decode + "{\"jsonrpc\": \"2.0\", \"method\": \"foo\", \"params\": { \"bar\": \"Hello\", \"foo\": 234, \"baz\": [5, 6, 7, 8] }, \"id\": 3}") + (Just Request { jsonrpc = "2.0" , method = "foo" , params = Just (Foo {foo = 234, bar = "Hello", baz = [5,6,7,8]}) , id = Just (NumberId 3)} - ) + ) -eqDecode1 :: Bool -eqDecode1 = - Aeson.decode - "{\"jsonrpc\": \"2.0\", \"method\": \"foo\", \"params\": [ 234, \"Hello\", [5, 6, 7, 8] ], \"id\": 3}" - == - Just (Request { jsonrpc = "2.0" +eqDecodeA :: Test +eqDecodeA = + eqTest "eq - decode array" + (Aeson.decode + "{\"jsonrpc\": \"2.0\", \"method\": \"foo\", \"params\": [ 234, \"Hello\", [5, 6, 7, 8] ], \"id\": 3}") + (Just Request { jsonrpc = "2.0" , method = "foo" , params = Just (Foo {foo = 234, bar = "Hello", baz = [5,6,7,8]}) , id = Just (NumberId 3)} - ) + ) + +newtype FooNE = FooNE Foo deriving (Eq, Show) + +instance FromJSON FooNE where + parseJSON = + (FooNE <$>) + . genericParseJSONRPC defaultJsonRpcOptions { allowNonExistField = False } Aeson.defaultOptions + +eqDecodeNonExistAllow :: Test +eqDecodeNonExistAllow = + eqTest "eq - decode object - allow non-exist" + (Aeson.decode + "{\"jsonrpc\": \"2.0\", \"method\": \"foo\", \"params\": { \"bar\": \"Hello\", \"foo\": 234, \"baz\": [5, 6, 7, 8], \"x\": 0 }, \"id\": 3}") + (Just Request { jsonrpc = "2.0" + , method = "foo" + , params = Just (Foo {foo = 234, bar = "Hello", baz = [5,6,7,8]}) + , id = Just (NumberId 3)} + ) + +eqDecodeNonExistDisallow :: Test +eqDecodeNonExistDisallow = + eqTest "eq - decode object - don't allow non-exist - error" + (Aeson.decode + "{\"jsonrpc\": \"2.0\", \"method\": \"foo\", \"params\": { \"bar\": \"Hello\", \"foo\": 234, \"baz\": [5, 6, 7, 8], \"x\": 0 }, \"id\": 3}" + :: Maybe (Request FooNE)) + Nothing + + +newtype FooSA = FooSA Foo deriving (Eq, Show) + +instance FromJSON FooSA where + parseJSON = + (FooSA <$>) + . genericParseJSONRPC defaultJsonRpcOptions { allowSpilledArguemnts = False } Aeson.defaultOptions + +eqDecodeSpilledAllow :: Test +eqDecodeSpilledAllow = + eqTest "eq - decode array - allow spilled args" + (Aeson.decode + "{\"jsonrpc\": \"2.0\", \"method\": \"foo\", \"params\": [ 234, \"Hello\", [5, 6, 7, 8], 0 ], \"id\": 3}") + (Just Request { jsonrpc = "2.0" + , method = "foo" + , params = Just (Foo {foo = 234, bar = "Hello", baz = [5,6,7,8]}) + , id = Just (NumberId 3)} + ) + +eqDecodeSpilledDisallow :: Test +eqDecodeSpilledDisallow = + eqTest "eq - decode array - don't allow spilled args" + (Aeson.decode + "{\"jsonrpc\": \"2.0\", \"method\": \"foo\", \"params\": [ 234, \"Hello\", [5, 6, 7, 8], 0 ], \"id\": 3}" + :: Maybe (Request FooSA)) + Nothing + + exId :: Id exId = fromMaybe (error "something wrong: _success") $ numberId 25 @@ -61,22 +117,29 @@ exFailure :: Failure String exFailure = failure (Just exId) Failure.InvalidRequest Nothing -eqResponseS :: Bool +eqResponseS :: Test eqResponseS = - Just (Response $ Right exSuccess :: Response String Foo) - == - Aeson.decode "{\"result\":{ \"bar\": \"Hello\", \"foo\": 234, \"baz\": [5, 6, 7, 8] },\"jsonrpc\":\"2.0\",\"id\":25}" + eqTest "eq - response success" + (Just (Response $ Right exSuccess :: Response String Foo)) + (Aeson.decode "{\"result\":{ \"bar\": \"Hello\", \"foo\": 234, \"baz\": [5, 6, 7, 8] },\"jsonrpc\":\"2.0\",\"id\":25}") -eqResponseF :: Bool +eqResponseF :: Test eqResponseF = - Just (Response $ Left exFailure :: Response String Foo) - == - Aeson.decode "{\"error\":{\"code\":-32600,\"message\":\"Invalid Request\"},\"jsonrpc\":\"2.0\",\"id\":25}" + eqTest "eq - response failure" + (Just (Response $ Left exFailure :: Response String Foo)) + (Aeson.decode "{\"error\":{\"code\":-32600,\"message\":\"Invalid Request\"},\"jsonrpc\":\"2.0\",\"id\":25}") tests :: [Test] tests = - [ boolTest "eq - decode 0" eqDecode0 - , boolTest "eq - decode 1" eqDecode1 - , boolTest "eq - response success" eqResponseS - , boolTest "eq - response failure" eqResponseF + [ eqDecodeO + , eqDecodeA + + , eqDecodeNonExistAllow + , eqDecodeNonExistDisallow + + , eqDecodeSpilledAllow + , eqDecodeSpilledDisallow + + , eqResponseS + , eqResponseF ] diff --git a/test/Instances.hs b/test/Instances.hs --- a/test/Instances.hs +++ b/test/Instances.hs @@ -17,7 +17,7 @@ Success (..), success, Failure (..), Error (..), ErrorStatus (..), failure, makeError, Response (..), - genericParseJSONRPC, ) + genericParseJSONRPC, defaultJsonRpcOptions, ) genText :: Gen Text @@ -103,6 +103,6 @@ <*> arbitrary <*> arbitrary <*> arbitrary instance FromJSON Example where - parseJSON = genericParseJSONRPC Aeson.defaultOptions + parseJSON = genericParseJSONRPC defaultJsonRpcOptions Aeson.defaultOptions instance ToJSON Example diff --git a/test/testMain.hs b/test/testMain.hs --- a/test/testMain.hs +++ b/test/testMain.hs @@ -1,7 +1,7 @@ import qualified Eq import qualified Iso -import Test.QuickCheck.Simple (defaultMain) +import Test.QuickCheck.Simple (defaultMain') main :: IO () -main = defaultMain $ Eq.tests ++ Iso.tests +main = defaultMain' True $ Eq.tests ++ Iso.tests