@@ -34,12 +34,14 @@ import Data.Monoid (Sum (..))
34
34
import Data.Sequence.Strict qualified as StrictSeq
35
35
import Data.Set (Set )
36
36
import Data.Set qualified as Set
37
+ import Data.Typeable
37
38
38
39
import NoThunks.Class
39
40
40
41
import Ouroboros.Network.Protocol.TxSubmission2.Type
41
42
import Ouroboros.Network.TxSubmission.Inbound.Decision
42
43
(SharedDecisionContext (.. ), TxDecision (.. ))
44
+ import Ouroboros.Network.TxSubmission.Inbound.Types qualified as TXS
43
45
import Ouroboros.Network.TxSubmission.Inbound.Decision qualified as TXS
44
46
import Ouroboros.Network.TxSubmission.Inbound.Policy
45
47
import Ouroboros.Network.TxSubmission.Inbound.State (PeerTxState (.. ),
@@ -305,7 +307,7 @@ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap =
305
307
where
306
308
mempoolHasTx = apply mempoolHasTxFun
307
309
availableTxIds = Map. fromList
308
- [ (txid, getTxSize tx) | (txid, TxAvailable tx _) <- Map. assocs txMaskMap
310
+ [ (txid, getTxAdvSize tx) | (txid, TxAvailable tx _) <- Map. assocs txMaskMap
309
311
, not (mempoolHasTx txid)
310
312
]
311
313
unknownTxs = Set. fromList
@@ -314,7 +316,7 @@ mkArbPeerTxState mempoolHasTxFun txIdsInflight unacked txMaskMap =
314
316
]
315
317
316
318
requestedTxIdsInflight = fromIntegral txIdsInflight
317
- requestedTxsInflightSize = foldMap getTxSize inflightMap
319
+ requestedTxsInflightSize = foldMap getTxAdvSize inflightMap
318
320
requestedTxsInflight = Map. keysSet inflightMap
319
321
320
322
-- exclude `txid`s which are already in the mempool, we never request such
@@ -758,12 +760,20 @@ instance Arbitrary ArbCollectTxs where
758
760
759
761
receivedTx <- sublistOf requestedTxIds'
760
762
>>= traverse (\ txid -> do
763
+ -- real size, which might be different from
764
+ -- the advertised size
765
+ size <- frequency [ (9 , pure (availableTxIds Map. ! txid))
766
+ , (1 , chooseEnum (0 , maxTxSize))
767
+ ]
768
+
761
769
valid <- frequency [(4 , pure True ), (1 , pure False )]
762
- pure $ Tx { getTxId = txid,
763
- getTxSize = availableTxIds Map. ! txid,
764
- getTxValid = valid })
770
+ pure $ Tx { getTxId = txid,
771
+ getTxSize = size,
772
+ -- `availableTxIds` contains advertised sizes
773
+ getTxAdvSize = availableTxIds Map. ! txid,
774
+ getTxValid = valid })
765
775
766
- pure $ assert (foldMap getTxSize receivedTx <= requestedTxsInflightSize)
776
+ pure $ assert (foldMap getTxAdvSize receivedTx <= requestedTxsInflightSize)
767
777
$ ArbCollectTxs mempoolHasTxFun
768
778
(Set. fromList requestedTxIds')
769
779
(Map. fromList [ (getTxId tx, tx) | tx <- receivedTx ])
@@ -855,24 +865,49 @@ prop_collectTxsImpl (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived p
855
865
label (" number of txids inflight " ++ labelInt 25 5 (Map. size $ inflightTxs st)) $
856
866
label (" number of txids requested " ++ labelInt 25 5 (Set. size txidsRequested)) $
857
867
label (" number of txids received " ++ labelInt 10 2 (Map. size txsReceived)) $
858
-
859
- -- InboundState invariant
860
- counterexample
861
- ( " InboundState invariant violation:\n " ++ show st' ++ " \n "
862
- ++ show ps'
863
- )
864
- (sharedTxStateInvariant st')
865
-
866
- .&&.
867
- -- `collectTxsImpl` doesn't modify unacknowledged TxId's
868
- counterexample " acknowledged property violation"
869
- ( let unacked = toList $ unacknowledgedTxIds ps
870
- unacked' = toList $ unacknowledgedTxIds ps'
871
- in unacked === unacked'
872
- )
868
+ label (" hasTxSizeError " ++ show hasTxSizeErr) $
869
+
870
+ case TXS. collectTxsImpl getTxSize peeraddr txidsRequested txsReceived st of
871
+ Right st' | not hasTxSizeErr ->
872
+ let ps' = peerTxStates st' Map. ! peeraddr in
873
+ -- InboundState invariant
874
+ counterexample
875
+ ( " InboundState invariant violation:\n " ++ show st' ++ " \n "
876
+ ++ show ps'
877
+ )
878
+ (sharedTxStateInvariant st')
879
+
880
+ .&&.
881
+ -- `collectTxsImpl` doesn't modify unacknowledged TxId's
882
+ counterexample " acknowledged property violation"
883
+ ( let unacked = toList $ unacknowledgedTxIds ps
884
+ unacked' = toList $ unacknowledgedTxIds ps'
885
+ in unacked === unacked'
886
+ )
887
+
888
+ Right _ ->
889
+ counterexample " collectTxsImpl should return Left"
890
+ . counterexample (show txsReceived)
891
+ $ False
892
+ Left _ | not hasTxSizeErr ->
893
+ counterexample " collectTxsImpl should return Right" False
894
+
895
+ Left (TXS. ProtocolErrorTxSizeError as) ->
896
+ counterexample (show as)
897
+ $ Set. fromList ((\ (txid, _, _) -> coerceTxId txid) `map` as)
898
+ ===
899
+ Map. keysSet (Map. filter (\ tx -> getTxSize tx /= getTxAdvSize tx) txsReceived)
900
+ Left e ->
901
+ counterexample (" unexpected error: " ++ show e) False
873
902
where
874
- st' = TXS. collectTxsImpl peeraddr txidsRequested txsReceived st
875
- ps' = peerTxStates st' Map. ! peeraddr
903
+ hasTxSizeErr = any (\ tx -> getTxSize tx /= getTxAdvSize tx) txsReceived
904
+
905
+ -- The `ProtocolErrorTxSizeError` type is an existential type. We know that
906
+ -- the type of `txid` is `TxId`, we just don't have evidence for it.
907
+ coerceTxId :: Typeable txid => txid -> TxId
908
+ coerceTxId txid = case cast txid of
909
+ Just a -> a
910
+ Nothing -> error " impossible happened! Is the test still using `TxId` for `txid`?"
876
911
877
912
878
913
-- | Verify that `SharedTxState` returned by `collectTxsImpl` if evaluated to
@@ -882,11 +917,11 @@ prop_collectTxsImpl_nothunks
882
917
:: ArbCollectTxs
883
918
-> Property
884
919
prop_collectTxsImpl_nothunks (ArbCollectTxs _mempoolHasTxFun txidsRequested txsReceived peeraddr _ st) =
885
- case unsafeNoThunks $! st' of
886
- Nothing -> property True
887
- Just ctx -> counterexample ( show ctx) False
888
- where
889
- st' = TXS. collectTxsImpl peeraddr txidsRequested txsReceived st
920
+ case TXS. collectTxsImpl getTxSize peeraddr txidsRequested txsReceived st of
921
+ Right st' -> case unsafeNoThunks $! st' of
922
+ Nothing -> property True
923
+ Just ctx -> counterexample ( show ctx) False
924
+ Left _ -> property True
890
925
891
926
892
927
newtype ArbTxDecisionPolicy = ArbTxDecisionPolicy TxDecisionPolicy
0 commit comments