Migrate to aeson 2.0+ (KeyMap API)

json-rpc-server.cabal

@@ -37,14 +37,13 @@ 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,
-                       deepseq >= 1.1 && <1.5,
-                       bytestring >=0.9 && <0.11,
-                       mtl >=2.2.1 && <2.3,
-                       text >=0.11 && <1.3,
-                       vector >=0.7.1 && <0.13,
-                       unordered-containers >=0.1 && <0.3
+  build-depends:       base >=4.3 && <4.21,
+                       aeson >=2.0 && <2.3,
+                       deepseq >= 1.1 && <1.6,
+                       bytestring >=0.9 && <0.13,
+                       mtl >=2.2.1 && <2.4,
+                       text >=0.11 && <2.2,
+                       vector >=0.7.1 && <0.14
   hs-source-dirs:      src
   ghc-options:         -Wall
   other-extensions:    CPP,
@@ -82,7 +81,6 @@ test-suite tests
                        bytestring,
                        mtl,
                        text,
-                       vector,
-                       unordered-containers
+                       vector
   ghc-options:         -Wall
   other-extensions:    CPP, OverloadedStrings

src/Network/JsonRpc/Server.hs

@@ -37,7 +37,8 @@ import Data.Maybe (catMaybes)
 import qualified Data.ByteString.Lazy as B
 import qualified Data.Aeson as A
 import qualified Data.Vector as V
-import qualified Data.HashMap.Strict as H
+import qualified Data.Aeson.Key as AK
+import qualified Data.Aeson.KeyMap as KM
 import Control.DeepSeq (NFData)
 import Control.Monad (liftM, (<=<))
 import Control.Monad.Identity (runIdentity)
@@ -86,7 +87,7 @@ toMethods :: [Method m] -> Methods m
 toMethods = id
 {-# DEPRECATED toMethods "Use 'call' directly." #-}
 
-type MethodMap m = H.HashMap Text (Method m)
+type MethodMap m = KM.KeyMap (Method m)
 
 -- | Handles one JSON-RPC request. It is the same as
 --   @callWithBatchStrategy sequence@.
@@ -109,8 +110,8 @@ callWithBatchStrategy :: Monad m =>
 callWithBatchStrategy strategy methods =
     mthMap `seq` either returnErr callMethod . parse
   where
-    mthMap = H.fromList $
-             map (\mth@(Method name _) -> (name, mth)) methods
+    mthMap = KM.fromList $
+             map (\mth@(Method name _) -> (AK.fromText name, mth)) methods
     parse :: B.ByteString -> Either RpcError (Either A.Value [A.Value])
     parse = runIdentity . runExceptT . parseVal <=< parseJson
     parseJson = maybe invalidJson return . A.decode
@@ -147,7 +148,7 @@ parseValue val = case A.fromJSON val of
                    A.Success x -> return x
 
 lookupMethod :: Monad m => Text -> MethodMap m -> RpcResult m (Method m)
-lookupMethod name = maybe notFound return . H.lookup name
+lookupMethod name = maybe notFound return . KM.lookup (AK.fromText name)
     where notFound = throwError $ rpcError (-32601) $ "Method not found: " `append` name
 
 throwInvalidRpc :: Monad m => Text -> RpcResult m a

src/Network/JsonRpc/Types.hs

@@ -23,9 +23,11 @@ import Data.Maybe (catMaybes)
 import Data.Text (Text, append, unpack)
 import qualified Data.Aeson as A
 import Data.Aeson ((.=), (.:), (.:?), (.!=))
-import Data.Aeson.Types (emptyObject)
+import Data.Aeson.Types (iparse, IResult (..), formatError)
+
 import qualified Data.Vector as V
-import qualified Data.HashMap.Strict as H
+import qualified Data.Aeson.Key as AK
+import qualified Data.Aeson.KeyMap as KM
 import Control.DeepSeq (NFData, rnf)
 import Control.Monad (when)
 import Control.Monad.Except (ExceptT (..), throwError)
@@ -68,14 +70,14 @@ 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 (KM.lookup (AK.fromText 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
+parseArg name val = case iparse A.parseJSON val of
+                      IError path msg -> throwError $ argTypeError (formatError path msg)
+                      ISuccess x -> return x
     where argTypeError = rpcErrorWithData (-32602) $ "Wrong type for argument: " `append` name
 
 paramDefault :: Parameter a -> Either RpcError a
@@ -92,15 +94,15 @@ paramName (Required n) = n
 -- | A JSON-RPC method.
 data Method m = Method Text (Args -> RpcResult m A.Value)
 
-type Args = Either A.Object A.Array
+type Args = Either (KM.KeyMap A.Value) A.Array
 
 data Request = Request Text Args (Maybe Id)
 
 instance A.FromJSON Request where
-    parseJSON (A.Object x) = (checkVersion =<< x .:? versionKey .!= jsonRpcVersion) *>
+    parseJSON (A.Object x) = (checkVersion =<< x .:? AK.fromText versionKey .!= jsonRpcVersion) *>
                              (Request <$>
-                              x .: "method" <*>
-                              (parseParams =<< x .:? "params" .!= emptyObject) <*>
+                              x .: AK.fromText "method" <*>
+                              (parseParams =<< x .:? AK.fromText "params" .!= A.Object KM.empty) <*>
                               parseId)
         where parseParams (A.Object obj) = return $ Left obj
               parseParams (A.Array ar) = return $ Right ar
@@ -109,9 +111,9 @@ instance A.FromJSON Request where
                             fail $ "Wrong JSON-RPC version: " ++ unpack ver
                -- (.:?) parses Null value as Nothing so parseId needs
                -- to use both (.:?) and (.:) to handle all cases
-              parseId = x .:? idKey >>= \optional ->
+              parseId = x .:? AK.fromText idKey >>= \optional ->
                         case optional of
-                          Nothing -> Just <$> (x .: idKey) <|> return Nothing
+                          Nothing -> Just <$> (x .: AK.fromText idKey) <|> return Nothing
                           _ -> return optional
     parseJSON _ = empty
 
@@ -122,9 +124,9 @@ instance NFData Response where
 
 instance A.ToJSON Response where
     toJSON (Response i result) = A.object pairs
-        where pairs = [ versionKey .= jsonRpcVersion
+        where pairs = [ AK.fromText versionKey .= jsonRpcVersion
                       , either ("error" .=) ("result" .=) result
-                      , idKey .= i]
+                      , AK.fromText idKey .= i]
 
 -- IdNumber cannot directly reference the type stored in A.Number,
 -- since it changes between aeson-0.6 and 0.7.

tests/Internal.hs

@@ -18,7 +18,8 @@ module Internal ( request
 
 import qualified Data.Aeson as A
 import Data.Aeson ((.=))
-import qualified Data.HashMap.Strict as H
+import qualified Data.Aeson.Key as AK
+import qualified Data.Aeson.KeyMap as KM
 import Data.Maybe (catMaybes)
 import qualified Data.Vector as V
 import Data.Text (Text)
@@ -31,7 +32,7 @@ array :: [A.Value] -> A.Value
 array = A.Array . V.fromList
 
 rspToIdString :: A.Value -> Maybe String
-rspToIdString (A.Object rsp) = show <$> H.lookup "id" rsp
+rspToIdString (A.Object rsp) = show <$> KM.lookup (AK.fromText "id") rsp
 rspToIdString _ = Nothing
 
 request :: Maybe A.Value -> Text -> Maybe A.Value -> A.Value
@@ -45,7 +46,7 @@ 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 i key res = A.object ["id" .= i, key .= res, "jsonrpc" .= A.String "2.0"]
+response i key res = A.object ["id" .= i, AK.fromText key .= res, "jsonrpc" .= A.String "2.0"]
 
 defaultRsp :: A.Value
 defaultRsp = response defaultId "result" defaultResult
@@ -79,8 +80,8 @@ result :: A.Value -> A.Value -> A.Value
 result rsp = insert rsp "result" . Just
 
 insert :: A.Value -> Text -> 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 (A.Object obj) key Nothing = A.Object $ KM.delete (AK.fromText key) obj
+insert (A.Object obj) key (Just val) = A.Object $ KM.insert (AK.fromText key) val obj
 insert v _ _ = v
 
 defaultId :: A.Value

tests/TestSuite.hs

@@ -16,7 +16,8 @@ import Data.Function (on)
 import qualified Data.Aeson as A
 import Data.Aeson ((.=))
 import qualified Data.Aeson.Types as A
-import qualified Data.HashMap.Strict as H
+import qualified Data.Aeson.Key as AK
+import qualified Data.Aeson.KeyMap as KM
 import qualified Data.ByteString.Lazy.Char8 as LB
 import Control.Monad.Trans (liftIO)
 import Control.Monad.State (State, runState, lift, modify)
@@ -93,7 +94,7 @@ otherTests = [ testCase "encode RPC error" $
 
              , testCase "empty argument array" $ assertGetTimeResponse $ Just A.emptyArray
 
-             , testCase "empty argument A.object" $ assertGetTimeResponse $ Just A.emptyObject
+             , testCase "empty argument A.object" $ assertGetTimeResponse $ Just (A.Object KM.empty)
 
              , let req = defaultRq `params` Just args
                    args = A.object ["x" .= A.Number 10, "y" .= A.Number 20, "z" .= A.String "extra"]
@@ -185,8 +186,11 @@ 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
-    where removeMsg (A.Object err) = A.Object $ H.insert "message" "" $ H.delete "data" err
+removeErrMsg (A.Object rsp) = A.Object $ case KM.lookup errKey rsp of
+    Nothing -> rsp
+    Just v  -> KM.insert errKey (removeMsg v) rsp
+    where errKey = AK.fromText "error"
+          removeMsg (A.Object err) = A.Object $ KM.insert (AK.fromText "message") "" $ KM.delete (AK.fromText "data") err
           removeMsg v = v
 removeErrMsg (A.Array rsps) = A.Array $ removeErrMsg `V.map` rsps
 removeErrMsg v = v