Haskell JSON-RPC nested struct server example

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TemplateHaskell   #-}

-- The purpose of this RPC example is to show how to define a method using
-- JSON-RPC in Haskell without having to explicitly write the deserialization
-- code. It also shows at the same time that nested structs in the `params`
-- object in the RPC call are possible and even easy.
--
-- It is built off of the original json-rpc server example, found here:
-- https://hackage.haskell.org/package/json-rpc-0.3.0.1
--
-- It shows how to add new methods to the RPC server when you compare this
-- example to that one, since all I am doing here is adding an additional
-- RPC method, and otherwise leaving the code in that example untouched.

module Main where
import           Control.Monad
import           Control.Monad.Logger
import           Control.Monad.Trans
import           Data.Aeson.Types
import           Data.Aeson
import           Data.Conduit.Network
import qualified Data.Foldable        as F
import           Data.Maybe
import qualified Data.Text            as T
import           Data.Time.Clock
import           Data.Time.Format
import           Network.JSONRPC
import           GHC.Generics

-- This example adds the `add_me` method to the already-existing `ping` and
-- `time` methods.
--
-- The `add_me` method takes the following json blob thing as the body to the
-- `params` json rpc value:
--
--     {"a": <INT>, "b": <INT>, "c": {"x": <INT>, "y": <INT> }}
--
-- If the integers in that blob were named according to their key names,
-- then the `add_me` method computes (a + b + c), where c = x * y.j
--
-- This is done to show how a nested object can be deserialized in a relatively
-- painless way.
--
-- The way the json-rpc library deals with deserialization and serialization
-- is by asking the developer to define a sum type, with each constructor of
-- the sum type corresponding to one of the RPC methods which the server supports
-- A single sum type is defined for incoming requests and another sum type
-- is defined for the outgoing responses.
--
-- The key idea to make (de)serialization simple when using RPC is
-- that when the method in question needs parameters,
-- the serialization/deserialization code can be handed off to the compiler
-- by only allowing constructors in the sum type to have at most one member.

-- First, the types which will be deserialized from JSON:
data MultiplyMe = MultiplyMe { x :: Int, y :: Int} deriving (Show, Eq, Generic)
data AddMe = AddMe { a :: Int
                   , b :: Int
                   , c :: MultiplyMe } deriving (Show, Eq, Generic)

-- These are just "normal structs" so they can be deserialized in the
-- normal way. See http://hackage.haskell.org/package/aeson-1.4.1.0/docs/Data-Aeson.html#v:parseJSON
-- for more info.
instance FromJSON MultiplyMe
instance FromJSON AddMe

-- Now for the json-rpc code. We define a sum type, `req`, which will
-- allow us to tell the json-rpc library what types to deserialize the
-- "params" value to based on the name of the method.
--
-- The key point here is that when params for the rpc call needs to be
-- defined, I think it's best to add another constructor to the sum type
-- with only *one* member. The reason for this becomes clear
-- when we define the `instance FromRequest Req` below.
data Req = TimeReq
         | Ping
         | AddReq { addReqParams :: AddMe }
  deriving (Show, Eq)


-- Again, the `add_me` is what *I* added here, the "time" and "ping"
-- methods were already here.
-- The magic is that I here use `parseJSON` defined for the
-- `AddMe` type. I simply pass the json value on to it, then
-- return an instance of `AddReq` with its member taken from
-- that `parseJSON` call. This allows the compiler to write
-- the JSON parsing code, and us to reuse that code with
-- minimal boiler plate.
instance FromRequest Req where
    parseParams "time" = Just $ const $ return TimeReq
    parseParams "ping" = Just $ const $ return Ping
    parseParams "add_me" = Just $ \v -> do
          addMeInst <- parseJSON v
          return $ AddReq addMeInst
    parseParams _      = Nothing

-- Similarly to how I added an `AddReq` constructor to the previous sum type,
-- I add `AddRes` here, again with only one member.
data Res = Time { getTime :: UTCTime }
         | Pong
         | AddRes { addResult :: Int }
         deriving (Show, Eq)

-- Then, when it's time for deserialization code, we can simply pass the
-- member of the constructor on to the version of toJSON that's already
-- there. (If we were returning a struct, we'd have to define it above
-- using `instance ToJSON <structname>`, but I'm only returning an
-- Int here, the `toJSON` method for which is already defined in
-- `Data.Aeson`.)
instance ToJSON Res where
    toJSON (Time t) = toJSON $ formatTime defaultTimeLocale "%c" t
    toJSON Pong     = emptyArray
    toJSON (AddRes r) = toJSON r

respond :: MonadLoggerIO m => Respond Req m Res
respond TimeReq = (Right . Time) <$> liftIO getCurrentTime
respond Ping    = return $ Right Pong

-- Finally, we add to the `respond` method here, which
-- simply wraps up the actual function that we wish to run
-- (`(a + b + (x * y))` below) in the necessary type
-- constructors so that we can send the result off.
-- And that's about all there is to the modifications to the original
-- example. The rest of the code below can already be found
-- in that first example. Cheers :)
respond (AddReq (AddMe a b (MultiplyMe x y))) = return $ Right $
  AddRes $ (a + b + (x * y))

main :: IO ()
main = runStderrLoggingT $ do
    let ss = serverSettings 31337 "::1"
    jsonrpcTCPServer V2 False ss srv

srv :: MonadLoggerIO m => JSONRPCT m ()
srv = do
        $(logDebug) "listening for new request"
        qM <- receiveBatchRequest
        case qM of
            Nothing -> do
                $(logDebug) "closed request channel, exting"
                return ()
            Just (SingleRequest q) -> do
                $(logDebug) "got request"
                rM <- buildResponse respond q
                F.forM_ rM sendResponse
                srv
            Just (BatchRequest qs) -> do
                $(logDebug) "got request batch"
                rs <- catMaybes `liftM` forM qs (buildResponse respond)
                sendBatchResponse $ BatchResponse rs
                srv