Skip to content

Commit d127d3e

Browse files
cootcoot
authored
Merge pull request #61 from input-output-hk/coot/stateful
Better stateful API
2 parents cd80ff7 + dc0105c commit d127d3e

File tree

18 files changed

+159
-100
lines changed

18 files changed

+159
-100
lines changed

‎.github/workflows/github-page.yml

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,8 +1,9 @@
11
name: Haddocks
22

33
on:
4-
schedule:
5-
- cron: '0 0 * * *'
4+
push:
5+
branches:
6+
- main
67
workflow_dispatch:
78

89
jobs:

‎typed-protocols-cborg/typed-protocols-cborg.cabal

Lines changed: 8 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
1-
cabal-version: 3.0
1+
cabal-version: 3.4
22
name: typed-protocols-cborg
3-
version: 0.2.0.0
3+
version: 0.3.0.0
44
synopsis: CBOR codecs for typed-protocols
55
-- description:
66
license: Apache-2.0
@@ -18,13 +18,13 @@ extra-source-files: CHANGELOG.md, README.md
1818
library
1919
exposed-modules: Network.TypedProtocol.Codec.CBOR
2020

21-
build-depends: base >=4.12 && <4.21,
22-
bytestring >=0.10 && <0.13,
23-
cborg >=0.2.1 && <0.3,
24-
singletons,
21+
build-depends: base >=4.12 && <4.21,
22+
bytestring >=0.10 && <0.13,
23+
cborg >=0.2.1 && <0.3,
24+
singletons,
2525

26-
io-classes ^>=1.5,
27-
typed-protocols
26+
io-classes ^>=1.5,
27+
typed-protocols ^>=0.3
2828

2929
hs-source-dirs: src
3030
default-language: Haskell2010

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -30,12 +30,12 @@ reqRespClientPeer
3030
-> Client (ReqResp req) StIdle State m a
3131

3232
reqRespClientPeer (SendMsgDone a) =
33-
Yield StateDone MsgDone (Done a)
33+
Yield StateIdle StateDone MsgDone (Done a)
3434

3535
reqRespClientPeer (SendMsgReq req next) =
36-
Yield (StateBusy req)
36+
Yield StateIdle (StateBusy req)
3737
(MsgReq req) $
38-
Await $ \_ (MsgResp _ resp) ->
38+
Await $ \_ (MsgResp resp) ->
3939
let client = next resp
4040
in ( Effect $ reqRespClientPeer <$> client
4141
, StateIdle

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

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -37,12 +37,12 @@ codecReqResp
3737
codecReqResp encodeReq decodeReq encodeResp decodeResp =
3838
Codec { encode, decode }
3939
where
40-
encode :: State st'
40+
encode :: State st
4141
-> Message (ReqResp req) st st'
4242
-> String
4343
encode _ (MsgReq req) = "MsgReq " ++ encodeReq req ++ "\n"
4444
encode _ MsgDone = "MsgDone\n"
45-
encode _ (MsgResp req resp) = "MsgResp " ++ encodeResp req resp ++ "\n"
45+
encode (StateBusy req) (MsgResp resp) = "MsgResp " ++ encodeResp req resp ++ "\n"
4646

4747
decode :: forall (st :: ReqResp req).
4848
ActiveState st
@@ -60,7 +60,7 @@ codecReqResp encodeReq decodeReq encodeResp decodeResp =
6060
(SingBusy, StateBusy req, ("MsgResp", str'))
6161
-- note that we need `req` to decode response of the given type
6262
| Just resp <- decodeResp req str'
63-
-> DecodeDone (SomeMessage (MsgResp req resp)) trailing
63+
-> DecodeDone (SomeMessage (MsgResp resp)) trailing
6464
(_, _, _) -> DecodeFail failure
6565
where failure = CodecFailure ("unexpected server message: " ++ str)
6666

@@ -106,7 +106,7 @@ codecReqRespId eqRespTypes = Codec { encode, decode }
106106

107107
msgRespType :: forall resp. Message (ReqResp FileAPI) (StBusy resp) StIdle
108108
-> Proxy resp
109-
msgRespType (MsgResp _ _) = Proxy
109+
msgRespType (MsgResp _) = Proxy
110110

111111
reqRespType :: forall resp. FileAPI resp -> Proxy resp
112112
reqRespType _ = Proxy

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -30,7 +30,7 @@ reqRespServerPeer ReqRespServer { reqRespServerDone = a,
3030
MsgDone -> (Done a, StateDone)
3131
MsgReq req ->
3232
( Effect $
33-
(\(resp, k') -> Yield StateIdle (MsgResp req resp) (reqRespServerPeer k'))
33+
(\(resp, k') -> Yield (StateBusy req) StateIdle (MsgResp resp) (reqRespServerPeer k'))
3434
<$> k req
3535
, StateBusy req
3636
)

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

Lines changed: 1 addition & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -54,12 +54,7 @@ instance Protocol (ReqResp req) where
5454
-- promoted to the state `StBusy` state.
5555
-> Message (ReqResp req) StIdle (StBusy resp)
5656
MsgResp :: Typeable resp
57-
=> req resp -- ^ request, not sent over the wire, just useful in the
58-
-- codec.
59-
--
60-
-- TODO: https://github.com/input-output-hk/typed-protocols/issues/59
61-
62-
-> resp -- ^ respond
57+
=> resp -- ^ respond
6358
-> Message (ReqResp req) (StBusy resp) StIdle
6459
MsgDone :: Message (ReqResp req) StIdle StDone
6560

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

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
1-
cabal-version: 3.0
1+
cabal-version: 3.4
22
name: typed-protocols-examples
3-
version: 0.4.0.0
3+
version: 0.5.0.0
44
synopsis: Examples and tests for the typed-protocols framework
55
-- description:
66
license: Apache-2.0
@@ -63,7 +63,7 @@ library
6363
si-timers,
6464
network,
6565
time,
66-
typed-protocols ^>= 0.2,
66+
typed-protocols ^>= 0.3,
6767
typed-protocols-cborg,
6868
typed-protocols-stateful
6969

‎typed-protocols-stateful-cborg/src/Network/TypedProtocol/Stateful/Codec/CBOR.hs

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -48,7 +48,7 @@ mkCodecCborStrictBS
4848
=> (forall (st :: ps) (st' :: ps).
4949
StateTokenI st
5050
=>ActiveState st
51-
=> f st' -> Message ps st st' -> CBOR.Encoding)
51+
=> f st -> Message ps st st' -> CBOR.Encoding)
5252
-- ^ cbor encoder
5353

5454
-> (forall (st :: ps) s.
@@ -90,7 +90,7 @@ mkCodecCborLazyBS
9090
=> (forall (st :: ps) (st' :: ps).
9191
StateTokenI st
9292
=> ActiveState st
93-
=> f st'
93+
=> f st
9494
-> Message ps st st' -> CBOR.Encoding)
9595
-- ^ cbor encoder
9696

‎typed-protocols-stateful-cborg/typed-protocols-stateful-cborg.cabal

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,6 @@
1-
cabal-version: 3.0
1+
cabal-version: 3.4
22
name: typed-protocols-stateful-cborg
3-
version: 0.2.0.0
3+
version: 0.3.0.0
44
synopsis: CBOR codecs for typed-protocols
55
-- description:
66
license: Apache-2.0
@@ -25,7 +25,7 @@ library
2525
singletons,
2626

2727
io-classes,
28-
typed-protocols,
28+
typed-protocols ^>= 0.3,
2929
typed-protocols-cborg,
3030
typed-protocols-stateful
3131

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

Lines changed: 54 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -41,8 +41,8 @@ module Network.TypedProtocol.Stateful.Codec
4141
-- * CodecFailure
4242
, CodecFailure (..)
4343
-- * Testing codec properties
44-
, AnyMessage (..)
45-
, pattern AnyMessageAndAgency
44+
, AnyMessage (.., AnyMessageAndAgency)
45+
, showAnyMessage
4646
, prop_codecM
4747
, prop_codec
4848
, prop_codec_splitsM
@@ -59,7 +59,7 @@ import Network.TypedProtocol.Codec (CodecFailure (..),
5959
DecodeStep (..), SomeMessage (..), hoistDecodeStep,
6060
isoDecodeStep, mapFailureDecodeStep, runDecoder,
6161
runDecoderPure)
62-
import qualified Network.TypedProtocol.Codec as TP
62+
import qualified Network.TypedProtocol.Codec as TP hiding (AnyMessageAndAgency)
6363

6464

6565
-- | A stateful codec.
@@ -68,14 +68,23 @@ data Codec ps failure (f :: ps -> Type) m bytes = Codec {
6868
encode :: forall (st :: ps) (st' :: ps).
6969
StateTokenI st
7070
=> ActiveState st
71-
=> f st'
71+
=> f st
72+
-- local state, which contain extra context for the encoding
73+
-- process.
74+
--
75+
-- TODO: input-output-hk/typed-protocols#57
7276
-> Message ps st st'
77+
-- message to be encoded
7378
-> bytes,
7479

7580
decode :: forall (st :: ps).
7681
ActiveState st
7782
=> StateToken st
7883
-> f st
84+
-- local state, which can contain extra context from the
85+
-- previous message.
86+
--
87+
-- TODO: input-output-hk/typed-protocols#57
7988
-> m (DecodeStep bytes failure m (SomeMessage st))
8089
}
8190

@@ -130,22 +139,32 @@ data AnyMessage ps (f :: ps -> Type) where
130139
, ActiveState st
131140
)
132141
=> f st
133-
-> f st'
142+
-- ^ local state
134143
-> Message ps (st :: ps) (st' :: ps)
144+
-- ^ protocol messsage
135145
-> AnyMessage ps f
136146

137-
instance ( forall (st :: ps) (st' :: ps). Show (Message ps st st')
138-
, forall (st :: ps). Show (f st)
139-
)
140-
=> Show (AnyMessage ps f) where
141-
show (AnyMessage st st' msg) = concat [ "AnyMessage "
142-
, show st
143-
, " "
144-
, show st'
145-
, " "
146-
, show msg
147-
]
148147

148+
-- | `showAnyMessage` is can be used to provide `Show` instance for
149+
-- `AnyMessage` if showing `Message` is independent of the state or one accepts
150+
-- showing only partial information included in message constructors or accepts
151+
-- message constructors to carry `Show` instances for its arguments. Note that
152+
-- the proper solution is to define a custom `Show (AnyMessage ps f)` instance
153+
-- for a protocol `ps`, which give access to the state functor `f` in scope of
154+
-- `show`.
155+
--
156+
showAnyMessage :: forall ps f.
157+
( forall st st'. Show (Message ps st st')
158+
, forall st. Show (f st)
159+
)
160+
=> AnyMessage ps f
161+
-> String
162+
showAnyMessage (AnyMessage st msg) =
163+
concat [ "AnyMessage "
164+
, show st
165+
, " "
166+
, show msg
167+
]
149168

150169

151170
-- | A convenient pattern synonym which unwrap 'AnyMessage' giving both the
@@ -156,10 +175,9 @@ pattern AnyMessageAndAgency :: forall ps f. ()
156175
(StateTokenI st, ActiveState st)
157176
=> StateToken st
158177
-> f st
159-
-> f st'
160178
-> Message ps st st'
161179
-> AnyMessage ps f
162-
pattern AnyMessageAndAgency stateToken f f' msg <- AnyMessage f f' (getAgency -> (msg, stateToken))
180+
pattern AnyMessageAndAgency stateToken f msg <- AnyMessage f (getAgency -> (msg, stateToken))
163181
where
164182
AnyMessageAndAgency _ msg = AnyMessage msg
165183
{-# COMPLETE AnyMessageAndAgency #-}
@@ -169,28 +187,29 @@ pattern AnyMessageAndAgency stateToken f f' msg <- AnyMessage f f' (getAgency ->
169187
getAgency :: StateTokenI st => Message ps st st' -> (Message ps st st', StateToken st)
170188
getAgency msg = (msg, stateToken)
171189

190+
172191
-- | The 'Codec' round-trip property: decode after encode gives the same
173192
-- message. Every codec must satisfy this property.
174193
--
175194
prop_codecM
176195
:: forall ps failure f m bytes.
177196
( Monad m
178-
, Eq (TP.AnyMessage ps)
197+
, Eq (AnyMessage ps f)
179198
)
180199
=> Codec ps failure f m bytes
181200
-> AnyMessage ps f
182201
-> m Bool
183-
prop_codecM Codec {encode, decode} (AnyMessage f f' (msg :: Message ps st st')) = do
184-
r <- decode (stateToken :: StateToken st) f >>= runDecoder [encode f' msg]
202+
prop_codecM Codec {encode, decode} a@(AnyMessage f (msg :: Message ps st st')) = do
203+
r <- decode (stateToken :: StateToken st) f >>= runDecoder [encode f msg]
185204
case r :: Either failure (SomeMessage st) of
186-
Right (SomeMessage msg') -> return $ TP.AnyMessage msg' == TP.AnyMessage msg
205+
Right (SomeMessage msg') -> return $ AnyMessage f msg' == a
187206
Left _ -> return False
188207

189208
-- | The 'Codec' round-trip property in a pure monad.
190209
--
191210
prop_codec
192211
:: forall ps failure f m bytes.
193-
(Monad m, Eq (TP.AnyMessage ps))
212+
(Monad m, Eq (AnyMessage ps f))
194213
=> (forall a. m a -> a)
195214
-> Codec ps failure f m bytes
196215
-> AnyMessage ps f
@@ -212,28 +231,28 @@ prop_codec runM codec msg =
212231
--
213232
prop_codec_splitsM
214233
:: forall ps failure f m bytes.
215-
(Monad m, Eq (TP.AnyMessage ps))
234+
(Monad m, Eq (AnyMessage ps f))
216235
=> (bytes -> [[bytes]]) -- ^ alternative re-chunkings of serialised form
217236
-> Codec ps failure f m bytes
218237
-> AnyMessage ps f
219238
-> m Bool
220239
prop_codec_splitsM splits
221-
Codec {encode, decode} (AnyMessage f f' (msg :: Message ps st st')) = do
240+
Codec {encode, decode} a@(AnyMessage f (msg :: Message ps st st')) = do
222241
and <$> sequence
223242
[ do r <- decode (stateToken :: StateToken st) f >>= runDecoder bytes'
224243
case r :: Either failure (SomeMessage st) of
225-
Right (SomeMessage msg') -> return $ TP.AnyMessage msg' == TP.AnyMessage msg
244+
Right (SomeMessage msg') -> return $ AnyMessage f msg' == a
226245
Left _ -> return False
227246

228-
| let bytes = encode f' msg
247+
| let bytes = encode f msg
229248
, bytes' <- splits bytes ]
230249

231250

232251
-- | Like @'prop_codec_splitsM'@ but run in a pure monad @m@, e.g. @Identity@.
233252
--
234253
prop_codec_splits
235254
:: forall ps failure f m bytes.
236-
(Monad m, Eq (TP.AnyMessage ps))
255+
(Monad m, Eq (AnyMessage ps f))
237256
=> (bytes -> [[bytes]])
238257
-> (forall a. m a -> a)
239258
-> Codec ps failure f m bytes
@@ -250,30 +269,30 @@ prop_codec_splits splits runM codec msg =
250269
prop_codecs_compatM
251270
:: forall ps failure f m bytes.
252271
( Monad m
253-
, Eq (TP.AnyMessage ps)
272+
, Eq (AnyMessage ps f)
254273
, forall a. Monoid a => Monoid (m a)
255274
)
256275
=> Codec ps failure f m bytes
257276
-> Codec ps failure f m bytes
258277
-> AnyMessage ps f
259278
-> m Bool
260279
prop_codecs_compatM codecA codecB
261-
(AnyMessage f f' (msg :: Message ps st st')) =
262-
getAll <$> do r <- decode codecB (stateToken :: StateToken st) f >>= runDecoder [encode codecA f' msg]
280+
a@(AnyMessage f (msg :: Message ps st st')) =
281+
getAll <$> do r <- decode codecB (stateToken :: StateToken st) f >>= runDecoder [encode codecA f msg]
263282
case r :: Either failure (SomeMessage st) of
264-
Right (SomeMessage msg') -> return $ All $ TP.AnyMessage msg' == TP.AnyMessage msg
283+
Right (SomeMessage msg') -> return $ All $ AnyMessage f msg' == a
265284
Left _ -> return $ All False
266-
<> do r <- decode codecA (stateToken :: StateToken st) f >>= runDecoder [encode codecB f' msg]
285+
<> do r <- decode codecA (stateToken :: StateToken st) f >>= runDecoder [encode codecB f msg]
267286
case r :: Either failure (SomeMessage st) of
268-
Right (SomeMessage msg') -> return $ All $ TP.AnyMessage msg' == TP.AnyMessage msg
287+
Right (SomeMessage msg') -> return $ All $ AnyMessage f msg' == a
269288
Left _ -> return $ All False
270289

271290
-- | Like @'prop_codecs_compatM'@ but run in a pure monad @m@, e.g. @Identity@.
272291
--
273292
prop_codecs_compat
274293
:: forall ps failure f m bytes.
275294
( Monad m
276-
, Eq (TP.AnyMessage ps)
295+
, Eq (AnyMessage ps f)
277296
, forall a. Monoid a => Monoid (m a)
278297
)
279298
=> (forall a. m a -> a)

0 commit comments

Comments
 (0)