Skip to content

Commit ab17e11

Browse files
cootcoot
committed
tip-sample: tests
1 parent 7cf01fd commit ab17e11

File tree

3 files changed

+388
-0
lines changed

3 files changed

+388
-0
lines changed

‎ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TipSample/Examples.hs

Lines changed: 112 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,112 @@
1+
{-# LANGUAGE BangPatterns #-}
2+
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE GADTs #-}
4+
{-# LANGUAGE KindSignatures #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
7+
module Ouroboros.Network.Protocol.TipSample.Examples where
8+
9+
import Cardano.Slotting.Slot (SlotNo (..))
10+
11+
import Data.List.NonEmpty (NonEmpty (..))
12+
import qualified Data.List.NonEmpty as NonEmpty
13+
14+
import Network.TypedProtocol.Pipelined (N (..), Nat (Succ, Zero),
15+
natToInt, unsafeIntToNat)
16+
17+
import Ouroboros.Network.Protocol.TipSample.Client
18+
import Ouroboros.Network.Protocol.TipSample.Server
19+
20+
import Test.QuickCheck
21+
22+
23+
data Request tip
24+
= RequestTipAfterSlotNo SlotNo
25+
| RequestTipAfterTip tip
26+
| forall (n :: N). RequestFollowTips (Nat (S n))
27+
28+
29+
instance Show tip => Show (Request tip) where
30+
show (RequestTipAfterSlotNo slotNo) = "RequestTipAfterSlotNo " ++ show slotNo
31+
show (RequestTipAfterTip tip) = "RequestTipAfterTip " ++ show tip
32+
show (RequestFollowTips n) = "RequestFollowTips " ++ show (natToInt n)
33+
34+
instance Eq tip => Eq (Request tip) where
35+
RequestTipAfterSlotNo slotNo == RequestTipAfterSlotNo slotNo' = slotNo == slotNo'
36+
RequestTipAfterTip tip == RequestTipAfterTip tip' = tip == tip'
37+
RequestFollowTips n == RequestFollowTips n' = natToInt n == natToInt n'
38+
_ == _ = False
39+
40+
instance Arbitrary tip => Arbitrary (Request tip) where
41+
arbitrary = oneof
42+
[ RequestTipAfterSlotNo . SlotNo <$> arbitrary
43+
, RequestTipAfterTip <$> arbitrary
44+
, RequestFollowTips . unsafeIntToNat . getPositive <$> arbitrary
45+
]
46+
47+
-- | Given a list of requests record all the responses.
48+
--
49+
tipSampleClientExample :: forall tip m. Applicative m
50+
=> [Request tip]
51+
-> TipSampleClient tip m [tip]
52+
tipSampleClientExample reqs =
53+
TipSampleClient $ pure (\tip -> goIdle [tip] reqs)
54+
where
55+
goIdle
56+
:: [tip]
57+
-> [Request tip]
58+
-> ClientStIdle tip m [tip]
59+
goIdle !acc [] =
60+
SendMsgDone (reverse acc)
61+
goIdle !acc (RequestTipAfterSlotNo slotNo : as) =
62+
SendMsgGetTipAfterSlotNo slotNo $ \tip -> pure (goIdle (tip : acc) as)
63+
goIdle !acc (RequestTipAfterTip a : as) =
64+
SendMsgGetTipAfterTip a $ \tip -> pure (goIdle (tip : acc) as)
65+
goIdle !acc (RequestFollowTips n : as) = SendMsgFollowTip n (goFollowTips acc as n)
66+
67+
goFollowTips
68+
:: [tip]
69+
-> [Request tip]
70+
-> Nat (S n)
71+
-> HandleTips (S n) tip m [tip]
72+
goFollowTips !acc as (Succ p@(Succ _)) =
73+
(ReceiveTip $ \tip -> pure $ goFollowTips (tip : acc) as p)
74+
goFollowTips !acc as (Succ Zero) =
75+
(ReceiveLastTip $ \tip -> pure $ goIdle (tip : acc) as)
76+
77+
78+
79+
-- | A server which sends replies from a list (used cyclicly) and returns all
80+
-- requests.
81+
--
82+
tipSampleServerExample :: forall tip m. Applicative m
83+
=> tip
84+
-> NonEmpty tip
85+
-> TipSampleServer tip m [Request tip]
86+
tipSampleServerExample tip tips =
87+
TipSampleServer $ pure (tip, go [] tiplist)
88+
where
89+
tiplist = cycle $ NonEmpty.toList tips
90+
91+
go :: [Request tip]
92+
-> [tip]
93+
-> ServerStIdle tip m [Request tip]
94+
go _acc [] = error "tipSampleServerExample: impossible happened"
95+
go !acc as@(a : as') =
96+
ServerStIdle {
97+
handleTipAfterSlotNo = \req -> pure (a, go (RequestTipAfterSlotNo req : acc) as'),
98+
handleTipChange = \req -> pure (a, go (RequestTipAfterTip req : acc) as'),
99+
handleFollowTip = \n -> goFollowTip n (RequestFollowTips n : acc) as,
100+
handleDone = pure $ reverse acc
101+
}
102+
103+
goFollowTip :: Nat (S n)
104+
-> [Request tip]
105+
-> [tip]
106+
-> FollowTip (S n) tip m [Request tip]
107+
goFollowTip n@(Succ Zero) !acc (a : as) =
108+
LastTip n (pure (a, go acc as))
109+
goFollowTip n@(Succ p@(Succ _)) !acc (a : as) =
110+
NextTip n (pure (a, goFollowTip p acc as))
111+
goFollowTip _ _ [] =
112+
error "tipSampleServerExample: impossible happened"

‎ouroboros-network/protocol-tests/Ouroboros/Network/Protocol/TipSample/Test.hs

Lines changed: 274 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,274 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE FlexibleContexts #-}
3+
{-# LANGUAGE FlexibleInstances #-}
4+
{-# LANGUAGE RankNTypes #-}
5+
{-# LANGUAGE ScopedTypeVariables #-}
6+
{-# LANGUAGE TypeFamilies #-}
7+
{-# LANGUAGE TypeApplications #-}
8+
9+
{-# OPTIONS_GHC -Wno-orphans #-}
10+
11+
module Ouroboros.Network.Protocol.TipSample.Test where
12+
13+
import Control.Monad.Class.MonadAsync
14+
import Control.Monad.Class.MonadSTM
15+
import Control.Monad.Class.MonadST
16+
import Control.Monad.Class.MonadThrow
17+
import qualified Control.Monad.ST as ST
18+
import Control.Tracer (nullTracer)
19+
20+
import Data.ByteString.Lazy (ByteString)
21+
import Data.List (cycle)
22+
import Data.List.NonEmpty (NonEmpty)
23+
import qualified Data.List.NonEmpty as NonEmpty
24+
import Data.Functor.Identity (Identity (..))
25+
import Codec.Serialise (Serialise)
26+
import qualified Codec.Serialise as Serialise (Serialise (..), DeserialiseFailure)
27+
28+
import Cardano.Slotting.Slot (SlotNo (..))
29+
30+
import Control.Monad.IOSim (runSimOrThrow)
31+
import Network.TypedProtocol.Pipelined (natToInt)
32+
import Network.TypedProtocol.Proofs
33+
34+
import Ouroboros.Network.Channel
35+
import Ouroboros.Network.Codec
36+
import Ouroboros.Network.Driver
37+
38+
import Ouroboros.Network.Protocol.TipSample.Type
39+
import Ouroboros.Network.Protocol.TipSample.Client
40+
import Ouroboros.Network.Protocol.TipSample.Server
41+
import Ouroboros.Network.Protocol.TipSample.Direct
42+
import Ouroboros.Network.Protocol.TipSample.Examples
43+
import Ouroboros.Network.Protocol.TipSample.Codec
44+
45+
import Test.Ouroboros.Network.Testing.Utils (splits2, splits3)
46+
47+
import Test.QuickCheck hiding (Result)
48+
import Test.Tasty (TestTree, testGroup)
49+
import Test.Tasty.QuickCheck (testProperty)
50+
51+
instance Arbitrary SlotNo where
52+
arbitrary = SlotNo <$> arbitrary
53+
shrink (SlotNo a) = SlotNo `map` shrink a
54+
55+
56+
tests :: TestTree
57+
tests = testGroup "Ouroboros.Network.Protocol.TipSampleProtocol"
58+
[ testProperty "direct" propSampleDirect
59+
, testProperty "connect" propSampleConnect
60+
, testProperty "codec" prop_codec_TipSample
61+
, testProperty "codec 2-splits" prop_codec_splits2_TipSample
62+
, testProperty "codec 3-splits" $ withMaxSuccess 30 prop_codec_splits3_TipSample
63+
, testProperty "demo ST" propTipSampleDemoST
64+
, testProperty "demo IO" propTipSampleDemoIO
65+
]
66+
67+
--
68+
-- Pure tests using either 'direct', 'directPipelined', 'connect' or
69+
-- 'connectPipelined'.
70+
--
71+
72+
tipSampleExperiment
73+
:: ( Eq tip
74+
, Show tip
75+
, Monad m
76+
)
77+
=> (forall a b. TipSampleClient tip m a -> TipSampleServer tip m b -> m (a, b))
78+
-> [Request tip]
79+
-> tip
80+
-> NonEmpty tip
81+
-> m Property
82+
tipSampleExperiment run reqs tip resps = do
83+
(resps', reqs') <-
84+
tipSampleClientExample reqs
85+
`run`
86+
tipSampleServerExample tip resps
87+
pure $
88+
counterexample "requests" (reqs' === reqs)
89+
.&&. counterexample "responses" (resps' === pureClient reqs tip resps)
90+
91+
92+
pureClient :: [Request tip] -> tip -> NonEmpty tip -> [tip]
93+
pureClient reqs tip resps = tip : go reqs (cycle (NonEmpty.toList resps))
94+
where
95+
go :: [Request tip] -> [tip] -> [tip]
96+
go [] _ = []
97+
go (RequestTipAfterSlotNo _ : rs) (a : as) = a : go rs as
98+
go (RequestTipAfterTip _ : rs) (a : as) = a : go rs as
99+
go (RequestFollowTips n : rs) as =
100+
case splitAt (natToInt n) as of
101+
(bs, as') -> bs ++ go rs as'
102+
go _ [] = error "tipSampleExperiment: impossible happened"
103+
104+
105+
propSampleDirect :: [Request Int]
106+
-> Int
107+
-> NonEmptyList Int
108+
-> Property
109+
propSampleDirect reqs tip (NonEmpty resps) =
110+
runIdentity $ tipSampleExperiment direct reqs tip (NonEmpty.fromList resps)
111+
112+
113+
propSampleConnect :: [Request Int]
114+
-> Int
115+
-> NonEmptyList Int
116+
-> Property
117+
propSampleConnect reqs tip (NonEmpty resps) =
118+
runIdentity $
119+
tipSampleExperiment
120+
(\client server -> do
121+
(a, b, TerminalStates TokDone TokDone) <-
122+
tipSampleClientPeer client
123+
`connect`
124+
tipSampleServerPeer server
125+
pure (a, b))
126+
reqs tip (NonEmpty.fromList resps)
127+
128+
--
129+
-- Codec tests
130+
--
131+
132+
instance Eq tip => Eq (AnyMessage (TipSample tip)) where
133+
AnyMessage MsgGetCurrentTip
134+
== AnyMessage MsgGetCurrentTip = True
135+
AnyMessage (MsgCurrentTip tip)
136+
== AnyMessage (MsgCurrentTip tip') = tip == tip'
137+
AnyMessage (MsgGetTipAfterSlotNo slotNo)
138+
== AnyMessage (MsgGetTipAfterSlotNo slotNo') = slotNo == slotNo'
139+
AnyMessage (MsgGetTipAfterTip tip)
140+
== AnyMessage (MsgGetTipAfterTip tip') = tip == tip'
141+
AnyMessage (MsgTip tip)
142+
== AnyMessage (MsgTip tip') = tip == tip'
143+
_ == _ = False
144+
145+
instance Eq tip => Eq (AnyMessageAndAgency (TipSample tip)) where
146+
AnyMessageAndAgency _ MsgGetCurrentTip
147+
== AnyMessageAndAgency _ MsgGetCurrentTip = True
148+
AnyMessageAndAgency _ (MsgCurrentTip tip)
149+
== AnyMessageAndAgency _ (MsgCurrentTip tip') = tip == tip'
150+
AnyMessageAndAgency _ (MsgGetTipAfterSlotNo slotNo)
151+
== AnyMessageAndAgency _ (MsgGetTipAfterSlotNo slotNo') = slotNo == slotNo'
152+
AnyMessageAndAgency _ (MsgGetTipAfterTip tip)
153+
== AnyMessageAndAgency _ (MsgGetTipAfterTip tip') = tip == tip'
154+
AnyMessageAndAgency (ServerAgency (TokBusy TokBlockUntilSlot)) (MsgTip tip)
155+
== AnyMessageAndAgency (ServerAgency (TokBusy TokBlockUntilSlot)) (MsgTip tip')
156+
= tip == tip'
157+
AnyMessageAndAgency (ServerAgency (TokBusy TokBlockUntilTip)) (MsgTip tip)
158+
== AnyMessageAndAgency (ServerAgency (TokBusy TokBlockUntilTip)) (MsgTip tip')
159+
= tip == tip'
160+
_ == _ = False
161+
162+
instance Show tip => Show (AnyMessageAndAgency (TipSample tip)) where
163+
show (AnyMessageAndAgency agency msg) =
164+
concat
165+
["AnnyMessageAndAgency "
166+
, show agency
167+
, " "
168+
, show msg
169+
]
170+
171+
instance Arbitrary tip => Arbitrary (AnyMessageAndAgency (TipSample tip)) where
172+
arbitrary = oneof
173+
[ pure $ AnyMessageAndAgency (ClientAgency TokStartClient) MsgGetCurrentTip
174+
, arbitrary >>= \tip ->
175+
pure $ AnyMessageAndAgency (ServerAgency TokStartServer) (MsgCurrentTip tip)
176+
, arbitrary >>= \slotNo ->
177+
pure $ AnyMessageAndAgency (ClientAgency TokIdle) (MsgGetTipAfterSlotNo slotNo)
178+
, arbitrary >>= \tip ->
179+
pure $ AnyMessageAndAgency (ClientAgency TokIdle) (MsgGetTipAfterTip tip)
180+
, arbitrary >>= \tip ->
181+
pure $ AnyMessageAndAgency (ServerAgency (TokBusy TokBlockUntilSlot)) (MsgTip tip)
182+
, arbitrary >>= \tip ->
183+
pure $ AnyMessageAndAgency (ServerAgency (TokBusy TokBlockUntilTip)) (MsgTip tip)
184+
]
185+
186+
codec :: ( MonadST m
187+
, Serialise tip
188+
)
189+
=> Codec (TipSample tip)
190+
Serialise.DeserialiseFailure
191+
m ByteString
192+
codec = codecTipSample Serialise.encode Serialise.decode
193+
194+
prop_codec_TipSample
195+
:: AnyMessageAndAgency (TipSample Int)
196+
-> Bool
197+
prop_codec_TipSample msg =
198+
ST.runST $ prop_codecM codec msg
199+
200+
prop_codec_splits2_TipSample
201+
:: AnyMessageAndAgency (TipSample Int)
202+
-> Bool
203+
prop_codec_splits2_TipSample msg =
204+
ST.runST $ prop_codec_splitsM
205+
splits2
206+
codec
207+
msg
208+
209+
prop_codec_splits3_TipSample
210+
:: AnyMessageAndAgency (TipSample Int)
211+
-> Bool
212+
prop_codec_splits3_TipSample msg =
213+
ST.runST $ prop_codec_splitsM
214+
splits3
215+
codec
216+
msg
217+
218+
--
219+
-- Network demos
220+
--
221+
222+
tipSampleDemo
223+
:: forall tip m.
224+
( MonadST m
225+
, MonadSTM m
226+
, MonadAsync m
227+
, MonadThrow m
228+
, Serialise tip
229+
, Eq tip
230+
)
231+
=> Channel m ByteString
232+
-> Channel m ByteString
233+
-> [Request tip]
234+
-> tip
235+
-> NonEmpty tip
236+
-> m Bool
237+
tipSampleDemo clientChan serverChan reqs tip resps = do
238+
let client :: TipSampleClient tip m [tip]
239+
client = tipSampleClientExample reqs
240+
241+
server :: TipSampleServer tip m [Request tip]
242+
server = tipSampleServerExample tip resps
243+
244+
((reqs', serBS), (resps', cliBS)) <-
245+
runPeer nullTracer codec serverChan (tipSampleServerPeer server)
246+
`concurrently`
247+
runPeer nullTracer codec clientChan (tipSampleClientPeer client)
248+
249+
pure $ reqs == reqs'
250+
&& resps' == pureClient reqs tip resps
251+
&& serBS == Nothing
252+
&& cliBS == Nothing
253+
254+
255+
propTipSampleDemoST
256+
:: [Request Int]
257+
-> Int
258+
-> NonEmptyList Int
259+
-> Bool
260+
propTipSampleDemoST reqs tip (NonEmpty resps) =
261+
runSimOrThrow $ do
262+
(clientChan, serverChan) <- createConnectedChannels
263+
tipSampleDemo clientChan serverChan reqs tip (NonEmpty.fromList resps)
264+
265+
266+
propTipSampleDemoIO
267+
:: [Request Int]
268+
-> Int
269+
-> NonEmptyList Int
270+
-> Property
271+
propTipSampleDemoIO reqs tip (NonEmpty resps) =
272+
ioProperty $ do
273+
(clientChan, serverChan) <- createConnectedChannels
274+
tipSampleDemo clientChan serverChan reqs tip (NonEmpty.fromList resps)

0 commit comments

Comments
 (0)