A simple Haskell JSON-RPC server implementation using Existential Type and Monad stack

JSON-RPC.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
module JSON_RPC where 

import ReadExcept
import Web.Scotty hiding (params)
import Data.Map                  
import Data.Aeson
import Network.Wai
import Control.Monad             as M
import qualified Data.Text       as T
import Prelude hiding (lookup)

data Req = Req { 
      reqId :: String
  , jsonrpc :: String
  ,  method :: String
  ,  params :: Maybe Value
} deriving (Show, Read, Eq)

instance FromJSON Req where
  parseJSON = withObject "Reguest" $ \v -> Req <$>
                        v .: "id" <*>
                        v .: "jsonrpc" <*>
                        v .: "method" <*>
                        v .: "params"

data RawResp    = RawOk String Value 
                | RawError String Int String (Maybe Value)

instance ToJSON RawResp where 
  toJSON (RawOk rid result) = object ["jsonrpc" .= v2, "id" .= rid, "result" .= result ]
  toJSON (RawError rid code msg d) = 
    object ["jsonrpc" .= v2, "id" .= rid, "error" .= 
      object [ "code" .= code, "message" .= msg, "data" .= d ]]

v2 = "2.0" :: T.Text

parseError = RawError "" (-32700) "Parse error" Nothing
invalidReq = RawError "" (-32600) "Invalid Request" Nothing
methodNotFound    req = RawError (reqId req) (-32601) "Method not found" Nothing
invalidParams msg req = RawError (reqId req) (-32602) ("Invalid params " ++ msg) Nothing
interError    msg req = RawError (reqId req) (-32603) ("Internal error "  ++ msg) Nothing

--------------------------------------------------------------------------------
-- The type of responses using existential type 
--------------------------------------------------------------------------------
data Ok    = forall a. (ToJSON a) => Ok a Req
data Error = ParseError
             | MethodNotFound Req 
             | InvalidParams String Req 
             | InterError String Req
             deriving (Show, Read, Eq)

type Resp = Either Error Ok

toRaw :: Resp -> RawResp
toRaw = either toRawError toRawOk
  where toRawOk (Ok a req) = RawOk (reqId req) (toJSON a)
        toRawError = \case 
                ParseError            -> parseError
                MethodNotFound req    -> methodNotFound    req
                InvalidParams msg req -> invalidParams msg req
                InterError    msg req -> interError    msg req

----------------------------------------------------------------------------------
---- RPC dispatcher using hetegeneous list
----------------------------------------------------------------------------------
data Handler = forall a b. (FromJSON a, ToJSON b) => Func (a -> b) 
             | forall a  . (ToJSON a) => Const a

type Handlers = Map String Handler

dispatch :: (MonadReader Req m, MonadError Error m) => Handlers -> m Ok
dispatch xs = do
  methodName <- reader method 
  h <- MethodNotFound `withReadMaybe_` lookup methodName xs
  case h of Const a -> reader (Ok a)
            Func  f -> do
              v <- InvalidParams "" `withReadMaybe` params 
              a <- InvalidParams    `withReadResult` fromJSON v
              reader $ Ok (f a)
--------------------------------------------------------------------------------
-- Example 
--
handlers = fromList
  [("Add", Func (uncurry (+) :: (Int, Int) -> Int)), 
   ("Mod", Func (uncurry mod :: (Int, Int) -> Int)),
   ("True",  Func (const True :: () -> Bool))]

main :: IO ()
main = scotty 3000 $ do
  get "/:word" $ do
    beam <- param "word"
    html $ mconcat ["<h1>Scotty, ", beam, " me up!</h1>"]

  post "/api" $ do
    setHeader "Content-Type" "application/json"
    b <- body
    raw . encode $ case (decode b :: Maybe Req) of
      Nothing  -> parseError 
      Just req -> toRaw $ runExcept $ runReaderT (dispatch handlers) req