Cleanup

Author: sebright

src/Network/JsonRpc/Server.hs

@@ -102,14 +102,14 @@ callWithBatchStrategy strategy fs input = either returnErr callMethod request
           parseJson = maybe invalidJson return . A.decode
           parseVal val = case val of
                            obj@(A.Object _) -> return $ Left obj
-                           A.Array vec | V.null vec -> throwError $ invalidRpcError "Empty batch request"
-                                     | otherwise -> return $ Right $ V.toList vec
-                           _ -> throwError $ invalidRpcError "Not a JSON object or array"
+                           A.Array vec | V.null vec -> throwInvalidRpc "Empty batch request"
+                                       | otherwise -> return $ Right $ V.toList vec
+                           _ -> throwInvalidRpc "Not a JSON object or array"
           callMethod rq = case rq of
                             Left val -> encodeJust `liftM` singleCall fs val
                             Right vals -> encodeJust `liftM` batchCall strategy fs vals
-              where encodeJust r = (A.encode . A.toJSON) <$> r
-          returnErr = return . Just . A.encode . A.toJSON . nullIdResponse
+              where encodeJust r = A.encode <$> r
+          returnErr = return . Just . A.encode . nullIdResponse
           invalidJson = throwError $ rpcError (-32700) "Invalid JSON"
 
 singleCall :: Monad m => Methods m -> A.Value -> m (Maybe Response)
@@ -126,15 +126,15 @@ nullIdResponse err = toResponse (Just IdNull) (Left err :: Either RpcError ())
 
 parseValue :: (A.FromJSON a, Monad m) => A.Value -> RpcResult m a
 parseValue val = case A.fromJSON val of
-                   A.Error msg -> throwError $ invalidRpcError $ pack msg
+                   A.Error msg -> throwInvalidRpc $ pack msg
                    A.Success x -> return x
 
 lookupMethod :: Monad m => Text -> H.HashMap Text (Method m) -> RpcResult m (Method m)
 lookupMethod name = maybe notFound return . H.lookup name
-    where notFound = throwError $ rpcError (-32601) ("Method not found: " `append` name)
+    where notFound = throwError $ rpcError (-32601) $ "Method not found: " `append` name
 
-invalidRpcError :: Text -> RpcError
-invalidRpcError = rpcErrorWithData (-32600) "Invalid JSON RPC 2.0 request"
+throwInvalidRpc :: Monad m => Text -> RpcResult m a
+throwInvalidRpc = throwError . rpcErrorWithData (-32600) "Invalid JSON RPC 2.0 request"
 
 batchCall :: Monad m => (forall a. [m a] -> m [a])
           -> Methods m

src/Network/JsonRpc/Types.hs

@@ -3,7 +3,6 @@
              FlexibleInstances,
              UndecidableInstances,
              TypeOperators,
-             PatternGuards,
              OverloadedStrings #-}
 
 module Network.JsonRpc.Types ( RpcResult
@@ -55,9 +54,9 @@ class (Monad m, Functor m, A.ToJSON r) => MethodParams f p m r | f -> p m r wher
     apply :: f -> p -> Args -> RpcResult m r
 
 instance (Monad m, Functor m, A.ToJSON r) => MethodParams (RpcResult m r) () m r where
-    apply r _ args | Left _ <- args = r
-                   | Right ar <- args, V.null ar = r
-                   | otherwise = throwError $ rpcError (-32602) "Too many unnamed arguments"
+    apply _ _ (Right ar) | not $ V.null ar =
+                             throwError $ rpcError (-32602) "Too many unnamed arguments"
+    apply res _ _ = res
 
 instance (A.FromJSON a, MethodParams f p m r) => MethodParams (a -> f) (a :+: p) m r where
     apply f (param :+: ps) args = arg >>= \a -> apply (f a) ps nextArgs
@@ -81,15 +80,16 @@ tailOrEmpty vec = if V.null vec then V.empty else V.tail vec
 
 parseArg :: (Monad m, A.FromJSON r) => Text -> A.Value -> RpcResult m r
 parseArg name val = case A.fromJSON val of
-                      A.Error msg -> throwError $ rpcErrorWithData (-32602) ("Wrong type for argument: " `append` name) msg
+                      A.Error msg -> throwError $ argTypeError msg
                       A.Success x -> return x
+    where argTypeError = rpcErrorWithData (-32602) $ "Wrong type for argument: " `append` name
 
 paramDefault :: Monad m => Parameter a -> RpcResult m a
 paramDefault (Optional _ d) = return d
 paramDefault (Required name) = throwError $ missingArgError name
 
 missingArgError :: Text -> RpcError
-missingArgError name = rpcError (-32602) ("Cannot find required argument: " `append` name)
+missingArgError name = rpcError (-32602) $ "Cannot find required argument: " `append` name
 
 paramName :: Parameter a -> Text
 paramName (Optional n _) = n
@@ -114,7 +114,8 @@ instance A.FromJSON Request where
         where parseParams (A.Object obj) = return $ Left obj
               parseParams (A.Array ar) = return $ Right ar
               parseParams _ = empty
-              checkVersion ver = when (ver /= jsonRpcVersion) (fail $ "Wrong JSON RPC version: " ++ unpack ver)
+              checkVersion ver = when (ver /= jsonRpcVersion) $
+                            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 ->