diff --git a/cabal.project b/cabal.project index 7775fa386c9..1af0f24c817 100644 --- a/cabal.project +++ b/cabal.project @@ -5,6 +5,7 @@ packages: ./typed-protocols ./typed-protocols-examples ./ouroboros-network-testing ./monoidal-synchronisation + ./monoidal-synchronisation-test ./network-mux ./ouroboros-network-framework ./ouroboros-network @@ -40,6 +41,9 @@ package Win32-network package io-classes flags: +asserts +package monoidal-synchronisation-test + tests: True + package strict-stm flags: +asserts diff --git a/io-sim/io-sim.cabal b/io-sim/io-sim.cabal index 0dcfddbed11..78e7e09fdf7 100644 --- a/io-sim/io-sim.cabal +++ b/io-sim/io-sim.cabal @@ -52,6 +52,7 @@ library io-classes >=0.2 && <0.3, exceptions >=0.10, containers, + monoidal-synchronisation, parallel, pretty-simple, psqueues >=0.2 && <0.3, diff --git a/io-sim/src/Control/Monad/IOSim/Types.hs b/io-sim/src/Control/Monad/IOSim/Types.hs index cc18ff0592a..3438940d8f5 100644 --- a/io-sim/src/Control/Monad/IOSim/Types.hs +++ b/io-sim/src/Control/Monad/IOSim/Types.hs @@ -97,7 +97,8 @@ import Data.Bifoldable import Data.Bifunctor (bimap) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe) -import Data.Monoid (Endo (..)) +import Data.Monoid (Alt (..), Endo (..)) +import Data.Monoid.Synchronisation import Data.Dynamic (Dynamic, toDyn) import Data.Semigroup (Max (..)) import Data.Typeable @@ -929,3 +930,51 @@ withStepTimelimit n e = e{explorationStepTimelimit = Just n} withReplay :: ScheduleControl -> ExplorationSpec withReplay r e = e{explorationReplay = Just r} + + +instance Semigroup (FirstToFinish (IOSim s) a) where + FirstToFinish a <> FirstToFinish b = FirstToFinish $ either id id <$> race a b + +instance Monoid (FirstToFinish (IOSim s) a) where + mempty = FirstToFinish $ forever $ threadDelay 3600 + +instance Semigroup (FirstToFinish (STM s) a) where + FirstToFinish a <> FirstToFinish b = FirstToFinish . getAlt + $ Alt a <|> Alt b +instance Monoid (FirstToFinish (STM s) a) where + mempty = FirstToFinish . getAlt $ mempty + +instance Semigroup (LastToFinish (IOSim s) a) where + LastToFinish left <> LastToFinish right = LastToFinish $ do + withAsync left $ \a -> + withAsync right $ \b -> + MonadSTM.atomically $ runLastToFinish $ + LastToFinish (waitSTM a) + <> LastToFinish (waitSTM b) + +instance Semigroup (LastToFinish (STM s) a) where + LastToFinish left <> LastToFinish right = LastToFinish $ do + a <- Left <$> left + <|> Right <$> right + case a of + Left {} -> right + Right {} -> left + +instance Semigroup (LastToFinishM (IOSim s) a) where + LastToFinishM left <> LastToFinishM right = LastToFinishM $ do + withAsync left $ \a -> + withAsync right $ \b -> + MonadSTM.atomically $ runLastToFinishM $ + LastToFinishM (waitSTM a) + <> LastToFinishM (waitSTM b) + +instance Semigroup (LastToFinishM (STM s) a) where + LastToFinishM left <> LastToFinishM right = LastToFinishM $ do + a <- Left <$> left + <|> Right <$> right + case a of + Left {} -> right + Right {} -> left + +instance Monoid a => Monoid (LastToFinishM (STM s) a) where + mempty = LastToFinishM (pure mempty) diff --git a/monoidal-synchronisation-test/monoidal-synchronisation-test.cabal b/monoidal-synchronisation-test/monoidal-synchronisation-test.cabal new file mode 100644 index 00000000000..be09717bd47 --- /dev/null +++ b/monoidal-synchronisation-test/monoidal-synchronisation-test.cabal @@ -0,0 +1,50 @@ +cabal-version: 2.4 +name: monoidal-synchronisation-test +version: 0.1.0.0 + +-- A short (one-line) description of the package. +-- synopsis: + +-- A longer description of the package. +-- description: + +-- A URL where users can report bugs. +-- bug-reports: + +-- The license under which the package is released. +license: Apache-2.0 +license-files: + LICENSE + NOTICE +author: Marcin Szamotulski +maintainer: coot@coot.me + +copyright: 2021 Input Output (Hong Kong) Ltd. +extra-source-files: CHANGELOG.md + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + other-modules: Test.Data.Monoid.Synchronisation + build-depends: base + + , QuickCheck + , tasty + , tasty-quickcheck + + , io-classes + , io-sim + , monoidal-synchronisation + default-language: Haskell2010 + ghc-options: -rtsopts + -threaded + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wno-unticked-promoted-constructors + diff --git a/monoidal-synchronisation/test/Main.hs b/monoidal-synchronisation-test/test/Main.hs similarity index 100% rename from monoidal-synchronisation/test/Main.hs rename to monoidal-synchronisation-test/test/Main.hs diff --git a/monoidal-synchronisation/test/Test/Data/Monoid/Synchronisation.hs b/monoidal-synchronisation-test/test/Test/Data/Monoid/Synchronisation.hs similarity index 85% rename from monoidal-synchronisation/test/Test/Data/Monoid/Synchronisation.hs rename to monoidal-synchronisation-test/test/Test/Data/Monoid/Synchronisation.hs index 838aa40c7c2..fda3b4ef020 100644 --- a/monoidal-synchronisation/test/Test/Data/Monoid/Synchronisation.hs +++ b/monoidal-synchronisation-test/test/Test/Data/Monoid/Synchronisation.hs @@ -1,5 +1,7 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE QuantifiedConstraints #-} module Test.Data.Monoid.Synchronisation where import Control.Monad.Class.MonadFork @@ -24,6 +26,8 @@ lastToFinishExperiment :: forall m. ( MonadFork m , MonadSTM m + , forall a stm. stm ~ STM m + => Semigroup (LastToFinish stm a) ) => Bool -> m Bool lastToFinishExperiment writeInSingleTransaction = do diff --git a/monoidal-synchronisation/monoidal-synchronisation.cabal b/monoidal-synchronisation/monoidal-synchronisation.cabal index 3454e051822..b5015eb6d72 100644 --- a/monoidal-synchronisation/monoidal-synchronisation.cabal +++ b/monoidal-synchronisation/monoidal-synchronisation.cabal @@ -27,6 +27,8 @@ extra-source-files: CHANGELOG.md library exposed-modules: Data.Monoid.Synchronisation build-depends: base >=4.9 && <4.15 + , async + , stm hs-source-dirs: src default-language: Haskell2010 ghc-options: -rtsopts @@ -39,29 +41,3 @@ library -Widentities -Wredundant-constraints -Wno-unticked-promoted-constructors - -test-suite test - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - other-modules: Test.Data.Monoid.Synchronisation - build-depends: base - - , QuickCheck - , tasty - , tasty-quickcheck - - , io-classes - , io-sim - , monoidal-synchronisation - default-language: Haskell2010 - ghc-options: -rtsopts - -threaded - -Wall - -Wcompat - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wpartial-fields - -Widentities - -Wredundant-constraints - -Wno-unticked-promoted-constructors diff --git a/monoidal-synchronisation/src/Data/Monoid/Synchronisation.hs b/monoidal-synchronisation/src/Data/Monoid/Synchronisation.hs index 32fb3081ca3..091662d8528 100644 --- a/monoidal-synchronisation/src/Data/Monoid/Synchronisation.hs +++ b/monoidal-synchronisation/src/Data/Monoid/Synchronisation.hs @@ -1,11 +1,16 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE StandaloneKindSignatures #-} module Data.Monoid.Synchronisation ( FirstToFinish (..) @@ -23,7 +28,10 @@ import Data.Monoid (Alt (..), Ap (..)) import GHC.Generics (Generic, Generic1) import Control.Applicative (Alternative (..)) -import Control.Monad (MonadPlus (..)) +import Control.Monad (MonadPlus (..), forever) +import Control.Monad.STM +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async -- | First-to-finish synchronisation. Like 'Alt' it is a monoid under '<|>'. @@ -48,12 +56,23 @@ newtype FirstToFinish m a = FirstToFinish { runFirstToFinish :: m a } , MonadPlus , Traversable ) - deriving Semigroup via (Alt m a) - deriving Monoid via (Alt m a) deriving Foldable via (Alt m) deriving Contravariant via (Alt m) +instance Semigroup (FirstToFinish IO a) where + FirstToFinish a <> FirstToFinish b = FirstToFinish $ either id id <$> race a b + +instance Monoid (FirstToFinish IO a) where + mempty = FirstToFinish $ forever $ threadDelay 3_600_000 + +instance Semigroup (FirstToFinish STM a) where + FirstToFinish a <> FirstToFinish b = FirstToFinish . getAlt + $ Alt a <|> Alt b + +instance Monoid (FirstToFinish STM a) where + mempty = FirstToFinish . getAlt $ mempty + -- | Last-to-finish synchronisation. It is the multiplicative semigroup of -- the [near-semiring](https://www.wikiwand.com/en/Near-semiring) for which addition is -- given by 'FirstToFinish'. @@ -83,7 +102,15 @@ newtype LastToFinish m a = LastToFinish { runLastToFinish :: m a } ) deriving Foldable via (Ap m) -instance MonadPlus m => Semigroup (LastToFinish m a) where +instance Semigroup (LastToFinish IO a) where + LastToFinish left <> LastToFinish right = LastToFinish $ do + withAsync left $ \a -> + withAsync right $ \b -> + atomically $ runLastToFinish $ + LastToFinish (waitSTM a) + <> LastToFinish (waitSTM b) + +instance Semigroup (LastToFinish STM a) where LastToFinish left <> LastToFinish right = LastToFinish $ do a <- Left <$> left <|> Right <$> right @@ -99,9 +126,9 @@ lastToFirst = coerce -- | Last-to-finish synchronisation. Like 'Ap' it is a monoid under '<*>'. --- The advantage over 'LastToFinish' is that it has a 'Monoid' instance, but --- 'a' must be a 'Monoid' as well. 'LastToFinishM' and 'FirstToFinish' form --- a unitial near-ring when @m ~ STM@. +-- The advantage over 'LastToFinish' is that it has a 'Monoid' instance for the +-- stm monad, although 'a' must be a 'Monoid'. 'LastToFinishM' and +-- 'FirstToFinish' form a unitial near-ring when @m ~ STM@. -- -- > -- | Read all 'TMVar's and combine the result using 'Monoid' instance. -- > -- @@ -119,10 +146,27 @@ newtype LastToFinishM m a = LastToFinishM { runLastToFinishM :: m a } , MonadPlus , Traversable ) - deriving Semigroup via (Ap m a) - deriving Monoid via (Ap m a) deriving Foldable via (Ap m) +instance Semigroup (LastToFinishM IO a) where + LastToFinishM left <> LastToFinishM right = LastToFinishM $ do + withAsync left $ \a -> + withAsync right $ \b -> + atomically $ runLastToFinishM $ + LastToFinishM (waitSTM a) + <> LastToFinishM (waitSTM b) + +instance Semigroup (LastToFinishM STM a) where + LastToFinishM left <> LastToFinishM right = LastToFinishM $ do + a <- Left <$> left + <|> Right <$> right + case a of + Left {} -> right + Right {} -> left + +instance Monoid a => Monoid (LastToFinishM STM a) where + mempty = LastToFinishM (pure mempty) + firstToLastM :: FirstToFinish m a -> LastToFinishM m a firstToLastM = coerce diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index d1e0e5202ca..0bf0efa5672 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -126,6 +126,7 @@ test-suite test strict-stm, io-sim >=0.2 && < 0.3, contra-tracer, + monoidal-synchronisation, network-mux, Win32-network, diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index 1ff05f9d04e..c5ceeb0e0a8 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GADTSyntax #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -203,6 +204,8 @@ runMux :: forall m mode. , MonadTime m , MonadTimer m , MonadMask m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) ) => Tracer m MuxTrace -> Mux mode m @@ -347,6 +350,8 @@ monitor :: forall mode m. , MonadAsync m , MonadMask m , MonadThrow (STM m) + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) ) => Tracer m MuxTrace -> TimeoutFn m diff --git a/network-mux/src/Network/Mux/Compat.hs b/network-mux/src/Network/Mux/Compat.hs index cbefd71a8f8..22ae935c4f9 100644 --- a/network-mux/src/Network/Mux/Compat.hs +++ b/network-mux/src/Network/Mux/Compat.hs @@ -4,6 +4,7 @@ {-# LANGUAGE GADTSyntax #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} @@ -34,6 +35,7 @@ module Network.Mux.Compat import qualified Data.ByteString.Lazy as BL import Data.Void (Void) +import Data.Monoid.Synchronisation import Control.Applicative ((<|>)) import Control.Monad @@ -94,6 +96,8 @@ muxStart , MonadTime m , MonadTimer m , MonadMask m + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) ) => Tracer m MuxTrace -> MuxApplication mode m a b diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index cad91311716..813df3f4642 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -4,9 +4,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-orphans #-} @@ -26,6 +28,7 @@ import qualified Data.ByteString.Lazy.Char8 as BL8 (pack) import Data.List (dropWhileEnd, nub) import qualified Data.List as List import qualified Data.Map as M +import Data.Monoid.Synchronisation (FirstToFinish) import Data.Tuple (swap) import Data.Word import qualified System.Random.SplitMix as SM @@ -982,17 +985,19 @@ encodeInvalidMuxSDU sdu = -- | Verify ingress processing of valid and invalid SDUs. -- prop_demux_sdu :: forall m. - ( MonadAsync m - , MonadFork m - , MonadLabelledSTM m - , MonadMask m - , MonadSay m - , MonadThrow (STM m) - , MonadTime m - , MonadTimer m - ) - => ArbitrarySDU - -> m Property + ( MonadAsync m + , MonadFork m + , MonadLabelledSTM m + , MonadMask m + , MonadSay m + , MonadThrow (STM m) + , MonadTime m + , MonadTimer m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) + ) + => ArbitrarySDU + -> m Property prop_demux_sdu a = do r <- run a return $ tabulate "SDU type" [stateLabel a] $ @@ -1092,7 +1097,7 @@ prop_demux_sdu a = do serverRes <- runMiniProtocol serverMux (miniProtocolNum serverApp) (miniProtocolDir serverApp) StartEagerly server_mp - said <- async $ runMux serverTracer serverMux serverBearer + said <- async $ runMux @m serverTracer serverMux serverBearer return (server_r, said, serverRes, serverMux) -- Server that expects to receive a specific ByteString. @@ -1299,6 +1304,8 @@ prop_mux_start_mX :: forall m. , MonadThrow (STM m) , MonadTime m , MonadTimer m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) ) => DummyApps -> DiffTime @@ -1345,6 +1352,8 @@ prop_mux_restart_m :: forall m. , MonadThrow (STM m) , MonadTime m , MonadTimer m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) ) => DummyRestartingApps -> m Property @@ -1495,6 +1504,8 @@ prop_mux_start_m :: forall m. , MonadThrow (STM m) , MonadTime m , MonadTimer m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) ) => MuxBearer m -> (DummyApp -> m ()) @@ -1715,6 +1726,8 @@ close_experiment , Eq resp , Show req , Show resp + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) ) => Bool -- 'True' for @m ~ IO@ -> FaultInjection diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs index 5e9856c35be..4fccd988c3b 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs @@ -6,6 +6,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -48,6 +49,7 @@ import Control.Monad.Class.MonadTimer import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) +import Data.Monoid.Synchronisation import Data.Typeable (Typeable) import Network.Mux hiding (miniProtocolNum) @@ -184,6 +186,8 @@ makeConnectionHandler , Ord versionNumber , Show peerAddr , Typeable peerAddr + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) ) => Tracer m (WithMuxBearer (ConnectionId peerAddr) MuxTrace) -> SingMuxMode muxMode diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index 5317eb05c42..2ef1323c0f9 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -11,6 +11,8 @@ {-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + -- | The implementation of connection manager. -- module Ouroboros.Network.ConnectionManager.Core @@ -531,6 +533,11 @@ withConnectionManager , MonadMonotonicTime m , MonadThrow (STM m) , MonadTimer m + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Semigroup (LastToFinishM stm x) + , forall x stm. ( stm ~ STM m + , Monoid x + ) => Monoid (LastToFinishM stm x) , Ord peerAddr , Show peerAddr diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index a19a0efddc2..531726670aa 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- 'runResponder' is using a redundant constraint. {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -95,6 +96,12 @@ inboundGovernor :: forall (muxMode :: MuxMode) socket peerAddr versionNumber m a , MonadMask m , Ord peerAddr , HasResponder muxMode ~ True + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Semigroup (LastToFinishM stm x) + , forall x stm. ( stm ~ STM m + , Monoid x + ) => Monoid (LastToFinishM stm x) ) => Tracer m (RemoteTransitionTrace peerAddr) -> Tracer m (InboundGovernorTrace peerAddr) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs index 3e2a9e7874a..d4afa39579e 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs @@ -1,10 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +{-# OPTIONS_GHC -Wno-redundant-constraints #-} -- Internals of inbound protocol governor. This module provide 'Event' type, -- which enumerates external events and stm action which block until these @@ -123,7 +127,10 @@ data Terminated muxMode peerAddr m a b = Terminated { -- -- /triggers:/ 'MiniProtocolTerminated'. -- -firstMiniProtocolToFinish :: MonadSTM m +firstMiniProtocolToFinish :: ( MonadSTM m + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + ) => EventSignal muxMode peerAddr m a b firstMiniProtocolToFinish connId @@ -158,7 +165,10 @@ firstMiniProtocolToFinish -- @Unidirectional@ connections. -- firstPeerPromotedToWarm :: forall muxMode peerAddr m a b. - MonadSTM m + ( MonadSTM m + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + ) => EventSignal muxMode peerAddr m a b firstPeerPromotedToWarm connId @@ -209,7 +219,14 @@ firstPeerPromotedToWarm -- run running). -- firstPeerPromotedToHot :: forall muxMode peerAddr m a b. - MonadSTM m + ( MonadSTM m + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Semigroup (LastToFinishM stm x) + , forall x stm. ( stm ~ STM m + , Monoid x + ) => Monoid (LastToFinishM stm x) + ) => EventSignal muxMode peerAddr m a b firstPeerPromotedToHot connId connState@ConnectionState { csRemoteState } @@ -259,7 +276,10 @@ firstPeerPromotedToHot -- `RemoteHot → RemoteWarm` transition. -- firstPeerDemotedToWarm :: forall muxMode peerAddr m a b. - MonadSTM m + ( MonadSTM m + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + ) => EventSignal muxMode peerAddr m a b firstPeerDemotedToWarm connId connState@ConnectionState { csRemoteState } @@ -303,7 +323,14 @@ firstPeerDemotedToWarm -- -- /triggers:/ 'DemotedToColdRemote' -- -firstPeerDemotedToCold :: MonadSTM m +firstPeerDemotedToCold :: ( MonadSTM m + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Semigroup (LastToFinishM stm x) + , forall x stm. ( stm ~ STM m + , Monoid x + ) => Monoid (LastToFinishM stm x) + ) => EventSignal muxMode peerAddr m a b firstPeerDemotedToCold connId @@ -345,7 +372,10 @@ firstPeerDemotedToCold -- | First peer for which the 'RemoteIdle' timeout expires. -- -firstPeerCommitRemote :: MonadSTM m +firstPeerCommitRemote :: ( MonadSTM m + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + ) => EventSignal muxMode peerAddr m a b firstPeerCommitRemote connId ConnectionState { csRemoteState } diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs index 71bf665f6e6..77b083a6518 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- 'runResponder' is using a redundant constraint. {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -46,6 +47,7 @@ import Data.ByteString.Lazy (ByteString) import Data.List (intercalate) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty +import Data.Monoid.Synchronisation import Data.Void (Void) import GHC.IO.Exception #if !defined(mingw32_HOST_OS) @@ -122,6 +124,12 @@ run :: forall muxMode socket peerAddr versionNumber m a b. , MonadTime m , MonadTimer m , HasResponder muxMode ~ True + , forall x stm. stm ~ STM m => Semigroup (LastToFinishM stm x) + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + , forall x stm. ( stm ~ STM m + , Monoid x + ) => Monoid (LastToFinishM stm x) , Ord peerAddr , Show peerAddr ) diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index 2de4122acd0..36d514605d1 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -1,13 +1,14 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | This module provides simulation environment and a snocket implementation -- suitable for 'IOSim'. @@ -386,6 +387,7 @@ withSnocket , Ord peerAddr , Typeable peerAddr , Show peerAddr + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) ) => Tracer m (WithAddr (TestAddress peerAddr) (SnocketTrace m (TestAddress peerAddr))) @@ -600,6 +602,7 @@ mkSnocket :: forall m addr. , GlobalAddressScheme addr , Ord addr , Show addr + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) ) => NetworkState m (TestAddress addr) -> Tracer m (WithAddr (TestAddress addr) diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index 2b07aafbb06..4852f81e250 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -1,21 +1,22 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} -- for 'debugTracer' {-# OPTIONS_GHC -Wno-redundant-constraints #-} @@ -54,7 +55,7 @@ import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import Data.Maybe (fromJust, fromMaybe, isJust, isNothing) import Data.Monoid (Sum (..)) -import Data.Monoid.Synchronisation (FirstToFinish (..)) +import Data.Monoid.Synchronisation import qualified Data.Set as Set import Data.Typeable (Typeable) import Data.Void (Void) @@ -330,6 +331,12 @@ withInitiatorOnlyConnectionManager , resp ~ [req] , Ord peerAddr, Show peerAddr, Typeable peerAddr , Serialise req, Typeable req + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Semigroup (LastToFinishM stm x) + , forall x stm. ( stm ~ STM m + , Monoid x + ) => Monoid (LastToFinishM stm x) , MonadAsync m , MonadFix m , MonadLabelledSTM m @@ -484,6 +491,12 @@ withBidirectionalConnectionManager , acc ~ [req], resp ~ [req] , Ord peerAddr, Show peerAddr, Typeable peerAddr , Serialise req, Typeable req + , forall x stm. stm ~ STM m => Semigroup (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Monoid (FirstToFinish stm x) + , forall x stm. stm ~ STM m => Semigroup (LastToFinishM stm x) + , forall x stm. ( stm ~ STM m + , Monoid x + ) => Monoid (LastToFinishM stm x) -- debugging , MonadAsync m @@ -744,6 +757,12 @@ unidirectionalExperiment , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Semigroup (LastToFinishM stm a) + , forall a stm. ( stm ~ STM m + , Monoid a + ) => Monoid (LastToFinishM stm a) , acc ~ [req], resp ~ [req] , Ord peerAddr, Show peerAddr, Typeable peerAddr, Eq peerAddr @@ -846,6 +865,12 @@ bidirectionalExperiment , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Semigroup (LastToFinishM stm a) + , forall a stm. ( stm ~ STM m + , Monoid a + ) => Monoid (LastToFinishM stm a) , acc ~ [req], resp ~ [req] , Ord peerAddr, Show peerAddr, Typeable peerAddr, Eq peerAddr @@ -1458,6 +1483,12 @@ multinodeExperiment , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Semigroup (LastToFinishM stm a) + , forall a stm. ( stm ~ STM m + , Monoid a + ) => Monoid (LastToFinishM stm a) , acc ~ [req], resp ~ [req] , Ord peerAddr, Show peerAddr, Typeable peerAddr, Eq peerAddr , Serialise req, Show req @@ -3484,6 +3515,12 @@ multiNodeSimTracer :: ( Monad m, MonadFix m, MonadTimer m, MonadLabelledSTM m , MonadThrow (STM m), MonadSay m, MonadAsync m , MonadEvaluate m, MonadFork m, MonadST m , Serialise req, Show req, Eq req, Typeable req + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Semigroup (LastToFinishM stm a) + , forall a stm. ( stm ~ STM m + , Monoid a + ) => Monoid (LastToFinishM stm a) ) => req -> DataFlow diff --git a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs index 382c592718f..52e560ad13c 100644 --- a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs @@ -1,15 +1,16 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} -- TODO: Create a 'snocket' package, in order to avoid having to have -- ouroboros-network-testing as a dependency for this cabal library. @@ -39,6 +40,7 @@ import Data.ByteString.Lazy (ByteString) import Data.Foldable (traverse_) import Data.Functor (void) import qualified Data.Map as Map +import Data.Monoid.Synchronisation import Data.Set (Set) import qualified Data.Set as Set import Text.Printf @@ -174,6 +176,8 @@ clientServerSimulation , MonadThrow (STM m) , MonadTime m , MonadTimer m + , forall a stm. stm ~ STM m => Semigroup (FirstToFinish stm a) + , forall a stm. stm ~ STM m => Monoid (FirstToFinish stm a) , Serialise payload , Eq payload @@ -666,5 +670,6 @@ assertNetworkState localAddress remoteAddress getState res = do remoteAddress)) Left _ -> return res -traceTime :: MonadMonotonicTime m => Tracer m (Time, a) -> Tracer m a +traceTime :: MonadMonotonicTime m + => Tracer m (Time, a) -> Tracer m a traceTime = contramapM (\a -> (,a) <$> getMonotonicTime)