Skip to content

Commit ea29919

Browse files
cootcoot
committed
Stateful RPC example
1 parent 6b3b105 commit ea29919

File tree

7 files changed

+301
-75
lines changed

7 files changed

+301
-75
lines changed

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -39,12 +39,12 @@ codecReqResp =
3939
decodeTerminatedFrame '\n' $ \str trailing ->
4040
case (stok, break (==' ') str) of
4141
(SingIdle, ("MsgReq", str'))
42-
| Just resp <- readMaybe str'
43-
-> DecodeDone (SomeMessage (MsgReq resp)) trailing
42+
| Just req <- readMaybe str'
43+
-> DecodeDone (SomeMessage (MsgReq req)) trailing
4444
(SingIdle, ("MsgDone", ""))
4545
-> DecodeDone (SomeMessage MsgDone) trailing
4646
(SingBusy, ("MsgResp", str'))
47-
| Just resp <- readMaybe str'
47+
| Just resp <- readMaybe str'
4848
-> DecodeDone (SomeMessage (MsgResp resp)) trailing
4949

5050
(_ , _ ) -> DecodeFail failure

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

Lines changed: 24 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -1,52 +1,42 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE FlexibleContexts #-}
33
{-# LANGUAGE GADTs #-}
4-
{-# LANGUAGE KindSignatures #-}
54
{-# LANGUAGE PolyKinds #-}
65
{-# LANGUAGE RankNTypes #-}
76
{-# LANGUAGE ScopedTypeVariables #-}
8-
{-# LANGUAGE TypeOperators #-}
97

108
module Network.TypedProtocol.Stateful.ReqResp.Client
11-
( -- * Non-Pipelined Client
12-
ReqRespClient (..)
9+
( ReqRespClient (..)
1310
, reqRespClientPeer
1411
) where
1512

16-
import Data.Kind (Type)
17-
18-
import Network.TypedProtocol.ReqResp.Type
13+
import Data.Typeable
14+
import Network.TypedProtocol.Stateful.ReqResp.Type
1915
import Network.TypedProtocol.Stateful.Peer.Client
2016

17+
data ReqRespClient req m a where
18+
SendMsgReq :: Typeable resp
19+
=> req resp
20+
-> (resp -> m (ReqRespClient req m a))
21+
-> ReqRespClient req m a
2122

22-
data ReqRespClient req resp (f :: ReqResp req resp -> Type) m a where
23-
SendMsgReq :: f StBusy
24-
-> req
25-
-> (f StBusy -> resp -> ( m (ReqRespClient req resp f m a)
26-
, f StIdle
27-
))
28-
-> ReqRespClient req resp f m a
29-
30-
SendMsgDone :: f StDone
31-
-> m a
32-
-> ReqRespClient req resp f m a
23+
SendMsgDone :: a
24+
-> ReqRespClient req m a
3325

3426

3527
reqRespClientPeer
3628
:: Monad m
37-
=> ReqRespClient req resp f m a
38-
-> Client (ReqResp req resp) StIdle f m a
39-
40-
reqRespClientPeer (SendMsgDone f result) =
41-
Effect $ do
42-
r <- result
43-
return $ Yield f MsgDone (Done r)
44-
45-
reqRespClientPeer (SendMsgReq f req next) =
46-
Yield f (MsgReq req) $
47-
Await $ \f' (MsgResp resp) ->
48-
case next f' resp of
49-
(client, f'') ->
50-
( Effect $ reqRespClientPeer <$> client
51-
, f''
52-
)
29+
=> ReqRespClient req m a
30+
-> Client (ReqResp req) StIdle State m a
31+
32+
reqRespClientPeer (SendMsgDone a) =
33+
Yield StateDone MsgDone (Done a)
34+
35+
reqRespClientPeer (SendMsgReq req next) =
36+
Yield (StateBusy req)
37+
(MsgReq req) $
38+
Await $ \_ (MsgResp resp) ->
39+
let client = next resp
40+
in ( Effect $ reqRespClientPeer <$> client
41+
, StateIdle
42+
)

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

Lines changed: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE NamedFieldPuns #-}
5+
{-# LANGUAGE PolyKinds #-}
6+
{-# LANGUAGE RankNTypes #-}
7+
{-# LANGUAGE ScopedTypeVariables #-}
8+
{-# LANGUAGE TypeOperators #-}
9+
10+
module Network.TypedProtocol.Stateful.ReqResp.Codec where
11+
12+
import Data.Kind (Type)
13+
import Data.Singletons.Decide
14+
import Data.Typeable
15+
import Network.TypedProtocol.Core
16+
import Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame)
17+
import Network.TypedProtocol.Stateful.Codec
18+
import Network.TypedProtocol.Stateful.ReqResp.Type
19+
20+
data Some (f :: k -> Type) where
21+
Some :: Typeable a => f a -> Some f
22+
23+
24+
-- | Codec polymorphic in the RPC (e.g. `req` type)
25+
--
26+
codecReqResp
27+
:: forall req m. Monad m
28+
=> (forall resp. req resp -> String)
29+
-- ^ encode `req resp`
30+
-> (String -> Maybe (Some req))
31+
-- ^ decode `req resp`
32+
-> (forall resp. resp -> String)
33+
-- ^ encode resp
34+
-> (forall resp. req resp -> String -> Maybe resp)
35+
-- ^ decode resp
36+
-> Codec (ReqResp req) CodecFailure State m String
37+
codecReqResp encodeReq decodeReq encodeResp decodeResp =
38+
Codec { encode, decode }
39+
where
40+
encode :: State st'
41+
-> Message (ReqResp req) st st'
42+
-> String
43+
encode _ (MsgReq req) = "MsgReq " ++ encodeReq req ++ "\n"
44+
encode _ MsgDone = "MsgDone\n"
45+
encode _ (MsgResp resp) = "MsgResp " ++ encodeResp resp ++ "\n"
46+
47+
decode :: forall (st :: ReqResp req).
48+
ActiveState st
49+
=> StateToken st
50+
-> State st
51+
-> m (DecodeStep String CodecFailure m (SomeMessage st))
52+
decode stok state =
53+
decodeTerminatedFrame '\n' $ \str trailing ->
54+
case (stok, state, break (==' ') str) of
55+
(SingIdle, StateIdle, ("MsgReq", str'))
56+
| Just (Some req) <- decodeReq str'
57+
-> DecodeDone (SomeMessage (MsgReq req)) trailing
58+
(SingIdle, StateIdle, ("MsgDone", ""))
59+
-> DecodeDone (SomeMessage MsgDone) trailing
60+
(SingBusy, StateBusy req, ("MsgResp", str'))
61+
-- note that we need `req` to decode response of the given type
62+
| Just resp <- decodeResp req str'
63+
-> DecodeDone (SomeMessage (MsgResp resp)) trailing
64+
(_, _, _) -> DecodeFail failure
65+
where failure = CodecFailure ("unexpected server message: " ++ str)
66+
67+
68+
data Bytes where
69+
Bytes :: Message (ReqResp FileAPI) st st' -> Bytes
70+
71+
-- | An identity codec which wraps messages into `AnyMessage`.
72+
--
73+
codecReqRespId
74+
:: forall m.
75+
Applicative m
76+
=> (forall (res1 :: Type) (res2 :: Type).
77+
(Typeable res1, Typeable res2)
78+
=> Proxy res1
79+
-> Proxy res2
80+
-> Maybe (res1 :~: res2)
81+
)
82+
-> Codec FileRPC String State m Bytes
83+
codecReqRespId eqRespTypes = Codec { encode, decode }
84+
where
85+
encode _ = Bytes
86+
87+
decode :: forall (st :: ReqResp FileAPI).
88+
ActiveState st
89+
=> StateToken st
90+
-> State st
91+
-> m (DecodeStep Bytes String m (SomeMessage st))
92+
decode stok state = pure $ DecodePartial $ \bytes -> pure $
93+
case (stok, state, bytes) of
94+
(SingIdle, StateIdle, Just (Bytes msg@MsgDone))
95+
-> DecodeDone (SomeMessage msg) Nothing
96+
(SingIdle, StateIdle, Just (Bytes msg@MsgReq{}))
97+
-> DecodeDone (SomeMessage msg) Nothing
98+
(SingBusy, StateBusy req, Just (Bytes msg@(MsgResp _)))
99+
-- the codec needs to verify that response type of `req` and `msg` agrees
100+
| Just Refl <- eqRespTypes (reqRespType req) (msgRespType msg)
101+
-> DecodeDone (SomeMessage msg) Nothing
102+
103+
(SingDone, _, _) -> notActiveState stok
104+
(_, _, Nothing) -> DecodeFail "no bytes"
105+
(_, _, _) -> DecodeFail "no matching message"
106+
107+
msgRespType :: forall resp. Message (ReqResp FileAPI) (StBusy resp) StIdle
108+
-> Proxy resp
109+
msgRespType (MsgResp _) = Proxy
110+
111+
reqRespType :: forall resp. FileAPI resp -> Proxy resp
112+
reqRespType _ = Proxy
113+
114+

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

Lines changed: 21 additions & 38 deletions
Original file line numberDiff line numberDiff line change
@@ -2,49 +2,32 @@
22
{-# LANGUAGE GADTs #-}
33
{-# LANGUAGE NamedFieldPuns #-}
44
{-# LANGUAGE PolyKinds #-}
5+
{-# LANGUAGE RankNTypes #-}
56
{-# LANGUAGE ScopedTypeVariables #-}
67

7-
module Network.TypedProtocol.Stateful.ReqResp.Examples
8-
( ReqRespStateCallbacks (..)
9-
, reqRespClientMap
10-
) where
8+
module Network.TypedProtocol.Stateful.ReqResp.Examples where
119

12-
import Data.Kind (Type)
10+
import Network.TypedProtocol.Stateful.ReqResp.Type
11+
import Network.TypedProtocol.Stateful.ReqResp.Server
1312

14-
import Network.TypedProtocol.ReqResp.Type
15-
import Network.TypedProtocol.Stateful.ReqResp.Client
1613

14+
fileRPCServer :: Monad m
15+
=> (forall resp. FileAPI resp -> m resp)
16+
-- ^ execute `FileAPI` locally
17+
-> ReqRespServer FileAPI m ()
18+
fileRPCServer run = ReqRespServer {
19+
reqRespServerDone = (),
20+
reqRespHandleReq = \req -> do
21+
resp <- run req
22+
return (resp, fileRPCServer run)
23+
}
1724

18-
data ReqRespStateCallbacks (f :: ReqResp req resp -> Type) =
19-
ReqRespStateCallbacks {
20-
rrBusyToIdle :: f StBusy -> f StIdle
21-
, rrBusyToBusy :: f StBusy -> f StBusy
22-
, rrBusyToDone :: f StBusy -> f StDone
23-
}
25+
-- | Example of a file API
26+
--
27+
simpleFileAPI :: Monad m => FileAPI resp -> m resp
28+
simpleFileAPI (ReadFile filepath) = return filepath
29+
simpleFileAPI (WriteFile _ _) = return ()
2430

25-
reqRespClientMap
26-
:: forall req resp f m.
27-
Monad m
28-
=> ReqRespStateCallbacks f
29-
-> f StBusy
30-
-> [req]
31-
-> ReqRespClient req resp f m ([resp], f StDone)
32-
reqRespClientMap ReqRespStateCallbacks
33-
{ rrBusyToIdle
34-
, rrBusyToBusy
35-
, rrBusyToDone
36-
} = go []
37-
where
38-
go :: [resp]
39-
-> f StBusy
40-
-> [req]
41-
-> ReqRespClient req resp f m ([resp], f StDone)
42-
go resps f [] = SendMsgDone f' (pure (reverse resps, f'))
43-
where
44-
f' = rrBusyToDone f
45-
go resps f (req:reqs) =
46-
SendMsgReq f req $ \f' resp ->
47-
( return (go (resp:resps) (rrBusyToBusy f') reqs)
48-
, rrBusyToIdle f'
49-
)
31+
simpleFileRPCServer :: Monad m => ReqRespServer FileAPI m ()
32+
simpleFileRPCServer = fileRPCServer simpleFileAPI
5033

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

Lines changed: 36 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,36 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE LambdaCase #-}
5+
{-# LANGUAGE PolyKinds #-}
6+
{-# LANGUAGE RankNTypes #-}
7+
{-# LANGUAGE ScopedTypeVariables #-}
8+
9+
module Network.TypedProtocol.Stateful.ReqResp.Server
10+
( ReqRespServer (..)
11+
, reqRespServerPeer
12+
) where
13+
14+
import Data.Typeable
15+
import Network.TypedProtocol.Stateful.ReqResp.Type
16+
import Network.TypedProtocol.Stateful.Peer.Server
17+
18+
19+
data ReqRespServer req m a = ReqRespServer {
20+
reqRespServerDone :: a,
21+
reqRespHandleReq :: forall resp. Typeable resp => req resp -> m (resp, ReqRespServer req m a)
22+
}
23+
24+
reqRespServerPeer :: Functor m
25+
=> ReqRespServer req m a
26+
-> Server (ReqResp req) StIdle State m a
27+
reqRespServerPeer ReqRespServer { reqRespServerDone = a,
28+
reqRespHandleReq = k } =
29+
Await $ \_ -> \case
30+
MsgDone -> (Done a, StateDone)
31+
MsgReq req ->
32+
( Effect $
33+
(\(resp, k') -> Yield StateIdle (MsgResp resp) (reqRespServerPeer k'))
34+
<$> k req
35+
, StateBusy req
36+
)

0 commit comments

Comments
 (0)