Stateful RPC example

typed-protocols-examples/src/Network/TypedProtocol/ReqResp/Codec.hs

@@ -39,12 +39,12 @@ codecReqResp =
       decodeTerminatedFrame '\n' $ \str trailing ->
         case (stok, break (==' ') str) of
           (SingIdle, ("MsgReq", str'))
-             | Just resp <- readMaybe str'
-            -> DecodeDone (SomeMessage (MsgReq resp)) trailing
+             | Just req <- readMaybe str'
+            -> DecodeDone (SomeMessage (MsgReq req)) trailing
           (SingIdle, ("MsgDone", ""))
             -> DecodeDone (SomeMessage MsgDone) trailing
           (SingBusy, ("MsgResp", str'))
-             | Just resp <- readMaybe str'
+            | Just resp <- readMaybe str'
             -> DecodeDone (SomeMessage (MsgResp resp)) trailing
 
           (_       , _     ) -> DecodeFail failure

typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Client.hs

@@ -1,52 +1,42 @@
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE GADTs               #-}
-{-# LANGUAGE KindSignatures      #-}
 {-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeOperators       #-}
 
 module Network.TypedProtocol.Stateful.ReqResp.Client
-  ( -- * Non-Pipelined Client
-    ReqRespClient (..)
+  ( ReqRespClient (..)
   , reqRespClientPeer
   ) where
 
-import           Data.Kind (Type)
-
-import           Network.TypedProtocol.ReqResp.Type
+import           Data.Typeable
 import           Network.TypedProtocol.Stateful.Peer.Client
+import           Network.TypedProtocol.Stateful.ReqResp.Type
 
+data ReqRespClient req m a where
+  SendMsgReq  :: Typeable resp
+              => req resp
+              -> (resp -> m (ReqRespClient req m a))
+              -> ReqRespClient req m a
 
-data ReqRespClient req resp (f :: ReqResp req resp -> Type) m a where
-  SendMsgReq  :: f StBusy
-              -> req
-              -> (f StBusy -> resp -> ( m (ReqRespClient req resp f m a)
-                                      , f StIdle
-                                      ))
-              -> ReqRespClient req resp f m a
-
-  SendMsgDone :: f StDone
-              -> m a
-              -> ReqRespClient req resp f m a
+  SendMsgDone :: a
+              -> ReqRespClient req m a
 
 
 reqRespClientPeer
   :: Monad m
-  => ReqRespClient req resp f m a
-  -> Client  (ReqResp req resp) StIdle f m a
-
-reqRespClientPeer (SendMsgDone f result) =
-    Effect $ do
-      r <- result
-      return $ Yield f MsgDone (Done r)
-
-reqRespClientPeer (SendMsgReq f req next) =
-    Yield f (MsgReq req) $
-    Await $ \f' (MsgResp resp) ->
-      case next f' resp of
-        (client, f'') ->
-          ( Effect $ reqRespClientPeer <$> client
-          , f''
-          )
+  => ReqRespClient req m a
+  -> Client (ReqResp req) StIdle State m a
+
+reqRespClientPeer (SendMsgDone a) =
+      Yield StateDone MsgDone (Done a)
+
+reqRespClientPeer (SendMsgReq req next) =
+    Yield (StateBusy req)
+          (MsgReq req) $
+    Await $ \_ (MsgResp resp) ->
+      let client = next resp
+      in ( Effect $ reqRespClientPeer <$> client
+         , StateIdle
+         )

typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Codec.hs

@@ -0,0 +1,114 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE NamedFieldPuns      #-}
+{-# LANGUAGE PolyKinds           #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module Network.TypedProtocol.Stateful.ReqResp.Codec where
+
+import           Data.Kind (Type)
+import           Data.Singletons.Decide
+import           Data.Typeable
+import           Network.TypedProtocol.Core
+import           Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame)
+import           Network.TypedProtocol.Stateful.Codec
+import           Network.TypedProtocol.Stateful.ReqResp.Type
+
+data Some (f :: k -> Type) where
+    Some :: Typeable a => f a -> Some f
+
+
+-- | Codec polymorphic in the RPC (e.g. `req` type)
+--
+codecReqResp
+  :: forall req m. Monad m
+  => (forall resp. req resp -> String)
+  -- ^ encode `req resp`
+  -> (String -> Maybe (Some req))
+  -- ^ decode `req resp`
+  -> (forall resp. resp -> String)
+  -- ^ encode resp
+  -> (forall resp. req resp -> String -> Maybe resp)
+  -- ^ decode resp
+  -> Codec (ReqResp req) CodecFailure State m String
+codecReqResp encodeReq decodeReq encodeResp decodeResp =
+    Codec { encode, decode }
+  where
+    encode :: State st'
+           -> Message (ReqResp req) st st'
+           -> String
+    encode _ (MsgReq req)   = "MsgReq " ++ encodeReq req ++ "\n"
+    encode _ MsgDone        = "MsgDone\n"
+    encode _ (MsgResp resp) = "MsgResp " ++ encodeResp resp ++ "\n"
+
+    decode :: forall (st :: ReqResp req).
+              ActiveState st
+           => StateToken st
+           -> State st
+           -> m (DecodeStep String CodecFailure m (SomeMessage st))
+    decode stok state =
+      decodeTerminatedFrame '\n' $ \str trailing ->
+        case (stok, state, break (==' ') str) of
+          (SingIdle, StateIdle, ("MsgReq", str'))
+            |  Just (Some req) <- decodeReq str'
+            -> DecodeDone (SomeMessage (MsgReq req)) trailing
+          (SingIdle, StateIdle, ("MsgDone", ""))
+            -> DecodeDone (SomeMessage MsgDone) trailing
+          (SingBusy, StateBusy req, ("MsgResp", str'))
+            -- note that we need `req` to decode response of the given type
+            |  Just resp <- decodeResp req str'
+            -> DecodeDone (SomeMessage (MsgResp resp)) trailing
+          (_, _, _) -> DecodeFail failure
+            where failure = CodecFailure ("unexpected server message: " ++ str)
+
+
+data Bytes where
+    Bytes :: Message (ReqResp FileAPI) st st' -> Bytes
+
+-- | An identity codec which wraps messages into `AnyMessage`.
+--
+codecReqRespId
+  :: forall m.
+     Applicative m
+  => (forall (res1 :: Type) (res2 :: Type).
+           (Typeable res1, Typeable res2)
+        => Proxy res1
+        -> Proxy res2
+        -> Maybe (res1 :~: res2)
+     )
+  -> Codec FileRPC String State m Bytes
+codecReqRespId eqRespTypes = Codec { encode, decode }
+  where
+    encode _ = Bytes
+
+    decode :: forall (st :: ReqResp FileAPI).
+              ActiveState st
+           => StateToken st
+           -> State st
+           -> m (DecodeStep Bytes String m (SomeMessage st))
+    decode stok state = pure $ DecodePartial $ \bytes -> pure $
+      case (stok, state, bytes) of
+        (SingIdle, StateIdle, Just (Bytes msg@MsgDone))
+          -> DecodeDone (SomeMessage msg) Nothing
+        (SingIdle, StateIdle, Just (Bytes msg@MsgReq{}))
+          -> DecodeDone (SomeMessage msg) Nothing
+        (SingBusy, StateBusy req, Just (Bytes msg@(MsgResp _)))
+          -- the codec needs to verify that response type of `req` and `msg` agrees
+          |  Just Refl <- eqRespTypes (reqRespType req) (msgRespType msg)
+          -> DecodeDone (SomeMessage msg) Nothing
+
+        (SingDone, _, _) -> notActiveState stok
+        (_, _, Nothing) -> DecodeFail "no bytes"
+        (_, _, _) -> DecodeFail "no matching message"
+
+    msgRespType :: forall resp. Message (ReqResp FileAPI) (StBusy resp) StIdle
+                -> Proxy resp
+    msgRespType (MsgResp _) = Proxy
+
+    reqRespType :: forall resp. FileAPI resp -> Proxy resp
+    reqRespType _ = Proxy
+
+

typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Examples.hs

@@ -2,49 +2,32 @@
 {-# LANGUAGE GADTs               #-}
 {-# LANGUAGE NamedFieldPuns      #-}
 {-# LANGUAGE PolyKinds           #-}
+{-# LANGUAGE RankNTypes          #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Network.TypedProtocol.Stateful.ReqResp.Examples
-  ( ReqRespStateCallbacks (..)
-  , reqRespClientMap
-  ) where
+module Network.TypedProtocol.Stateful.ReqResp.Examples where
 
-import           Data.Kind (Type)
+import           Network.TypedProtocol.Stateful.ReqResp.Server
+import           Network.TypedProtocol.Stateful.ReqResp.Type
 
-import           Network.TypedProtocol.ReqResp.Type
-import           Network.TypedProtocol.Stateful.ReqResp.Client
 
+fileRPCServer :: Monad m
+              => (forall resp. FileAPI resp -> m resp)
+              -- ^ execute `FileAPI` locally
+              -> ReqRespServer FileAPI m ()
+fileRPCServer run = ReqRespServer {
+    reqRespServerDone = (),
+    reqRespHandleReq = \req -> do
+      resp <- run req
+      return (resp, fileRPCServer run)
+  }
 
-data ReqRespStateCallbacks (f :: ReqResp req resp -> Type) =
-    ReqRespStateCallbacks {
-        rrBusyToIdle :: f StBusy -> f StIdle
-      , rrBusyToBusy :: f StBusy -> f StBusy
-      , rrBusyToDone :: f StBusy -> f StDone
-      }
+-- | Example of a file API
+--
+simpleFileAPI :: Monad m => FileAPI resp -> m resp
+simpleFileAPI (ReadFile filepath) = return filepath
+simpleFileAPI (WriteFile _ _)     = return ()
 
-reqRespClientMap
-  :: forall req resp f m.
-     Monad m
-  => ReqRespStateCallbacks f
-  -> f StBusy
-  -> [req]
-  -> ReqRespClient req resp f m ([resp], f StDone)
-reqRespClientMap ReqRespStateCallbacks
-                           { rrBusyToIdle
-                           , rrBusyToBusy
-                           , rrBusyToDone
-                           } = go []
-  where
-    go :: [resp]
-       -> f StBusy
-       -> [req]
-       -> ReqRespClient req resp f m ([resp], f StDone)
-    go resps f []         = SendMsgDone f' (pure (reverse resps, f'))
-      where
-        f' = rrBusyToDone f
-    go resps f (req:reqs) =
-      SendMsgReq f req $ \f' resp ->
-        ( return (go (resp:resps) (rrBusyToBusy f') reqs)
-        , rrBusyToIdle f'
-        )
+simpleFileRPCServer :: Monad m => ReqRespServer FileAPI m ()
+simpleFileRPCServer = fileRPCServer simpleFileAPI
 

typed-protocols-examples/src/Network/TypedProtocol/Stateful/ReqResp/Server.hs

@@ -0,0 +1,36 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE GADTs               #-}
+{-# LANGUAGE LambdaCase          #-}
+{-# LANGUAGE PolyKinds           #-}
+{-# LANGUAGE RankNTypes          #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+module Network.TypedProtocol.Stateful.ReqResp.Server
+  ( ReqRespServer (..)
+  , reqRespServerPeer
+  ) where
+
+import           Data.Typeable
+import           Network.TypedProtocol.Stateful.Peer.Server
+import           Network.TypedProtocol.Stateful.ReqResp.Type
+
+
+data ReqRespServer req m a = ReqRespServer {
+    reqRespServerDone :: a,
+    reqRespHandleReq  :: forall resp. Typeable resp => req resp -> m (resp, ReqRespServer req m a)
+  }
+
+reqRespServerPeer :: Functor m
+                  => ReqRespServer req m a
+                  -> Server (ReqResp req) StIdle State m a
+reqRespServerPeer ReqRespServer { reqRespServerDone = a,
+                                  reqRespHandleReq  = k } =
+  Await $ \_ -> \case
+    MsgDone -> (Done a, StateDone)
+    MsgReq req ->
+      ( Effect $
+              (\(resp, k') -> Yield StateIdle (MsgResp resp) (reqRespServerPeer  k'))
+          <$> k req
+      , StateBusy req
+      )