Re: [Haskell-cafe] Designing somewhat-type-safe RPC

3 Jan 2014

      On Thu, 2014-01-02 at 21:30 +0100, Nicolas Trangez wrote:
...
Hi,
While working on the design of an RPC library (for an existing
protocol), I got somewhat stuck.
The system is fairly simple: for some call, a client first sends an
identifier of the call, followed by a serialized form of the argument.
Then the server returns some serialized result.
A server exposes several procedures, all taking a certain argument type
and returning a certain result type.
I figured out how to get my intentions into working code thanks to the
input of John Lato (which got me to the correct type signature... I
always have troubles with those RankN types) and Oleg (for using an
existential type in his solution. I tried that before, but must have
done something wrong). Thanks!

The end result only uses GADTs and Rank2Types, so I think that's fairly
reasonable. Code below.

Regards,

Nicolas

{-# LANGUAGE Rank2Types, GADTs #-}
{-# OPTIONS_GHC -Wall #-}

module RPC2 where

import Data.Word (Word32)
import Data.Binary (Binary, decode, encode)
import Control.Monad (forever)
import Control.Monad.IO.Class (MonadIO(liftIO))

import System.IO (hFlush, stdout)

-- Library code

-- Not exported, use `procedure` instead
data SomeProcedure a =
    forall req res. (Binary req, Binary res) => SomeProcedure (a req
res)

class RPC a where
    rpcProcedureId :: a req res -> Word32
    rpcProcedure :: Word32 -> Maybe (SomeProcedure a)

procedure :: (Binary req, Binary res) => a req res -> Maybe
(SomeProcedure a)
procedure = Just . SomeProcedure

runServer :: (MonadIO m, RPC call) => (forall req res. call req res ->
req -> m res) -> m ()
runServer handler = forever $ do
    -- Read tag from network
    tag <- liftIO $ do
        putStr "Procedure tag: " >> hFlush stdout
        read `fmap` getLine

    case rpcProcedure tag of
        Nothing -> liftIO $ putStrLn "Unknown procedure!" -- TODO Handle
correctly
        Just (SomeProcedure c) -> do
            -- Read request data from network
            input <- recvData 
            let req = decode input

            res <- handler c req

            let res' = encode res
            -- Write result to network
            liftIO $ putStrLn $ "Result data: " ++ show res'
  where
    -- Fake data coming from network
    -- (Note: when the request is 'Ping', `()` can be read from this as
    -- well)
    recvData = return $ encode (1 :: Word32, 2 :: Word32)

-- API user code
data Service req res where
    Ping :: Service () ()
    Add :: Service (Word32, Word32) Word32

instance RPC Service where
    rpcProcedureId p = case p of
        Ping -> 0
        Add -> 1
    rpcProcedure i = case i of
        0 -> procedure Ping
        1 -> procedure Add
        _ -> Nothing

serviceHandler :: Service req res -> req -> IO res
serviceHandler call req = case call of
    Ping -> putStrLn $ "Ping " ++ show req
    Add -> do
        putStrLn $ "Add " ++ show req
        return (fst req + snd req)

main :: IO ()
main = runServer serviceHandler