Support aeson-2.0.

Author: qnikst

json-rpc-server.cabal

@@ -37,8 +37,8 @@ flag demo
 library
   exposed-modules:     Network.JsonRpc.Server
   other-modules:       Network.JsonRpc.Types
-  build-depends:       base >=4.3 && <4.15,
-                       aeson >=0.6 && <1.6,
+  build-depends:       base >=4.3 && <4.16,
+                       aeson (>=0.6 && <1.6) || (>=2.1 && <2.2),
                        deepseq >= 1.1 && <1.5,
                        bytestring >=0.9 && <0.11,
                        mtl >=2.2.1 && <2.3,

src/Network/JsonRpc/Types.hs

@@ -20,12 +20,22 @@ module Network.JsonRpc.Types ( RpcResult
                              , rpcErrorWithData) where
 
 import Data.Maybe (catMaybes)
-import Data.Text (Text, append, unpack)
+import Data.Text (Text)
+#if ! MIN_VERSION_aeson(2,0,0)
+import Data.Text (unpack)
+#endif
 import qualified Data.Aeson as A
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.Key as A
+#endif
 import Data.Aeson ((.=), (.:), (.:?), (.!=))
 import Data.Aeson.Types (emptyObject)
 import qualified Data.Vector as V
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as KeyMap
+#else
 import qualified Data.HashMap.Strict as H
+#endif
 import Control.DeepSeq (NFData, rnf)
 import Control.Monad (when)
 import Control.Monad.Except (ExceptT (..), throwError)
@@ -68,22 +78,22 @@ instance (A.FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p)
         ExceptT (return arg) >>= \a -> _apply (f a) ps nextArgs
       where
         arg = maybe (paramDefault param) (parseArg name) lookupValue
-        lookupValue = either (H.lookup name) (V.!? 0) args
+        lookupValue = either (lookupInObject name) (V.!? 0) args
         nextArgs = V.drop 1 <$> args
         name = paramName param
 
 parseArg :: A.FromJSON r => Text -> A.Value -> Either RpcError r
 parseArg name val = case A.fromJSON val of
                       A.Error msg -> throwError $ argTypeError msg
                       A.Success x -> return x
-    where argTypeError = rpcErrorWithData (-32602) $ "Wrong type for argument: " `append` name
+    where argTypeError = rpcErrorWithData (-32602) $ "Wrong type for argument: " <> name
 
 paramDefault :: Parameter a -> Either RpcError a
 paramDefault (Optional _ d) = Right d
 paramDefault (Required name) = Left $ missingArgError name
 
 missingArgError :: Text -> RpcError
-missingArgError name = rpcError (-32602) $ "Cannot find required argument: " `append` name
+missingArgError name = rpcError (-32602) $ "Cannot find required argument: " <> name
 
 paramName :: Parameter a -> Text
 paramName (Optional n _) = n
@@ -106,7 +116,7 @@ instance A.FromJSON Request where
               parseParams (A.Array ar) = return $ Right ar
               parseParams _ = empty
               checkVersion ver = when (ver /= jsonRpcVersion) $
-                            fail $ "Wrong JSON-RPC version: " ++ unpack ver
+                            fail $ "Wrong JSON-RPC version: " ++ unpackKey ver
                -- (.:?) parses Null value as Nothing so parseId needs
                -- to use both (.:?) and (.:) to handle all cases
               parseId = x .:? idKey >>= \optional ->
@@ -180,7 +190,25 @@ rpcError code msg = RpcError code msg Nothing
 rpcErrorWithData :: A.ToJSON a => Int -> Text -> a -> RpcError
 rpcErrorWithData code msg errorData = RpcError code msg $ Just $ A.toJSON errorData
 
+#if MIN_VERSION_aeson(2,0,0)
+jsonRpcVersion, versionKey, idKey :: A.Key
+#else
 jsonRpcVersion, versionKey, idKey :: Text
+#endif
 jsonRpcVersion = "2.0"
 versionKey = "jsonrpc"
 idKey = "id"
+
+#if MIN_VERSION_aeson(2,0,0)
+unpackKey :: A.Key -> String
+unpackKey = A.toString
+
+lookupInObject :: Text -> KeyMap.KeyMap A.Value -> Maybe A.Value
+lookupInObject key = KeyMap.lookup (A.fromText key)
+#else
+unpackKey :: Text -> String
+unpackKey = unpack
+
+lookupInObject :: Text -> H.HashMap Text A.Value -> Maybe A.Value
+lookupInObject = H.lookup
+#endif

tests/Internal.hs

@@ -18,7 +18,11 @@ module Internal ( request
 
 import qualified Data.Aeson as A
 import Data.Aeson ((.=))
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as H
+#else
 import qualified Data.HashMap.Strict as H
+#endif
 import Data.Maybe (catMaybes)
 import qualified Data.Vector as V
 import Data.Text (Text)
@@ -44,7 +48,7 @@ defaultRq :: A.Value
 defaultRq = request (Just defaultId) "subtract" args
     where args = Just $ A.object ["x" .= A.Number 1, "y" .= A.Number 2]
 
-response :: A.Value -> Text -> A.Value -> A.Value
+response :: A.Value -> Key -> A.Value -> A.Value
 response i key res = A.object ["id" .= i, key .= res, "jsonrpc" .= A.String "2.0"]
 
 defaultRsp :: A.Value
@@ -78,7 +82,7 @@ version rq = insert rq "jsonrpc"
 result :: A.Value -> A.Value -> A.Value
 result rsp = insert rsp "result" . Just
 
-insert :: A.Value -> Text -> Maybe A.Value -> A.Value
+insert :: A.Value -> Key -> Maybe A.Value -> A.Value
 insert (A.Object obj) key Nothing = A.Object $ H.delete key obj
 insert (A.Object obj) key (Just val) = A.Object $ H.insert key val obj
 insert v _ _ = v
@@ -88,3 +92,9 @@ defaultId = A.Number 3
 
 defaultResult :: A.Value
 defaultResult = A.Number (-1)
+
+#if MIN_VERSION_aeson(2,0,0)
+type Key = A.Key
+#else
+type Key = Text
+#endif

tests/TestSuite.hs

@@ -16,11 +16,15 @@ import Data.Function (on)
 import qualified Data.Aeson as A
 import Data.Aeson ((.=))
 import qualified Data.Aeson.Types as A
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as H
+#else
 import qualified Data.HashMap.Strict as H
+#endif
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Control.Monad.Trans (liftIO)
 import Control.Monad.State (State, runState, lift, modify)
-import Control.Monad.Identity (Identity, runIdentity)
+import Control.Monad.Identity (Identity(..), runIdentity)
 import Test.HUnit hiding (State, Test)
 import Test.Framework (defaultMain, Test)
 import Test.Framework.Providers.HUnit (testCase)
@@ -185,7 +189,7 @@ getTimeMethod = S.toMethod "get_time_seconds" getTestTime ()
           getTestTime = liftIO $ return 100
 
 removeErrMsg :: A.Value -> A.Value
-removeErrMsg (A.Object rsp) = A.Object $ H.adjust removeMsg "error" rsp
+removeErrMsg (A.Object rsp) = A.Object $ runIdentity $ H.alterF (Identity . fmap removeMsg) "error" rsp
     where removeMsg (A.Object err) = A.Object $ H.insert "message" "" $ H.delete "data" err
           removeMsg v = v
 removeErrMsg (A.Array rsps) = A.Array $ removeErrMsg `V.map` rsps