packages feed

json-rpc-generic (empty) → 0.0.1.0

raw patch · 15 files changed

+680/−0 lines, 15 filesdep +QuickCheckdep +aesondep +basesetup-changed

Dependencies added: QuickCheck, aeson, base, bytestring, json-rpc-generic, quickcheck-simple, scientific, text, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2016, Kei Hibino++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Kei Hibino nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ json-rpc-generic.cabal view
@@ -0,0 +1,77 @@+name:                json-rpc-generic+version:             0.0.1.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+license:             BSD3+license-file:        LICENSE+author:              Kei Hibino+maintainer:          ex8k.hibino@gmail.com+copyright:           Copyright (c) 2016 Kei Hibino+category:            Network+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10+tested-with:           GHC == 8.0.1+                     , GHC == 7.10.1, GHC == 7.10.2, GHC == 7.10.3+                     , GHC == 7.8.1, GHC == 7.8.2, GHC == 7.8.3, GHC == 7.8.4+                     , GHC == 7.6.1, GHC == 7.6.2, GHC == 7.6.3++library+  exposed-modules:+                       Data.JsonRpc.Id+                       Data.JsonRpc.Request+                       Data.JsonRpc.Success+                       Data.JsonRpc.Failure+                       Data.JsonRpc.Response+                       Data.JsonRpc.Generic+                       Data.JsonRpc.Instances++                       Data.JsonRpc+  -- other-modules:+  other-extensions:+                       TypeOperators+                       FlexibleContexts+                       OverloadedStrings+                       DeriveFunctor+                       DeriveFoldable+                       DeriveTraversable+                       -- DeriveGeneric  -- compat with Cabal 1.16+                       StandaloneDeriving++  build-depends:         base >=4.6 && <5+                       , transformers+                       , bytestring >=0.10+                       , text+                       , scientific+                       , vector >=0.10+                       , aeson >=0.7++  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall++test-suite test-main+  main-is:             testMain.hs+  other-modules:+                       Instances+                       Iso+                       Eq+  build-depends:         base <5+                       , aeson+                       , text+                       , json-rpc-generic+                       , quickcheck-simple+                       , QuickCheck+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  ghc-options:         -Wall+  default-language:    Haskell2010++source-repository head+  type:       git+  location:   https://github.com/khibino/haskell-json-rpc-generic++source-repository head+  type:       mercurial+  location:   https://bitbucket.org/khibino/haskell-json-rpc-generic
+ src/Data/JsonRpc.hs view
@@ -0,0 +1,16 @@+module Data.JsonRpc (+  module Data.JsonRpc.Id,+  module Data.JsonRpc.Request,+  module Data.JsonRpc.Success,+  module Data.JsonRpc.Failure,+  module Data.JsonRpc.Response,+  module Data.JsonRpc.Generic,+  ) where++import Data.JsonRpc.Id+import Data.JsonRpc.Request+import Data.JsonRpc.Success+import Data.JsonRpc.Failure hiding (_jsonrpc, _id)+import Data.JsonRpc.Response+import Data.JsonRpc.Generic+import Data.JsonRpc.Instances ()
+ src/Data/JsonRpc/Failure.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++module Data.JsonRpc.Failure (+  Failure (..), Error (..), ErrorStatus (..),++  failure, makeError,+  serverError,+  methodError,+  emptyError,+  ) where++import Prelude hiding (userError)+import Control.Monad (MonadPlus, guard)+import Data.Text (Text)+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)++import Data.JsonRpc.Id (Id)+++data Failure e =+  Failure+  { _jsonrpc :: !Text+  , _id      :: !(Maybe Id)+  , _error   :: !(Error e)+  } deriving (Eq, Show, Functor, Foldable, Traversable)++data Error e =+  Error+  { _code    :: !Int+  , _message :: !Text+  , _data    :: !(Maybe e)+  } deriving (Eq, Show, Functor, Foldable, Traversable)++data ErrorStatus+  = ParseError+  | InvalidRequest+  | MethodNotFound+  | InvalidParams+  | InternalError+  | ServerError !Int+  | MethodError !Int !Text+  deriving (Eq, Show)++failure :: Maybe Id -> ErrorStatus -> Maybe e -> Failure e+failure mayId s =+  Failure "2.0" mayId . makeError s++makeError :: ErrorStatus -> Maybe e -> Error e+makeError = d  where+  d  ParseError         =  Error (-32700) "Parse error"+  d  InvalidRequest     =  Error (-32600) "Invalid Request"+  d  MethodNotFound     =  Error (-32601) "Method not found"+  d  InvalidParams      =  Error (-32602) "Invalid params"+  d  InternalError      =  Error (-32603) "Internal error"+  d (ServerError c)     =  Error       c  "Server error"+  d (MethodError c m)   =  Error       c   m++serverError :: MonadPlus m+            => Int+            -> m ErrorStatus+serverError c = do+  guard $ -32099 <= c && c <= -32000+  return $ ServerError c++methodError :: MonadPlus m+            => Int+            -> Text+            -> m ErrorStatus+methodError c s = do+  guard $ c < -32768 || -32000 < c+  return $ MethodError c s++emptyError :: Maybe ()+emptyError = Nothing
+ src/Data/JsonRpc/Generic.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.JsonRpc.Generic (+  GFromArrayJSON, genericParseJSONRPC,++  GToArrayJSON, genericToArrayJSON,+  ) where++import GHC.Generics+import Control.Applicative ((<$>), (<*>), (<*), empty)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.State (StateT, evalStateT, get, put)+import Data.Aeson.Types+  (FromJSON (..), ToJSON (..), GFromJSON, genericParseJSON, Parser, Options, Value (..))+import Data.Vector (Vector)+import qualified Data.Vector as Vector+++class GFromArrayJSON f where+  gFromArrayJSON :: StateT [Value] Parser (f a)++instance GFromArrayJSON U1 where+  gFromArrayJSON  =  return U1++instance (GFromArrayJSON a, GFromArrayJSON b) => GFromArrayJSON (a :*: b) where+  gFromArrayJSON  =  (:*:) <$> gFromArrayJSON <*> gFromArrayJSON++instance GFromArrayJSON a => GFromArrayJSON (M1 i c a) where+  gFromArrayJSON  =  M1 <$> gFromArrayJSON++instance FromJSON a => GFromArrayJSON (K1 i a) where+  gFromArrayJSON  =  do+    vs'  <-  get+    K1 <$> case vs' of+     v:vs  ->  (lift $ parseJSON v)   <* put vs+     []    ->   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+  d _               =  empty+++class GToArrayJSON f where+  gToArrayJSON :: f a -> Vector Value++instance GToArrayJSON U1 where+  gToArrayJSON U1 = Vector.empty++instance (GToArrayJSON a, GToArrayJSON b) => GToArrayJSON (a :*: b) where+  gToArrayJSON (x :*: y)  =  gToArrayJSON x Vector.++ gToArrayJSON y++instance GToArrayJSON a => GToArrayJSON (M1 i c a) where+  gToArrayJSON (M1 x)  =  gToArrayJSON x++instance ToJSON a => GToArrayJSON (K1 i a) where+  gToArrayJSON (K1 x)  =  Vector.singleton $ toJSON x++genericToArrayJSON :: (Generic a, GToArrayJSON (Rep a))+                   => a -> Value+genericToArrayJSON = Array . gToArrayJSON . from
+ src/Data/JsonRpc/Id.hs view
@@ -0,0 +1,41 @@++module Data.JsonRpc.Id (Id(..), numberId) where++import Control.Applicative (Applicative, pure)+import Control.Monad (MonadPlus, guard)++import Data.Text (Text)+import Data.Scientific (Scientific, toDecimalDigits)+++{-+-- citation from http://www.jsonrpc.org/specification+--+--  An identifier established by the Client that MUST contain+--  a String, Number, or NULL value if included.+--  If it is not included it is assumed to be a notification.+--  The value SHOULD normally not be Null [1]+--  and Numbers SHOULD NOT contain fractional parts [2]+--+--  [1] The use of Null as a value for the id member in+--  a Request object is discouraged, because this specification+--  uses a value of Null for Responses with an unknown id.+--  Also, because JSON-RPC 1.0 uses an id value of Null+--  for Notifications this could cause confusion in handling.++--  [2] Fractional parts may be problematic,+--  since many decimal fractions cannot be+--  represented exactly as binary fractions.+-}++data Id+  = StringId !Text+  | NumberId !Integer+  deriving (Eq, Ord, Show, Read)++numberId :: (MonadPlus m, Applicative m) => Scientific -> m Id+numberId sci = do+  let (ds, e) = toDecimalDigits sci+  guard $ sci == 0 || null (drop e ds)  -- test integral++  pure . NumberId $ round sci
+ src/Data/JsonRpc/Instances.hs view
@@ -0,0 +1,80 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StandaloneDeriving #-}++module Data.JsonRpc.Instances () where++import GHC.Generics (Generic)+import Control.Applicative ((<$>), pure, (<|>))+import Data.Maybe (fromMaybe)+import Data.List (stripPrefix)+import Data.Aeson (FromJSON (..), genericParseJSON, ToJSON (..), genericToJSON, Value(..))+import Data.Aeson.Types (Options (..))+import qualified Data.Aeson.Types as Aeson++import Data.JsonRpc.Id (Id(..), numberId)+import Data.JsonRpc.Request (Request (..))+import Data.JsonRpc.Success (Success (..))+import Data.JsonRpc.Failure (Failure (..), Error (..))+import Data.JsonRpc.Response (Response (..))+++instance FromJSON Id where+  parseJSON = d  where+    d (String t)   =  pure $ StringId t+    d (Number n)   =  maybe (parseError "Integer check error") pure $ numberId n+    d (Object {})  =  parseError "object is not allowed"+    d (Array  {})  =  parseError "array is not allowed"+    d (Bool   {})  =  parseError "boolean is not allowed"+    d  Null        =  parseError "null is not allowed"+    parseError = fail . ("JSON RPC id: " ++)++instance ToJSON Id where+  toJSON = d  where+    d (StringId s)  =  String s+    d (NumberId i)  =  Number $ fromIntegral i++deriving instance Generic (Request a)++instance FromJSON a => FromJSON (Request a) where+  parseJSON = genericParseJSON customOptions++instance ToJSON a => ToJSON (Request a) where+  toJSON = genericToJSON customOptions++deriving instance Generic (Success a)++instance FromJSON a => FromJSON (Success a) where+  parseJSON = genericParseJSON customOptions++instance ToJSON a => ToJSON (Success a) where+  toJSON = genericToJSON customOptions++deriving instance Generic (Error e)+deriving instance Generic (Failure e)++instance FromJSON e => FromJSON (Error e) where+  parseJSON = genericParseJSON customOptions++instance ToJSON e => ToJSON (Error e) where+  toJSON = genericToJSON customOptions { omitNothingFields  =  True }++instance FromJSON e => FromJSON (Failure e) where+  parseJSON = genericParseJSON customOptions++instance ToJSON e => ToJSON (Failure e) where+  toJSON = genericToJSON customOptions++instance (FromJSON e, FromJSON a) => FromJSON (Response e a) where+  parseJSON v = Response <$> (Right <$> parseJSON v <|>+                              Left  <$> parseJSON v)++instance (ToJSON e, ToJSON a) => ToJSON (Response e a) where+  toJSON (Response r) = case r of+    Right a  -> toJSON a+    Left  e  -> toJSON e++customOptions :: Options+customOptions =+  Aeson.defaultOptions+  { fieldLabelModifier  =  \s -> fromMaybe s $ stripPrefix "_" s }
+ src/Data/JsonRpc/Request.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++module Data.JsonRpc.Request (+  Request(..), request,+  ) where++import Prelude hiding (id)+import Data.Text (Text, pack)+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)++import Data.JsonRpc.Id (Id)+++data Request a =+  Request+  { jsonrpc :: !Text+  , method  :: !Text+  , params  :: !(Maybe a)+  , id      :: !(Maybe Id)+  } deriving (Eq, Show, Read, Functor, Foldable, Traversable)++request :: Text -> Maybe a -> Maybe Id -> Request a+request = Request $ pack "2.0"
+ src/Data/JsonRpc/Response.hs view
@@ -0,0 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Data.JsonRpc.Response (+  Response (..),+  ) where++import Data.JsonRpc.Success (Success (..))+import Data.JsonRpc.Failure (Failure (..))+++newtype Response e a =+  Response (Either (Failure e) (Success a))+  deriving (Eq, Show, Functor)
+ src/Data/JsonRpc/Success.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}++module Data.JsonRpc.Success (+  Success (..), success,+  ) where++import Data.Text (Text, pack)+import Data.Foldable (Foldable)+import Data.Traversable (Traversable)++import Data.JsonRpc.Id (Id)+++data Success a =+  Success+  { _jsonrpc :: !Text+  , _id      :: !Id+  , _result  :: !a+  } deriving (Eq, Show, Functor, Foldable, Traversable)++success :: Id -> a -> Success a+success = Success $ pack "2.0"
+ test/Eq.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Eq (tests) where++import Test.QuickCheck.Simple (Test, boolTest)++import GHC.Generics (Generic)++import Prelude hiding (id)+import Data.Maybe (fromMaybe)+import Data.Aeson (FromJSON)+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson++import Data.JsonRpc+  (Id(..), numberId, Request (..),+   Success, success, Failure, failure, Response (..),+  genericParseJSONRPC)+import qualified Data.JsonRpc.Failure as Failure+++data Foo =+  Foo+  { foo :: Int+  , bar :: String+  , baz :: [Int]+  } deriving (Eq, Show, Generic)++instance FromJSON Foo where+  parseJSON = genericParseJSONRPC 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"+                , 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"+                , method = "foo"+                , params = Just (Foo {foo = 234, bar = "Hello", baz = [5,6,7,8]})+                , id = Just (NumberId 3)}+       )++exId :: Id+exId = fromMaybe (error "something wrong: _success") $ numberId 25++exSuccess :: Success Foo+exSuccess = success exId Foo {foo = 234, bar = "Hello", baz = [5,6,7,8]}++exFailure :: Failure String+exFailure = failure (Just exId) Failure.InvalidRequest Nothing++eqResponseS :: Bool+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}"++eqResponseF :: Bool+eqResponseF =+  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+  ]
+ test/Instances.hs view
@@ -0,0 +1,108 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric #-}++module Instances (Example (..)) where++import Test.QuickCheck (Arbitrary (..), Gen, frequency, choose)++import GHC.Generics (Generic)+import Control.Applicative ((<$>), pure, (<*>))+import Data.Text (Text)+import qualified Data.Text as T+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson.Types as Aeson++import Data.JsonRpc+  (Id(..), Request (..), request,+   Success (..), success,+   Failure (..), Error (..), ErrorStatus (..), failure, makeError,+   Response (..),+   genericParseJSONRPC, )+++genText :: Gen Text+genText = T.pack <$> arbitrary++instance Arbitrary Id where+  arbitrary =+    frequency+    [ (3, NumberId <$> arbitrary)+    , (2, StringId . T.pack <$> arbitrary)+    ]++instance Arbitrary a => Arbitrary (Request a) where+  arbitrary =+    request+    <$> genText+    <*> arbitrary+    <*> arbitrary++instance Arbitrary a => Arbitrary (Success a) where+  arbitrary =+    success+    <$> arbitrary+    <*> arbitrary++genServerError :: Gen ErrorStatus+genServerError = ServerError <$> choose (-32099, -32000)++genMethodErrorA :: Gen ErrorStatus+genMethodErrorA = MethodError <$> choose (-31999, 0) <*> genText++genMethodErrorB :: Gen ErrorStatus+genMethodErrorB = MethodError <$> choose (-65535, -32769) <*> genText++instance Arbitrary ErrorStatus where+  arbitrary =+    frequency+    [ (1, pure ParseError)+    , (1, pure InvalidRequest)+    , (1, pure MethodNotFound)+    , (1, pure InvalidParams)+    , (1, pure InternalError)+    , (2, genServerError)+    , (2, genMethodErrorA)+    , (2, genMethodErrorB)+    ]++instance Arbitrary e => Arbitrary (Error e) where+  arbitrary =+    makeError+    <$> arbitrary+    <*> arbitrary++instance Arbitrary e => Arbitrary (Failure e) where+  arbitrary =+    failure+    <$> arbitrary+    <*> arbitrary+    <*> arbitrary++instance (Arbitrary e, Arbitrary a) => Arbitrary (Response e a) where+  arbitrary =+    frequency+    [ (2, Response . Right <$> arbitrary)+    , (3, Response . Left  <$> arbitrary)+    ]+++data Example =+  Example+  { p :: Int+  , q :: String+  , r :: Maybe Int+  , s :: [Int]+  , t :: Maybe [Int]+  , u :: Maybe String+  } deriving (Eq, Show, Generic)++instance Arbitrary Example where+  arbitrary =+    Example+    <$> arbitrary <*> arbitrary <*> arbitrary+    <*> arbitrary <*> arbitrary <*> arbitrary++instance FromJSON Example where+  parseJSON = genericParseJSONRPC Aeson.defaultOptions++instance ToJSON Example
+ test/Iso.hs view
@@ -0,0 +1,36 @@+module Iso (tests) where++import Test.QuickCheck.Simple (Test, qcTest)++import Control.Applicative ((<$>))+import Data.Aeson (FromJSON, ToJSON)+import qualified Data.Aeson as Aeson++import Data.JsonRpc (Request, Response, Error, genericToArrayJSON)++import Instances (Example)+++aesonED :: (Eq a, ToJSON a, FromJSON a)+        => a -> Bool+aesonED x = Aeson.decode (Aeson.encode x) == Just x++request :: Request Example -> Bool+request = aesonED++requestA :: Request Example -> Bool+requestA r =+  Aeson.decode (Aeson.encode $ genericToArrayJSON <$> r) == Just r++errorObj :: Error Example -> Bool+errorObj = aesonED++response :: Response Example Example -> Bool+response = aesonED++tests :: [Test]+tests =+  [ qcTest "iso - request" request+  , qcTest "iso - request array" requestA+  , qcTest "iso - error object" errorObj+  , qcTest "iso - response" response ]
+ test/testMain.hs view
@@ -0,0 +1,7 @@++import qualified Eq+import qualified Iso+import Test.QuickCheck.Simple (defaultMain)++main :: IO ()+main = defaultMain $ Eq.tests ++ Iso.tests