Skip to content

Commit fc7da51

Browse files
crocodile-dentistcrocodile-dentist
committed
dmq: local protocols tests
1 parent 11a4e69 commit fc7da51

File tree

5 files changed

+251
-46
lines changed

5 files changed

+251
-46
lines changed

‎decentralized-message-queue/decentralized-message-queue.cabal‎

Lines changed: 34 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,16 @@ category: Network
1818
build-type: Simple
1919
extra-doc-files: CHANGELOG.md
2020

21+
common extensions
22+
default-extensions:
23+
BangPatterns
24+
BlockArguments
25+
GADTs
26+
ImportQualifiedPost
27+
LambdaCase
28+
NamedFieldPuns
29+
ScopedTypeVariables
30+
2131
common warnings
2232
ghc-options:
2333
-Wall
@@ -31,7 +41,9 @@ common warnings
3141
-Wunused-packages
3242

3343
library
34-
import: warnings
44+
import:
45+
warnings,
46+
extensions
3547
exposed-modules:
3648
DMQ.Configuration
3749
DMQ.Configuration.CLIOptions
@@ -42,8 +54,16 @@ library
4254
DMQ.Diffusion.PeerSelection
4355
DMQ.NodeToClient
4456
DMQ.NodeToNode
45-
DMQ.Protocol.SigSubmission.Type
57+
DMQ.Protocol.LocalMsgNotification.Client
58+
DMQ.Protocol.LocalMsgNotification.Codec
59+
DMQ.Protocol.LocalMsgNotification.Server
60+
DMQ.Protocol.LocalMsgNotification.Type
61+
DMQ.Protocol.LocalMsgSubmission.Client
62+
DMQ.Protocol.LocalMsgSubmission.Codec
63+
DMQ.Protocol.LocalMsgSubmission.Server
64+
DMQ.Protocol.LocalMsgSubmission.Type
4665
DMQ.Protocol.SigSubmission.Codec
66+
DMQ.Protocol.SigSubmission.Type
4767

4868
build-depends:
4969
aeson >=2.1.1.0 && <3,
@@ -67,14 +87,15 @@ library
6787
random ^>=1.2,
6888
text >=1.2.4 && <2.2,
6989
time ^>= 1.12,
70-
typed-protocols:{cborg, typed-protocols} ^>=1.0,
90+
typed-protocols:{typed-protocols, cborg} ^>=1.0,
7191

7292
hs-source-dirs: src
7393
default-language: Haskell2010
74-
default-extensions: ImportQualifiedPost
7594

7695
executable dmq-exe
77-
import: warnings
96+
import:
97+
warnings,
98+
extensions
7899
main-is: Main.hs
79100
ghc-options:
80101
-threaded
@@ -91,32 +112,37 @@ executable dmq-exe
91112

92113
hs-source-dirs: app
93114
default-language: Haskell2010
94-
default-extensions: ImportQualifiedPost
95115

96116
test-suite dmq-test
97-
import: warnings
117+
import: warnings,
118+
extensions
98119
default-language: Haskell2010
99-
default-extensions: ImportQualifiedPost
100120
other-modules:
101121
Test.DMQ.NodeToClient
102122
Test.DMQ.NodeToNode
103123
Test.DMQ.Protocol.SigSubmission
124+
Test.DMQ.Protocol.LocalMsgNotification
125+
Test.DMQ.Protocol.LocalMsgSubmission
104126

105127
type: exitcode-stdio-1.0
106128
hs-source-dirs: test
107129
main-is: Main.hs
108130
build-depends:
109131
QuickCheck,
110132
base >=4.14 && <4.22,
133+
bytestring,
111134
decentralized-message-queue,
112135
ouroboros-network-api,
113136
ouroboros-network-protocols:testlib,
137+
ouroboros-network-testing,
114138
quickcheck-instances,
139+
serialise,
115140
tasty,
116141
tasty-quickcheck,
117142
time,
118143
typed-protocols,
119144
with-utf8,
145+
io-classes
120146

121147
ghc-options:
122148
-fno-ignore-asserts

‎decentralized-message-queue/src/DMQ/Protocol/SigSubmission/Codec.hs‎

Lines changed: 49 additions & 37 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,10 @@ module DMQ.Protocol.SigSubmission.Codec
99
, byteLimitsSigSubmission
1010
, timeLimitsSigSubmission
1111
, codecSigSubmissionId
12+
, encodeSig
13+
, decodeSig
14+
, encodeSigId
15+
, decodeSigId
1216
) where
1317

1418
import Control.Monad (when)
@@ -82,43 +86,51 @@ codecSigSubmission
8286
codecSigSubmission =
8387
TX.codecTxSubmission2 encodeSigId decodeSigId
8488
encodeSig decodeSig
85-
where
86-
encodeSigId :: SigId -> CBOR.Encoding
87-
encodeSigId SigId { getSigId } = CBOR.encodeBytes (getSigHash getSigId)
88-
89-
decodeSigId :: forall s. CBOR.Decoder s SigId
90-
decodeSigId = SigId . SigHash <$> CBOR.decodeBytes
91-
92-
encodeSig :: Sig -> CBOR.Encoding
93-
encodeSig Sig { sigId,
94-
sigBody,
95-
sigExpiresAt,
96-
sigKesSignature,
97-
sigOpCertificate
98-
}
99-
= CBOR.encodeListLen 5
100-
<> encodeSigId sigId
101-
<> CBOR.encodeBytes (getSigBody sigBody)
102-
<> CBOR.encodeWord32 (floor sigExpiresAt)
103-
<> CBOR.encodeBytes (getSigKesSignature sigKesSignature)
104-
<> CBOR.encodeBytes (getSigOpCertificate sigOpCertificate)
105-
106-
decodeSig :: forall s. CBOR.Decoder s Sig
107-
decodeSig = do
108-
a <- CBOR.decodeListLen
109-
when (a /= 5) $ fail (printf "codecSigSubmission: unexpected number of parameters %d" a)
110-
sigId <- decodeSigId
111-
sigBody <- SigBody <$> CBOR.decodeBytes
112-
sigExpiresAt <- realToFrac <$> CBOR.decodeWord32
113-
sigKesSignature <- SigKesSignature <$> CBOR.decodeBytes
114-
sigOpCertificate <- SigOpCertificate <$> CBOR.decodeBytes
115-
return Sig {
116-
sigId,
117-
sigBody,
118-
sigExpiresAt,
119-
sigKesSignature,
120-
sigOpCertificate
121-
}
89+
90+
91+
--
92+
-- encoding primitives
93+
--
94+
95+
encodeSigId :: SigId -> CBOR.Encoding
96+
encodeSigId SigId { getSigId } = CBOR.encodeBytes (getSigHash getSigId)
97+
98+
99+
decodeSigId :: forall s. CBOR.Decoder s SigId
100+
decodeSigId = SigId . SigHash <$> CBOR.decodeBytes
101+
102+
103+
encodeSig :: Sig -> CBOR.Encoding
104+
encodeSig Sig { sigId,
105+
sigBody,
106+
sigExpiresAt,
107+
sigKesSignature,
108+
sigOpCertificate
109+
}
110+
= CBOR.encodeListLen 5
111+
<> encodeSigId sigId
112+
<> CBOR.encodeBytes (getSigBody sigBody)
113+
<> CBOR.encodeWord32 (floor sigExpiresAt)
114+
<> CBOR.encodeBytes (getSigKesSignature sigKesSignature)
115+
<> CBOR.encodeBytes (getSigOpCertificate sigOpCertificate)
116+
117+
118+
decodeSig :: forall s. CBOR.Decoder s Sig
119+
decodeSig = do
120+
a <- CBOR.decodeListLen
121+
when (a /= 5) $ fail (printf "codecSigSubmission: unexpected number of parameters %d" a)
122+
sigId <- decodeSigId
123+
sigBody <- SigBody <$> CBOR.decodeBytes
124+
sigExpiresAt <- realToFrac <$> CBOR.decodeWord32
125+
sigKesSignature <- SigKesSignature <$> CBOR.decodeBytes
126+
sigOpCertificate <- SigOpCertificate <$> CBOR.decodeBytes
127+
return Sig {
128+
sigId,
129+
sigBody,
130+
sigExpiresAt,
131+
sigKesSignature,
132+
sigOpCertificate
133+
}
122134

123135

124136
codecSigSubmissionId

‎decentralized-message-queue/test/Main.hs‎

Lines changed: 7 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,8 @@ import Main.Utf8 (withUtf8)
44

55
import Test.DMQ.NodeToClient qualified
66
import Test.DMQ.NodeToNode qualified
7+
import Test.DMQ.Protocol.LocalMsgNotification qualified
8+
import Test.DMQ.Protocol.LocalMsgSubmission qualified
79
import Test.DMQ.Protocol.SigSubmission qualified
810

911
import Test.Tasty
@@ -15,8 +17,12 @@ main = withUtf8 $ defaultMain tests
1517

1618
tests :: TestTree
1719
tests =
18-
testGroup "decentralised-message-queue:testse"
20+
testGroup "decentralised-message-queue:tests"
1921
[ Test.DMQ.NodeToClient.tests
2022
, Test.DMQ.NodeToNode.tests
23+
24+
-- protocols
2125
, Test.DMQ.Protocol.SigSubmission.tests
26+
, Test.DMQ.Protocol.LocalMsgSubmission.tests
27+
, Test.DMQ.Protocol.LocalMsgNotification.tests
2228
]

‎decentralized-message-queue/test/Test/DMQ/Protocol/LocalMsgNotification.hs‎

Lines changed: 117 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,117 @@
1+
{-# LANGUAGE FlexibleContexts, FlexibleInstances #-}
2+
3+
{-# OPTIONS_GHC -Wno-orphans #-}
4+
5+
module Test.DMQ.Protocol.LocalMsgNotification where
6+
7+
import Codec.Serialise (DeserialiseFailure, Serialise)
8+
import Control.Monad.Class.MonadST (MonadST)
9+
import Control.Monad.ST (runST)
10+
import Data.ByteString.Lazy (ByteString)
11+
import Data.List.NonEmpty qualified as NonEmpty
12+
-- import GHC.Generics
13+
-- import Test.Data.CDDL (Any (..))
14+
import Test.QuickCheck qualified as QC
15+
import Test.Tasty
16+
import Test.Tasty.QuickCheck
17+
18+
import DMQ.Protocol.LocalMsgNotification.Codec
19+
import DMQ.Protocol.LocalMsgNotification.Type
20+
import DMQ.Protocol.SigSubmission.Codec
21+
import DMQ.Protocol.SigSubmission.Type hiding (SingBlockingStyle (..), BlockingReplyList (..))
22+
import Network.TypedProtocol.Codec hiding (prop_codec)
23+
import Test.DMQ.Protocol.SigSubmission ()
24+
import Test.Ouroboros.Network.Utils
25+
26+
27+
tests :: TestTree
28+
tests =
29+
testGroup "DMQ.Protocol"
30+
[ testGroup "LocalMsgNotification"
31+
[ testProperty "codec" prop_codec
32+
--, testProperty "codec 2-splits" prop_codec_splits2
33+
]
34+
]
35+
36+
-- from sigsubmission
37+
-- , testProperty "codec id" prop_codec_id
38+
-- , testProperty "codec 2-splits" prop_codec_splits2
39+
-- , testProperty "codec 3-splits" $ withMaxSize 10
40+
-- prop_codec_splits3
41+
-- , testProperty "codec cbor" prop_codec_cbor
42+
-- , testProperty "codec valid cbor" prop_codec_valid_cbor
43+
44+
-- | Check the codec round trip property.
45+
--
46+
prop_codec :: AnyMessage (LocalMsgNotification Sig) -> Bool
47+
prop_codec msg = runST (prop_codecM codec msg)
48+
49+
prop_codec_splits2 = undefined
50+
51+
-- prop_codec_splits2 :: AnyMessage (LocalMsgNotification Sig) -> Bool
52+
-- prop_codec_splits2 msg =
53+
-- runST (prop_codec_splitsM splits2 codecSigSubmission msg)
54+
55+
-- prop_codec_splits3 :: AnyMessage (LocalMsgNotification Sig) -> Property
56+
-- prop_codec_splits3 msg =
57+
-- labelMsg msg $
58+
-- runST (prop_codec_splitsM splits3 codecSigSubmission msg)
59+
60+
--
61+
-- Common utilities and types used in the tests in this module.
62+
--
63+
64+
codec :: MonadST m
65+
=> Codec (LocalMsgNotification Sig)
66+
DeserialiseFailure m
67+
ByteString
68+
codec = codecLocalMsgNotification encodeSig decodeSig
69+
70+
instance Arbitrary HasMore where
71+
arbitrary = elements [HasMore, DoesNotHaveMore]
72+
73+
instance Arbitrary msg => Arbitrary (AnyMessage (LocalMsgNotification msg)) where
74+
arbitrary = oneof
75+
[ pure . AnyMessage . MsgRequest $ SingBlocking
76+
, pure . AnyMessage . MsgRequest $ SingNonBlocking
77+
, AnyMessage <$>
78+
((MsgReply . BlockingReply . NonEmpty.fromList . QC.getNonEmpty <$> arbitrary) <*> arbitrary)
79+
, AnyMessage <$>
80+
((MsgReply . NonBlockingReply <$> arbitrary) <*> arbitrary)
81+
, pure $ AnyMessage MsgServerDone
82+
, pure $ AnyMessage MsgClientDone
83+
]
84+
85+
86+
instance (Eq msg) => Eq (AnyMessage (LocalMsgNotification msg)) where
87+
(==) (AnyMessage (MsgRequest SingBlocking))
88+
(AnyMessage (MsgRequest SingBlocking)) = True
89+
90+
(==) (AnyMessage (MsgRequest SingNonBlocking))
91+
(AnyMessage (MsgRequest SingNonBlocking)) = True
92+
93+
(==) (AnyMessage (MsgReply (BlockingReply msgs) hasMore))
94+
(AnyMessage (MsgReply (BlockingReply msgs') hasMore')) =
95+
(msgs, hasMore) == (msgs', hasMore')
96+
97+
(==) (AnyMessage (MsgReply (NonBlockingReply msgs) hasMore))
98+
(AnyMessage (MsgReply (NonBlockingReply msgs') hasMore')) =
99+
(msgs, hasMore) == (msgs', hasMore')
100+
101+
(==) (AnyMessage MsgServerDone)
102+
(AnyMessage MsgServerDone) = True
103+
104+
(==) (AnyMessage MsgClientDone)
105+
(AnyMessage MsgClientDone) = True
106+
107+
_ == _ = False
108+
109+
110+
labelMsg :: AnyMessage (LocalMsgNotification Sig) -> Bool -> Property
111+
labelMsg (AnyMessage msg) =
112+
label (case msg of
113+
MsgRequest {} -> "MsgRequest"
114+
MsgReply as _more -> "MsgReply " ++ renderRanges 3 (length as)
115+
MsgServerDone -> "MsgServerDone"
116+
MsgClientDone -> "MsgClientDone"
117+
)

‎decentralized-message-queue/test/Test/DMQ/Protocol/LocalMsgSubmission.hs‎

Lines changed: 44 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,44 @@
1+
-- {-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
2+
-- {-# OPTIONS_GHC -Wno-orphans #-}
3+
4+
module Test.DMQ.Protocol.LocalMsgSubmission where
5+
6+
-- import Codec.Serialise (DeserialiseFailure, Serialise)
7+
-- import Codec.Serialise qualified as Serialise (decode, encode)
8+
-- import Control.Monad.Class.MonadST
9+
-- import Control.Monad.ST (runST)
10+
-- import Data.ByteString.Lazy (ByteString)
11+
-- import GHC.Generics
12+
13+
-- import DMQ.Protocol.LocalMsgSubmission.Codec
14+
-- import DMQ.Protocol.LocalMsgSubmission.Type
15+
-- import Network.TypedProtocol.Codec hiding (prop_codec)
16+
import Ouroboros.Network.Protocol.LocalTxSubmission.Test as LocalTxSubmission
17+
18+
import Test.Tasty
19+
-- import Test.Tasty.QuickCheck
20+
-- import Test.QuickCheck
21+
22+
tests :: TestTree
23+
tests = LocalTxSubmission.tests
24+
25+
-- testGroup "DMQ.Protocol"
26+
-- [ testGroup "LocalMsgSubmission"
27+
-- [ testProperty "codec" $ verbose prop_codec
28+
-- ]
29+
-- ]
30+
31+
32+
-- codec :: MonadST m
33+
-- => Codec (LocalMsgSubmission Tx Reject)
34+
-- DeserialiseFailure
35+
-- m ByteString
36+
-- codec = codecLocalMsgSubmission
37+
-- Serialise.encode Serialise.decode
38+
-- Serialise.encode Serialise.decode
39+
40+
41+
-- -- | Check the codec round trip property.
42+
-- --
43+
-- prop_codec :: AnyMessage (LocalMsgSubmission Tx Reject) -> Bool
44+
-- prop_codec msg = runST (prop_codecM codec msg)

0 commit comments

Comments
 (0)