Skip to content

Commit

Permalink
quickcheck-monoids
Browse files Browse the repository at this point in the history
  • Loading branch information
@coot
coot committed Apr 25, 2024
1 parent 204cba0 commit 515d8b3
Show file tree
Hide file tree
Showing 19 changed files with 511 additions and 120 deletions.
1 change: 1 addition & 0 deletions cabal.project
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,7 @@ index-state:

packages: ./cardano-ping
./monoidal-synchronisation
./quickcheck-monoids
./network-mux
./ouroboros-network
./ouroboros-network-api
Expand Down
1 change: 1 addition & 0 deletions flake.nix
View file
Original file line number Diff line number Diff line change
Expand Up @@ -157,6 +157,7 @@
packages.ouroboros-network-protocols.components.tests.cddl.preCheck = "export HOME=`pwd`";

# don't run checks using Wine when cross compiling
packages.quickcheck-monoids.components.tests.test.doCheck = !pkgs.stdenv.hostPlatform.isWindows;
packages.ntp-client.components.tests.test.doCheck = !pkgs.stdenv.hostPlatform.isWindows;
packages.network-mux.components.tests.test.doCheck = !pkgs.stdenv.hostPlatform.isWindows;
packages.network-mux.components.tests.test.preCheck = "export GHCRTS=-M500M";
Expand Down
2 changes: 2 additions & 0 deletions ouroboros-network-framework/ouroboros-network-framework.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -142,6 +142,7 @@ library testlib
, serialise

, QuickCheck
, quickcheck-monoids

, contra-tracer
, io-sim
Expand Down Expand Up @@ -194,6 +195,7 @@ test-suite sim-tests

, QuickCheck
, quickcheck-instances
, quickcheck-monoids
, tasty
, tasty-quickcheck

Expand Down
79 changes: 39 additions & 40 deletions ouroboros-network-framework/sim-tests/Test/Ouroboros/Network/Server2/Sim.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -58,6 +58,7 @@ import Data.Typeable (Typeable)
import Text.Printf

import Test.QuickCheck
import Test.QuickCheck.Monoids (All (..), getAllProperty)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.QuickCheck

Expand Down Expand Up @@ -941,7 +942,7 @@ validate_transitions mns@(MultiNodeScript events _) trace =
)
. getAllProperty
. foldMap ( \ tr
-> AllProperty
-> All
. (counterexample $!
( "\nUnexpected transition: "
++ show tr)
Expand Down Expand Up @@ -1098,14 +1099,13 @@ prop_connection_manager_no_invalid_traces serverAcc (ArbDataFlow dataFlow)
. bifoldMap
( \ case
MainReturn {} -> mempty
v -> AllProperty (counterexample (show v) False)
v -> All (counterexample (show v) False)
)
( \ tr
-> case tr of
CM.TrUnexpectedlyFalseAssertion _ ->
AllProperty (counterexample (show tr) False)
_ ->
mempty
CM.TrUnexpectedlyFalseAssertion _
-> All (counterexample (show tr) False)
_ -> mempty
)
$ connectionManagerEvents
where
Expand Down Expand Up @@ -1143,7 +1143,7 @@ prop_connection_manager_valid_transition_order serverAcc (ArbDataFlow dataFlow)
. bifoldMap
( \ case
MainReturn {} -> mempty
_ -> AllProperty (property False)
_ -> All False
)
(verifyAbstractTransitionOrder True)
. fmap (map ttTransition)
Expand Down Expand Up @@ -1183,7 +1183,7 @@ prop_connection_manager_valid_transition_order_racy serverAcc (ArbDataFlow dataF
. bifoldMap
( \ case
MainReturn {} -> mempty
_ -> AllProperty (property False)
_ -> All False
)
(verifyAbstractTransitionOrder True)
. fmap (map ttTransition)
Expand Down Expand Up @@ -1247,12 +1247,12 @@ prop_connection_manager_counters serverAcc (ArbDataFlow dataFlow)
. bifoldMap
( \ case
MainReturn {} -> mempty
v -> AllProperty
$ counterexample (show v) (property False)
v -> All
$ counterexample (show v) False
)
( \ case
TrConnectionManagerCounters cmc ->
AllProperty
All
$ counterexample
("Upper bound is: " ++ show upperBound
++ "\n But got: " ++ show cmc)
Expand Down Expand Up @@ -1476,9 +1476,9 @@ prop_inbound_governor_valid_transitions serverAcc (ArbDataFlow dataFlow)
-- Verify that all Inbound Governor remote transitions are valid
. getAllProperty
. bifoldMap
( \ _ -> AllProperty (property True) )
( \ _ -> All True )
( \ TransitionTrace {ttPeerAddr = peerAddr, ttTransition = tr} ->
AllProperty
All
. counterexample (concat [ "Unexpected transition: "
, show peerAddr
, " "
Expand Down Expand Up @@ -1523,25 +1523,25 @@ prop_inbound_governor_no_unsupported_state serverAcc (ArbDataFlow dataFlow)
-- RemoteTransitionTrace
. getAllProperty
. bifoldMap
( \ _ -> AllProperty (property True))
( \ _ -> All True)
( \ tr -> case tr of
-- verify that 'unregisterInboundConnection' does not return
-- 'UnsupportedState'.
TrDemotedToColdRemote _ res ->
case res of
UnsupportedState {}
-> AllProperty (counterexample (show tr) False)
_ -> AllProperty (property True)
-> All (counterexample (show tr) False)
_ -> All True

-- verify that 'demotedToColdRemote' does not return
-- 'UnsupportedState'
TrWaitIdleRemote _ res ->
case res of
UnsupportedState {}
-> AllProperty (counterexample (show tr) False)
_ -> AllProperty (property True)
-> All (counterexample (show tr) False)
_ -> All True

_ -> AllProperty (property True)
_ -> All True
)
$ inboundGovernorEvents
where
Expand Down Expand Up @@ -1584,14 +1584,13 @@ prop_inbound_governor_no_invalid_traces serverAcc (ArbDataFlow dataFlow)
. bifoldMap
( \ case
MainReturn {} -> mempty
v -> AllProperty (counterexample (show v) False)
v -> All (counterexample (show v) False)
)
( \ tr
-> case tr of
IG.TrUnexpectedlyFalseAssertion _ ->
AllProperty (counterexample (show tr) False)
_ ->
mempty
IG.TrUnexpectedlyFalseAssertion _
-> All (counterexample (show tr) False)
_ -> mempty
)
$ inboundGovernorEvents
where
Expand Down Expand Up @@ -1668,7 +1667,7 @@ prop_inbound_governor_valid_transition_order serverAcc (ArbDataFlow dataFlow)
. bifoldMap
( \ case
MainReturn {} -> mempty
_ -> AllProperty (property False)
_ -> All False
)
(verifyRemoteTransitionOrder True)
. fmap (map ttTransition)
Expand Down Expand Up @@ -1710,12 +1709,12 @@ prop_inbound_governor_counters serverAcc (ArbDataFlow dataFlow)
. bifoldMap
(\ case
MainReturn {} -> mempty
v -> AllProperty
$ counterexample (show v) (property False)
v -> All
$ counterexample (show v) (property False)
)
(\ case
TrInboundGovernorCounters igc ->
AllProperty
All
$ counterexample
("Upper bound is: " ++ show upperBound
++ "\n But got: " ++ show igc)
Expand Down Expand Up @@ -1831,7 +1830,7 @@ prop_connection_manager_pruning serverAcc
)
. getAllProperty
. foldMap ( \ tr
-> AllProperty
-> All
. (counterexample $!
( "\nUnexpected transition: "
++ show tr)
Expand Down Expand Up @@ -1898,7 +1897,7 @@ prop_inbound_governor_pruning serverAcc
-- . counterexample (ppTrace trace)
. getAllProperty
. bifoldMap
(\ _ -> AllProperty (property True) )
(\ _ -> All True)
(\ case
Left tr ->
case tr of
Expand All @@ -1907,30 +1906,30 @@ prop_inbound_governor_pruning serverAcc
TrDemotedToColdRemote _ res ->
case res of
UnsupportedState {} ->
AllProperty
All
$ counterexample
("Unexpected UnsupportedState "
++ "in unregisterInboundConnection "
++ show tr)
False
_ -> AllProperty (property True)
_ -> All True

-- verify that 'demotedToColdRemote' does not return
-- 'UnsupportedState'
TrWaitIdleRemote _ UnsupportedState {} ->
AllProperty
All
$ counterexample
("Unexpected UnsupportedState "
++ "in demotedToColdRemote "
++ show tr)
False

_ -> AllProperty (property True)
_ -> All True

-- Verify we do not return unsupported states in any of the
-- RemoteTransitionTrace
Right TransitionTrace {ttPeerAddr = peerAddr, ttTransition = tr } ->
AllProperty
All
. counterexample (concat [ "Unexpected transition: "
, show peerAddr
, " "
Expand Down Expand Up @@ -1992,12 +1991,12 @@ prop_never_above_hardlimit serverAcc
( \ case
MainReturn {} -> mempty
MainException _ _ e _
-> AllProperty (counterexample (show e) False)
_ -> AllProperty (property False)
-> All (counterexample (show e) False)
_ -> All False
)
( \ case
(TrConnectionManagerCounters cmc) ->
AllProperty
All
. counterexample ("HardLimit: " ++ show hardlimit ++
", but got: " ++ show (inboundConns cmc) ++
" inbound connections!\n" ++
Expand All @@ -2006,7 +2005,7 @@ prop_never_above_hardlimit serverAcc
. property
$! inboundConns cmc <= fromIntegral hardlimit
(TrPruneConnections prunnedSet numberToPrune choiceSet) ->
( AllProperty
( All
. counterexample (concat
[ "prunned set too small: "
, show numberToPrune
Expand All @@ -2015,7 +2014,7 @@ prop_never_above_hardlimit serverAcc
])
$ numberToPrune <= length prunnedSet )
<>
( AllProperty
( All
. counterexample (concat [ "prunnedSet not a subset of choice set: "
, show prunnedSet
, " ⊈ "
Expand Down
17 changes: 5 additions & 12 deletions ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Timeouts.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@ import Text.Printf (printf)

import Test.QuickCheck (Arbitrary (..), Property, choose, counterexample, cover,
frequency, label, property, shrink, tabulate, (.&&.))
import Test.QuickCheck.Monoids (All (..))

import Network.TypedProtocol.Core (PeerHasAgency (..))

Expand All @@ -32,16 +33,16 @@ import Ouroboros.Network.Snocket qualified as Snocket
verifyAllTimeouts :: Show addr
=> Bool
-> Trace (SimResult ()) [(Time, AbstractTransitionTrace addr)]
-> AllProperty
-> All
verifyAllTimeouts inDiffusion =
bifoldMap
( \ case
MainReturn {} -> mempty
v -> AllProperty
$ counterexample (show v) (property False)
v -> All
$ counterexample (show v) False
)
(\ tr ->
AllProperty
All
$ counterexample ("\nConnection transition trace:\n"
++ intercalate "\n" (map show tr)
)
Expand Down Expand Up @@ -526,14 +527,6 @@ classifyPruning
classifyPruning TrPruneConnections {} = Sum 1
classifyPruning _ = Sum 0

newtype AllProperty = AllProperty { getAllProperty :: Property }

instance Semigroup AllProperty where
AllProperty a <> AllProperty b = AllProperty (a .&&. b)

instance Monoid AllProperty where
mempty = AllProperty (property True)

newtype ArbDataFlow = ArbDataFlow DataFlow
deriving Show

Expand Down
10 changes: 5 additions & 5 deletions ouroboros-network-framework/testlib/Ouroboros/Network/ConnectionManager/Test/Utils.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -5,10 +5,10 @@ module Ouroboros.Network.ConnectionManager.Test.Utils where
import Prelude hiding (read)

import Ouroboros.Network.ConnectionHandler (ConnectionHandlerTrace)
import Ouroboros.Network.ConnectionManager.Test.Timeouts
import Ouroboros.Network.ConnectionManager.Types

import Test.QuickCheck (counterexample, property)
import Test.QuickCheck.Monoids (All (..))


verifyAbstractTransition :: AbstractTransition
Expand Down Expand Up @@ -189,17 +189,17 @@ verifyAbstractTransitionOrder :: Bool -- ^ Check last transition: useful for
-- distinguish Diffusion layer tests
-- vs non-Diffusion ones.
-> [AbstractTransition]
-> AllProperty
-> All
verifyAbstractTransitionOrder _ [] = mempty
verifyAbstractTransitionOrder checkLast (h:t) = go t h
where
go :: [AbstractTransition] -> AbstractTransition -> AllProperty
go :: [AbstractTransition] -> AbstractTransition -> All
-- All transitions must end in the 'UnknownConnectionSt', and since we
-- assume that all transitions are valid we do not have to check the
-- 'fromState'.
go [] (Transition _ UnknownConnectionSt) = mempty
go [] tr@(Transition _ _) =
AllProperty
All
$ counterexample
("\nUnexpected last transition: " ++ show tr)
(property (not checkLast))
Expand All @@ -208,7 +208,7 @@ verifyAbstractTransitionOrder checkLast (h:t) = go t h
-- the next 'fromState', in order for the transition chain to be correct.
go (next@(Transition nextFromState _) : ts)
curr@(Transition _ currToState) =
AllProperty
All
(counterexample
("\nUnexpected transition order!\nWent from: "
++ show curr ++ "\nto: " ++ show next)
Expand Down

0 comments on commit 515d8b3

Please sign in to comment.