From 5a2660a2797eb4bd426d417ec66e09fb79e5def1 Mon Sep 17 00:00:00 2001 From: Anatolii Prylutskyi Date: Mon, 9 Feb 2026 19:54:05 +0200 Subject: [PATCH 1/3] Migrate from Data.HashMap.Strict to Data.Aeson.KeyMap for aeson 2.0+ aeson 2.0 replaced HashMap-based Object with KeyMap-based Object. This updates all HashMap operations to use the KeyMap and Key APIs: - H.lookup -> KM.lookup with AK.fromText for key conversion - Object type alias -> KM.KeyMap A.Value - .: and .:? operators now use AK.fromText for string keys - Object construction uses AK.fromText for keys - emptyObject replaced with A.Object KM.empty - MethodMap type updated from HashMap to KeyMap - Dependency bounds updated: aeson >=2.0, removed unordered-containers - Relaxed upper bounds for base, bytestring, text, vector, deepseq, mtl Fixes #3 Co-Authored-By: Claude Opus 4.6 (1M context) --- json-rpc-server.cabal | 18 ++++++++---------- src/Network/JsonRpc/Server.hs | 11 ++++++----- src/Network/JsonRpc/Types.hs | 23 ++++++++++++----------- tests/Internal.hs | 11 ++++++----- tests/TestSuite.hs | 9 +++++---- 5 files changed, 37 insertions(+), 35 deletions(-) diff --git a/json-rpc-server.cabal b/json-rpc-server.cabal index a5a8a09..b1ac158 100644 --- a/json-rpc-server.cabal +++ b/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 diff --git a/src/Network/JsonRpc/Server.hs b/src/Network/JsonRpc/Server.hs index 1fbd102..377fe7a 100644 --- a/src/Network/JsonRpc/Server.hs +++ b/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 diff --git a/src/Network/JsonRpc/Types.hs b/src/Network/JsonRpc/Types.hs index bb7e71a..e5d5e0b 100644 --- a/src/Network/JsonRpc/Types.hs +++ b/src/Network/JsonRpc/Types.hs @@ -23,9 +23,10 @@ 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 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,7 +69,7 @@ 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 @@ -92,15 +93,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 +110,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 +123,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. diff --git a/tests/Internal.hs b/tests/Internal.hs index dc9ec25..daefef9 100644 --- a/tests/Internal.hs +++ b/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 diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index e68c2a3..04c920e 100644 --- a/tests/TestSuite.hs +++ b/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,8 @@ 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 $ KM.adjust removeMsg (AK.fromText "error") rsp + where 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 From 3f7ad977df19931739baccdf5d01111546e16e59 Mon Sep 17 00:00:00 2001 From: Anatolii Prylutskyi Date: Mon, 9 Feb 2026 20:19:46 +0200 Subject: [PATCH 2/3] Fix KM.adjust removal in aeson 2.2.x test suite Data.Aeson.KeyMap no longer exports adjust in aeson 2.2.x. Replace with KM.lookup + KM.insert pattern. --- tests/TestSuite.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/tests/TestSuite.hs b/tests/TestSuite.hs index 04c920e..c0124ea 100644 --- a/tests/TestSuite.hs +++ b/tests/TestSuite.hs @@ -186,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 $ KM.adjust removeMsg (AK.fromText "error") rsp - where removeMsg (A.Object err) = A.Object $ KM.insert (AK.fromText "message") "" $ KM.delete (AK.fromText "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 From acdc0ac8726ef84978aaa2243be30fcf6c5281d8 Mon Sep 17 00:00:00 2001 From: Anatolii Prylutskyi Date: Fri, 6 Mar 2026 10:57:00 +0200 Subject: [PATCH 3/3] Use iparse/IResult for JSONPath tracking in parseArg Previously, parseArg used A.fromJSON which discards the JSONPath accumulated by (.:) and withObject, producing bare error strings like "expected Number, got String". Switch to iparse/IResult/formatError so that the full path is included in the error: "Error in $.products[0].price: expected Number, got String". This makes JSON-RPC -32602 errors actionable without guessing which field caused the failure. --- src/Network/JsonRpc/Types.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/src/Network/JsonRpc/Types.hs b/src/Network/JsonRpc/Types.hs index e5d5e0b..1b43a27 100644 --- a/src/Network/JsonRpc/Types.hs +++ b/src/Network/JsonRpc/Types.hs @@ -23,6 +23,7 @@ import Data.Maybe (catMaybes) import Data.Text (Text, append, unpack) import qualified Data.Aeson as A import Data.Aeson ((.=), (.:), (.:?), (.!=)) +import Data.Aeson.Types (iparse, IResult (..), formatError) import qualified Data.Vector as V import qualified Data.Aeson.Key as AK @@ -74,9 +75,9 @@ instance (A.FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) 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