json-rpc-generic 0.0.1.0 → 0.1.0.0

raw patch · 5 files changed

+195/−42 lines, 5 filesdep +containersdep +dlistdep +unordered-containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, dlist, unordered-containers

API changes (from Hackage documentation)

Files

• json-rpc-generic.cabal +4/−1
• src/Data/JsonRpc/Generic.hs +95/−8
• test/Eq.hs +92/−29
• test/Instances.hs +2/−2
• test/testMain.hs +2/−2

@@ -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

@@ -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

@@ -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   ]

@@ -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

@@ -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