Sketch of well-typed RPC

RPC.hs

{-# language DataKinds, GADTs, ScopedTypeVariables #-}
{-# language RankNTypes, TypeApplications #-}
{-# language LambdaCase #-}
{-# language ImplicitParams #-}
module Server where

import Data.Bifunctor (first)
import Data.ByteString (ByteString)
import Data.Proxy
import Data.Serialize
import Data.Serialize.Text
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Type.Equality
import GHC.Generics
import GHC.TypeLits

data Registered a b where
  Registered ::
    ( Serialize a
    , Serialize b
    ) =>
    (a -> b) ->
    Registered a b

newtype Registry name where
  Registry :: (forall a b. name a b -> Registered a b) -> Registry name

withEntry ::
  name a b ->
  Registry name ->
  ((Serialize a, Serialize b) => (a -> b) -> r) ->
  r
withEntry n (Registry lookup) k = case lookup n of; Registered f -> k f

data RPCError where
  DecodeError :: String -> RPCError

decodeAndRunCall ::
  GSerialize2 name =>
  Registry name ->
  (ByteString, ByteString) ->
  Either RPCError ByteString
decodeAndRunCall reg (bsName, bsArg) = do
  Some2 (name :: name a b) <- first DecodeError $ runGet gget2 bsName
  withEntry name reg $ \f -> do
    a :: a <- first DecodeError $ decode bsArg
    let b = f a
    pure $ encode b

encodeCall ::
  (GSerialize2 name, Serialize a) =>
  Registry name ->
  name a b ->
  a ->
  (ByteString, ByteString)
encodeCall reg name a =
  withEntry name reg $ \_ -> (runPut $ gput2 name, encode a)

data MyName a b where
  MyAdd :: MyName (Int, Int) Int
  MyMult :: MyName (Int, Int) Int
  MyNot :: MyName Bool Bool

data Some2 f where
  Some2 :: f a b -> Some2 f

class GSerialize2 f where
  gget2 :: Get (Some2 f)
  gput2 :: Putter (f a b)

instance GSerialize2 MyName where
  gget2 = do
    tag <- get @Word
    case tag of
      0 -> pure $ Some2 MyAdd
      1 -> pure $ Some2 MyMult
      2 -> pure $ Some2 MyNot
      _ -> fail $ "Invalid tag: " <> show tag
  gput2 n =
    case n of
      MyAdd -> put @Word 0
      MyMult -> put @Word 1
      MyNot -> put @Word 2

myRegistry :: Registry MyName
myRegistry =
  Registry $
  \case
    MyAdd -> Registered $ uncurry (+)
    MyMult -> Registered $ uncurry (*)
    MyNot -> Registered not

testEncodeCall :: (ByteString, ByteString)
testEncodeCall =
  encodeCall myRegistry MyAdd (1, 2)

data Connection

call ::
  ( ?conn :: Connection, ?reg :: Registry name
  , GSerialize2 name, Serialize a, Serialize b
  ) =>
  name a b ->
  a ->
  IO b
call name a = do
  res <- _ $ encodeCall ?reg name a
  either error pure (decode =<< res)