Merge pull request #60 from input-output-hk/coot/stateful-req-resp

coot/stateful req resp

Author: coot

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

@@ -35,7 +35,7 @@ reqRespClientPeer (SendMsgDone a) =
 reqRespClientPeer (SendMsgReq req next) =
     Yield (StateBusy req)
           (MsgReq req) $
-    Await $ \_ (MsgResp resp) ->
+    Await $ \_ (MsgResp _ resp) ->
       let client = next resp
       in ( Effect $ reqRespClientPeer <$> client
          , StateIdle

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

@@ -29,7 +29,7 @@ codecReqResp
   -- ^ encode `req resp`
   -> (String -> Maybe (Some req))
   -- ^ decode `req resp`
-  -> (forall resp. resp -> String)
+  -> (forall resp. req resp -> resp -> String)
   -- ^ encode resp
   -> (forall resp. req resp -> String -> Maybe resp)
   -- ^ decode resp
@@ -40,9 +40,9 @@ codecReqResp encodeReq decodeReq encodeResp decodeResp =
     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"
+    encode _ (MsgReq req)       = "MsgReq " ++ encodeReq req ++ "\n"
+    encode _ MsgDone            = "MsgDone\n"
+    encode _ (MsgResp req resp) = "MsgResp " ++ encodeResp req resp ++ "\n"
 
     decode :: forall (st :: ReqResp req).
               ActiveState st
@@ -60,7 +60,7 @@ codecReqResp encodeReq decodeReq encodeResp decodeResp =
           (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
+            -> DecodeDone (SomeMessage (MsgResp req resp)) trailing
           (_, _, _) -> DecodeFail failure
             where failure = CodecFailure ("unexpected server message: " ++ str)
 
@@ -95,7 +95,7 @@ codecReqRespId eqRespTypes = Codec { encode, decode }
           -> DecodeDone (SomeMessage msg) Nothing
         (SingIdle, StateIdle, Just (Bytes msg@MsgReq{}))
           -> DecodeDone (SomeMessage msg) Nothing
-        (SingBusy, StateBusy req, Just (Bytes msg@(MsgResp _)))
+        (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
@@ -106,7 +106,7 @@ codecReqRespId eqRespTypes = Codec { encode, decode }
 
     msgRespType :: forall resp. Message (ReqResp FileAPI) (StBusy resp) StIdle
                 -> Proxy resp
-    msgRespType (MsgResp _) = Proxy
+    msgRespType (MsgResp _ _) = Proxy
 
     reqRespType :: forall resp. FileAPI resp -> Proxy resp
     reqRespType _ = Proxy

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

@@ -30,7 +30,7 @@ reqRespServerPeer ReqRespServer { reqRespServerDone = a,
     MsgDone -> (Done a, StateDone)
     MsgReq req ->
       ( Effect $
-              (\(resp, k') -> Yield StateIdle (MsgResp resp) (reqRespServerPeer  k'))
+              (\(resp, k') -> Yield StateIdle (MsgResp req resp) (reqRespServerPeer  k'))
           <$> k req
       , StateBusy req
       )

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

@@ -54,7 +54,12 @@ instance Protocol (ReqResp req) where
                         --   promoted to the state `StBusy` state.
             -> Message (ReqResp req) StIdle (StBusy resp)
     MsgResp :: Typeable resp
-            => resp     -- ^ respond type
+            => req resp -- ^ request, not sent over the wire, just useful in the
+                        -- codec.
+                        --
+                        -- TODO: https://github.com/input-output-hk/typed-protocols/issues/59
+
+            -> resp     -- ^ respond
             -> Message (ReqResp req) (StBusy resp) StIdle
     MsgDone :: Message (ReqResp req) StIdle StDone
 

typed-protocols-examples/typed-protocols-examples.cabal

@@ -1,6 +1,6 @@
 cabal-version:       3.0
 name:                typed-protocols-examples
-version:             0.3.0.0
+version:             0.4.0.0
 synopsis:            Examples and tests for the typed-protocols framework
 -- description:
 license:             Apache-2.0