Skip to content

Commit a5b458b

Browse files
grayjaygrayjay
committed
Replaced ErrorT with ExceptT.
1 parent ee86944 commit a5b458b

File tree

5 files changed

+35
-55
lines changed

5 files changed

+35
-55
lines changed

‎.travis.yml

Lines changed: 11 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -21,16 +21,16 @@ env:
2121
# - CABALVER=1.16 GHCVER=7.4.2
2222
# - CABALVER=1.16 GHCVER=7.6.1
2323
- CABALVER=1.18 GHCVER=7.6.2 AESONVER=0.7.0.4
24-
- CABALVER=1.18 GHCVER=7.6.3 AESONVER=0.8.0.2
24+
# - CABALVER=1.18 GHCVER=7.6.3
2525
# - CABALVER=1.18 GHCVER=7.8.1
2626
# - CABALVER=1.18 GHCVER=7.8.2
27-
# - CABALVER=1.18 GHCVER=7.8.3
28-
- CABALVER=1.22 GHCVER=7.10.1
29-
# - CABALVER=head GHCVER=head
30-
- CABALVER=1.18 HPVER=2014.2.0.0
27+
- CABALVER=1.18 GHCVER=7.8.3 AESONVER=0.8.0.2
28+
- CABALVER=1.22 GHCVER=7.10.1 AESONVER=0.9.0.0
29+
- CABALVER=head GHCVER=head
30+
# - CABALVER=1.18 HPVER=2014.2.0.0
3131
# - HPVER=2013.2.0.0
3232
# - HPVER=2012.4.0.0
33-
- CABALVER=1.18 HPVER=2012.2.0.0
33+
# - CABALVER=1.18 HPVER=2012.2.0.0
3434
# - HPVER=2011.4.0.0
3535

3636
# Note: the distinction between `before_install` and `install` is not
@@ -71,7 +71,7 @@ before_install:
7171
fi
7272

7373
if [ "$AESONVER" = "0.6.0.0" ]; then
74-
echo "constraints:attoparsec==0.8.6.1,blaze-builder==0.2.1.4,bytestring==0.9.1.8,hashable==1.1.2.0,mtl==1.1.1.0,network==2.3.0.1,test-framework-hunit==0.3.0,text==0.11.1.1,unordered-containers==0.1.3.0,vector==0.7.1,zlib==0.5.2.0" >> cabal.config;
74+
echo "constraints:attoparsec==0.8.6.1,blaze-builder==0.2.1.4,bytestring==0.9.1.8,hashable==1.1.2.0,mtl==2.2.1,network==2.3.0.1,test-framework-hunit==0.3.0,text==0.11.1.1,unordered-containers==0.1.3.0,vector==0.7.1,zlib==0.5.2.0" >> cabal.config;
7575
fi
7676

7777
- travis_retry sudo add-apt-repository -y ppa:hvr/ghc
@@ -118,4 +118,8 @@ script:
118118
- cd ..;
119119
cabal install -f demo;
120120

121+
matrix:
122+
allow_failures:
123+
- env: CABALVER=head GHCVER=head
124+
121125
# EOF

‎demo/Demo.hs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ import Data.List (intercalate)
99
import Data.Maybe (fromMaybe)
1010
import Control.Monad (forM_, when)
1111
import Control.Monad.Trans (liftIO)
12-
import Control.Monad.Error (throwError)
12+
import Control.Monad.Except (throwError)
1313
import Control.Monad.Reader (ReaderT, ask, runReaderT)
1414
import Control.Concurrent.MVar (MVar, newMVar, modifyMVar)
1515

‎json-rpc-server.cabal

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@
22
-- documentation, see http://haskell.org/cabal/users-guide/
33

44
name: json-rpc-server
5-
version: 0.1.6.0
5+
version: 0.2.0.0
66
license: MIT
77
license-file: LICENSE
88
category: Network, JSON
@@ -38,7 +38,7 @@ library
3838
aeson >=0.6 && <0.10,
3939
deepseq >= 1.1 && <1.5,
4040
bytestring >=0.9 && <0.11,
41-
mtl >=1.1.1 && <2.3,
41+
mtl >=2.2.1 && <2.3,
4242
text >=0.11 && <1.3,
4343
vector >=0.7.1 && <0.11,
4444
unordered-containers >=0.1 && <0.3
@@ -52,7 +52,7 @@ executable demo
5252
build-depends: base >=4.3 && <4.9,
5353
json-rpc-server,
5454
bytestring >=0.9 && <0.11,
55-
mtl >=1.1.1 && <2.3
55+
mtl >=2.2.1 && <2.3
5656
else
5757
buildable: False
5858

@@ -68,7 +68,7 @@ test-suite tests
6868
test-framework-hunit >=0.3 && <0.4,
6969
aeson >=0.6 && <0.10,
7070
bytestring >=0.9 && <0.11,
71-
mtl >=1.1.1 && <2.3,
71+
mtl >=2.2.1 && <2.3,
7272
text >=0.11 && <1.3,
7373
vector >=0.7.1 && <0.11,
7474
unordered-containers >=0.1 && <0.3

‎src/Network/JsonRpc/Server.hs

Lines changed: 4 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -4,10 +4,6 @@
44
TypeOperators,
55
OverloadedStrings #-}
66

7-
#if MIN_VERSION_mtl(2,2,1)
8-
{-# OPTIONS_GHC -fno-warn-deprecations #-}
9-
#endif
10-
117
-- | Functions for implementing the server side of JSON-RPC 2.0.
128
-- See <http://www.jsonrpc.org/specification>.
139
module Network.JsonRpc.Server (
@@ -46,7 +42,7 @@ import qualified Data.HashMap.Strict as H
4642
import Control.DeepSeq (NFData)
4743
import Control.Monad (liftM)
4844
import Control.Monad.Identity (runIdentity)
49-
import Control.Monad.Error (runErrorT, throwError)
45+
import Control.Monad.Except (runExceptT, throwError)
5046

5147
#if !MIN_VERSION_base(4,8,0)
5248
import Control.Applicative ((<$>))
@@ -110,7 +106,7 @@ callWithBatchStrategy :: Monad m =>
110106
-- all wrapped in the given monad.
111107
callWithBatchStrategy strategy fs input = either returnErr callMethod request
112108
where request :: Either RpcError (Either A.Value [A.Value])
113-
request = runIdentity $ runErrorT $ parseVal =<< parseJson input
109+
request = runIdentity $ runExceptT $ parseVal =<< parseJson input
114110
parseJson = maybe invalidJson return . A.decode
115111
parseVal val = case val of
116112
obj@(A.Object _) -> return $ Left obj
@@ -128,9 +124,9 @@ singleCall :: Monad m => Methods m -> A.Value -> m (Maybe Response)
128124
singleCall (Methods fs) val = case parsed of
129125
Left err -> return $ nullIdResponse err
130126
Right (Request name args i) ->
131-
toResponse i `liftM` runErrorT (applyMethodTo args =<< method)
127+
toResponse i `liftM` runExceptT (applyMethodTo args =<< method)
132128
where method = lookupMethod name fs
133-
where parsed = runIdentity $ runErrorT $ parseValue val
129+
where parsed = runIdentity $ runExceptT $ parseValue val
134130
applyMethodTo args (Method _ f) = f args
135131

136132
nullIdResponse :: RpcError -> Maybe Response

‎src/Network/JsonRpc/Types.hs

Lines changed: 15 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -7,10 +7,6 @@
77
TypeSynonymInstances,
88
OverloadedStrings #-}
99

10-
#if MIN_VERSION_mtl(2,2,1)
11-
{-# OPTIONS_GHC -fno-warn-deprecations #-}
12-
#endif
13-
1410
module Network.JsonRpc.Types ( RpcResult
1511
, Method (..)
1612
, Methods (..)
@@ -24,7 +20,6 @@ module Network.JsonRpc.Types ( RpcResult
2420
, rpcError
2521
, rpcErrorWithData) where
2622

27-
import Data.String (fromString)
2823
import Data.Maybe (catMaybes)
2924
import Data.Text (Text, append, unpack)
3025
import qualified Data.Aeson as A
@@ -33,8 +28,8 @@ import Data.Aeson.Types (emptyObject)
3328
import qualified Data.Vector as V
3429
import qualified Data.HashMap.Strict as H
3530
import Control.DeepSeq (NFData, rnf)
36-
import Control.Monad (mplus, when)
37-
import Control.Monad.Error (Error, ErrorT, throwError, strMsg, noMsg)
31+
import Control.Monad (when)
32+
import Control.Monad.Except (ExceptT (..), throwError)
3833
import Prelude hiding (length)
3934
import Control.Applicative ((<|>), empty)
4035

@@ -44,7 +39,7 @@ import Control.Applicative ((<$>), (<*>), (*>))
4439

4540
-- | Return type of a method. A method call can either fail with an 'RpcError'
4641
-- or succeed with a result of type 'r'.
47-
type RpcResult m r = ErrorT RpcError m r
42+
type RpcResult m r = ExceptT RpcError m r
4843

4944
-- | Parameter expected by a method.
5045
data Parameter a
@@ -70,34 +65,23 @@ instance (Monad m, Functor m, A.ToJSON r) => MethodParams (RpcResult m r) () m r
7065
_apply res _ _ = res
7166

7267
instance (A.FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where
73-
_apply f (param :+: ps) args = arg >>= \a -> _apply (f a) ps nextArgs
74-
where arg = either (parseArg name) return =<<
75-
(Left <$> lookupValue) `mplus` (Right <$> paramDefault param)
76-
lookupValue = either (lookupArg name) (headArg name) args
77-
nextArgs = tailOrEmpty <$> args
78-
name = paramName param
79-
80-
lookupArg :: Monad m => Text -> A.Object -> RpcResult m A.Value
81-
lookupArg name hm = case H.lookup name hm of
82-
Nothing -> throwError $ missingArgError name
83-
Just v -> return v
84-
85-
headArg :: Monad m => Text -> A.Array -> RpcResult m A.Value
86-
headArg name vec | V.null vec = throwError $ missingArgError name
87-
| otherwise = return $ V.head vec
88-
89-
tailOrEmpty :: A.Array -> A.Array
90-
tailOrEmpty vec = if V.null vec then V.empty else V.tail vec
91-
92-
parseArg :: (Monad m, A.FromJSON r) => Text -> A.Value -> RpcResult m r
68+
_apply f (param :+: ps) args =
69+
ExceptT (return arg) >>= \a -> _apply (f a) ps nextArgs
70+
where
71+
arg = maybe (paramDefault param) (parseArg name) lookupValue
72+
lookupValue = either (H.lookup name) (V.!? 0) args
73+
nextArgs = V.drop 1 <$> args
74+
name = paramName param
75+
76+
parseArg :: A.FromJSON r => Text -> A.Value -> Either RpcError r
9377
parseArg name val = case A.fromJSON val of
9478
A.Error msg -> throwError $ argTypeError msg
9579
A.Success x -> return x
9680
where argTypeError = rpcErrorWithData (-32602) $ "Wrong type for argument: " `append` name
9781

98-
paramDefault :: Monad m => Parameter a -> RpcResult m a
99-
paramDefault (Optional _ d) = return d
100-
paramDefault (Required name) = throwError $ missingArgError name
82+
paramDefault :: Parameter a -> Either RpcError a
83+
paramDefault (Optional _ d) = Right d
84+
paramDefault (Required name) = Left $ missingArgError name
10185

10286
missingArgError :: Text -> RpcError
10387
missingArgError name = rpcError (-32602) $ "Cannot find required argument: " `append` name
@@ -175,10 +159,6 @@ data RpcError = RpcError { errCode :: Int
175159
instance NFData RpcError where
176160
rnf (RpcError e m d) = rnf e `seq` rnf m `seq` rnf d
177161

178-
instance Error RpcError where
179-
noMsg = strMsg "unknown error"
180-
strMsg msg = RpcError (-32000) (fromString msg) Nothing
181-
182162
instance A.ToJSON RpcError where
183163
toJSON (RpcError code msg data') = A.object pairs
184164
where pairs = catMaybes [ Just $ "code" .= code

0 commit comments

Comments
 (0)