From dc892987fae95599d5eaa7c90f0fb40fe9e01427 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 7 Dec 2022 14:57:13 +0100 Subject: [PATCH] Use io-sim-1.0.0.1 --- cabal.project | 4 +- cardano-client/cardano-client.cabal | 2 +- cardano-ping/cardano-ping.cabal | 7 +++- cardano-ping/src/Cardano/Network/Ping.hs | 2 +- .../test/Test/Data/Monoid/Synchronisation.hs | 3 ++ network-mux/network-mux.cabal | 8 ++-- network-mux/src/Network/Mux.hs | 9 +++-- network-mux/src/Network/Mux/Bearer.hs | 4 +- .../Network/Mux/Bearer/AttenuatedChannel.hs | 10 ++--- .../src/Network/Mux/Bearer/NamedPipe.hs | 4 +- network-mux/src/Network/Mux/Bearer/Pipe.hs | 2 +- network-mux/src/Network/Mux/Bearer/Queues.hs | 4 +- network-mux/src/Network/Mux/Bearer/Socket.hs | 4 +- network-mux/src/Network/Mux/Channel.hs | 5 +-- network-mux/src/Network/Mux/Compat.hs | 8 ++-- .../src/Network/Mux/DeltaQ/TraceStats.hs | 2 +- network-mux/src/Network/Mux/Egress.hs | 5 +-- network-mux/src/Network/Mux/Ingress.hs | 6 +-- network-mux/src/Network/Mux/Time.hs | 2 +- network-mux/src/Network/Mux/Timeout.hs | 10 ++--- network-mux/src/Network/Mux/Trace.hs | 2 +- network-mux/src/Network/Mux/Types.hs | 2 +- network-mux/test/Test/Mux.hs | 40 ++++++++++--------- network-mux/test/Test/Mux/Timeout.hs | 5 ++- nix/sources.json | 12 +++--- .../ouroboros-network-api.cabal | 7 ++-- .../Network/PeerSelection/PeerMetric/Type.hs | 2 +- .../src/Ouroboros/Network/Protocol/Limits.hs | 2 +- .../demo/connection-manager.hs | 13 +++--- .../ouroboros-network-framework.cabal | 11 +++-- .../src/Ouroboros/Network/Channel.hs | 5 +-- .../Ouroboros/Network/ConnectionHandler.hs | 8 ++-- .../Network/ConnectionManager/Core.hs | 12 +++--- .../Network/ConnectionManager/Types.hs | 2 +- .../src/Ouroboros/Network/Driver/Limits.hs | 6 +-- .../src/Ouroboros/Network/ErrorPolicy.hs | 2 +- .../src/Ouroboros/Network/InboundGovernor.hs | 11 +++-- .../Network/InboundGovernor/Event.hs | 21 +++++++--- .../Ouroboros/Network/Protocol/Handshake.hs | 6 +-- .../Network/Protocol/Handshake/Codec.hs | 2 +- .../Ouroboros/Network/Server/RateLimiting.hs | 5 +-- .../src/Ouroboros/Network/Server/Socket.hs | 4 +- .../src/Ouroboros/Network/Server2.hs | 9 +++-- .../src/Ouroboros/Network/Socket.hs | 2 +- .../Ouroboros/Network/Subscription/Client.hs | 2 +- .../src/Ouroboros/Network/Subscription/Dns.hs | 4 +- .../src/Ouroboros/Network/Subscription/Ip.hs | 6 +-- .../Network/Subscription/PeerState.hs | 11 ++--- .../Ouroboros/Network/Subscription/Worker.hs | 6 +-- .../src/Simulation/Network/Snocket.hs | 17 +++++--- .../Ouroboros/Network/ConnectionManager.hs | 15 +++---- .../test/Test/Ouroboros/Network/Driver.hs | 7 ++-- .../Test/Ouroboros/Network/RateLimiting.hs | 4 +- .../test/Test/Ouroboros/Network/Server2.hs | 21 +++++++--- .../test/Test/Ouroboros/Network/Socket.hs | 2 +- .../Test/Ouroboros/Network/Subscription.hs | 9 +++-- .../test/Test/Simulation/Network/Snocket.hs | 9 +++-- .../testlib/TestLib/Utils.hs | 2 +- .../ouroboros-network-protocols.cabal | 7 +++- .../Network/Protocol/BlockFetch/Codec.hs | 2 +- .../Network/Protocol/ChainSync/Codec.hs | 2 +- .../Network/Protocol/KeepAlive/Codec.hs | 2 +- .../Network/Protocol/PeerSharing/Codec.hs | 2 +- .../Network/Protocol/TxSubmission2/Codec.hs | 2 +- .../Network/Protocol/Handshake/Test.hs | 12 ++++-- .../ouroboros-network-testing.cabal | 3 +- .../Network/Testing/Data/AbsBearerInfo.hs | 2 +- .../Ouroboros/Network/Testing/Data/Script.hs | 4 +- .../Ouroboros/Network/Testing/Data/Signal.hs | 2 +- .../src/Ouroboros/Network/Testing/Utils.hs | 2 +- ouroboros-network/ouroboros-network.cabal | 7 +++- .../src/Ouroboros/Network/BlockFetch.hs | 5 +-- .../Ouroboros/Network/BlockFetch/Client.hs | 6 +-- .../Network/BlockFetch/ClientState.hs | 2 +- .../Ouroboros/Network/BlockFetch/Decision.hs | 2 +- .../Ouroboros/Network/BlockFetch/DeltaQ.hs | 2 +- .../src/Ouroboros/Network/BlockFetch/State.hs | 5 +-- .../src/Ouroboros/Network/DeltaQ.hs | 3 +- .../src/Ouroboros/Network/Diffusion/P2P.hs | 9 +++-- .../Ouroboros/Network/Diffusion/Policies.hs | 2 +- .../src/Ouroboros/Network/ExitPolicy.hs | 2 +- .../src/Ouroboros/Network/KeepAlive.hs | 7 ++-- .../src/Ouroboros/Network/NodeToClient.hs | 12 +++--- .../src/Ouroboros/Network/NodeToNode.hs | 2 +- .../Network/PeerSelection/EstablishedPeers.hs | 2 +- .../Network/PeerSelection/Governor.hs | 39 ++++++++++++------ .../PeerSelection/Governor/ActivePeers.hs | 17 ++++++-- .../Governor/EstablishedPeers.hs | 9 ++++- .../PeerSelection/Governor/KnownPeers.hs | 12 +++--- .../Network/PeerSelection/Governor/Monitor.hs | 2 +- .../PeerSelection/Governor/RootPeers.hs | 2 +- .../Network/PeerSelection/Governor/Types.hs | 2 +- .../Network/PeerSelection/KnownPeers.hs | 2 +- .../Network/PeerSelection/LedgerPeers.hs | 4 +- .../Network/PeerSelection/PeerMetric.hs | 2 +- .../Network/PeerSelection/PeerStateActions.hs | 9 +++-- .../Network/PeerSelection/RootPeersDNS.hs | 9 +++-- .../PeerSelection/RootPeersDNS/DNSActions.hs | 5 ++- .../Ouroboros/Network/PeerSelection/Simple.hs | 8 ++-- .../src/Ouroboros/Network/PeerSharing.hs | 11 +++-- .../Ouroboros/Network/BlockFetch/Examples.hs | 22 +++++----- .../test/Ouroboros/Network/MockNode.hs | 11 +++-- ouroboros-network/test/Test/LedgerPeers.hs | 4 +- ouroboros-network/test/Test/Mux.hs | 9 +++-- .../test/Test/Ouroboros/Network/BlockFetch.hs | 8 ++-- .../Test/Ouroboros/Network/Diffusion/Node.hs | 9 +++-- .../Network/Diffusion/Node/MiniProtocols.hs | 8 ++-- .../Network/Diffusion/Node/NodeKernel.hs | 9 +++-- .../Ouroboros/Network/Diffusion/Policies.hs | 6 +-- .../test/Test/Ouroboros/Network/KeepAlive.hs | 6 ++- .../test/Test/Ouroboros/Network/MockNode.hs | 18 +++++---- .../Test/Ouroboros/Network/PeerSelection.hs | 4 +- .../Network/PeerSelection/MockEnvironment.hs | 10 ++--- .../Network/PeerSelection/PeerGraph.hs | 2 +- .../Network/PeerSelection/PeerMetric.hs | 5 ++- .../Network/PeerSelection/RootPeersDNS.hs | 12 ++++-- .../test/Test/Ouroboros/Network/Testnet.hs | 16 ++++---- .../Network/Testnet/Simulation/Node.hs | 9 +++-- .../Test/Ouroboros/Network/TxSubmission.hs | 7 +++- ouroboros-network/test/Test/PeerState.hs | 2 +- ouroboros-network/test/Test/Pipe.hs | 2 +- ouroboros-network/test/Test/Socket.hs | 4 +- 122 files changed, 480 insertions(+), 353 deletions(-) diff --git a/cabal.project b/cabal.project index 9a683591f23..e7a1593aded 100644 --- a/cabal.project +++ b/cabal.project @@ -16,9 +16,9 @@ repository cardano-haskell-packages index-state: 2023-03-29T00:00:00Z index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2023-03-29T00:00:00Z + , hackage.haskell.org 2023-04-20T20:00:00Z -- Bump this if you need newer packages from CHaP - , cardano-haskell-packages 2023-04-24T15:34:01Z + , cardano-haskell-packages 2023-04-24T15:33:00Z packages: ./cardano-ping ./monoidal-synchronisation diff --git a/cardano-client/cardano-client.cabal b/cardano-client/cardano-client.cabal index b880b6b7d53..bb110e6a339 100644 --- a/cardano-client/cardano-client.cabal +++ b/cardano-client/cardano-client.cabal @@ -21,7 +21,7 @@ library build-depends: base >=4.14 && <4.17, bytestring >=0.10 && <0.12, containers, - io-classes, + io-classes ^>=1.0.0.1, ouroboros-network-api, ouroboros-network, ouroboros-network-framework, diff --git a/cardano-ping/cardano-ping.cabal b/cardano-ping/cardano-ping.cabal index 6d594df208b..b3f36893638 100644 --- a/cardano-ping/cardano-ping.cabal +++ b/cardano-ping/cardano-ping.cabal @@ -27,9 +27,12 @@ library cborg >=0.2.8 && <0.3, bytestring >=0.10 && <0.12, contra-tracer >=0.1 && <0.2, - io-classes >=0.3 && <0.4, + + io-classes ^>=1.0, + si-timers, + strict-stm, + network-mux >=0.3 && <0.4, - strict-stm >=0.2 && <0.3, tdigest >=0.2.1.1 && <0.3, text >=1.2.4 && <2.1, diff --git a/cardano-ping/src/Cardano/Network/Ping.hs b/cardano-ping/src/Cardano/Network/Ping.hs index e70970f9784..7dfebf6c7d5 100644 --- a/cardano-ping/src/Cardano/Network/Ping.hs +++ b/cardano-ping/src/Cardano/Network/Ping.hs @@ -22,7 +22,7 @@ module Cardano.Network.Ping import Control.Exception (bracket) import Control.Monad (replicateM, unless, when) import Control.Concurrent.Class.MonadSTM.Strict ( MonadSTM(atomically), takeTMVar, StrictTMVar ) -import Control.Monad.Class.MonadTime (UTCTime, diffTime, MonadMonotonicTime(getMonotonicTime), MonadTime(getCurrentTime), Time) +import Control.Monad.Class.MonadTime.SI (UTCTime, diffTime, MonadMonotonicTime(getMonotonicTime), MonadTime(getCurrentTime), Time) import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Aeson (Value, ToJSON(toJSON), object, encode, KeyValue((.=))) import Data.Bits (clearBit, setBit, testBit) diff --git a/monoidal-synchronisation/test/Test/Data/Monoid/Synchronisation.hs b/monoidal-synchronisation/test/Test/Data/Monoid/Synchronisation.hs index d1e88a43561..49ea54179e5 100644 --- a/monoidal-synchronisation/test/Test/Data/Monoid/Synchronisation.hs +++ b/monoidal-synchronisation/test/Test/Data/Monoid/Synchronisation.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE ScopedTypeVariables #-} module Test.Data.Monoid.Synchronisation where +import Control.Monad (MonadPlus) import Control.Concurrent.Class.MonadSTM import Control.Monad.Class.MonadFork @@ -23,6 +25,7 @@ tests = lastToFinishExperiment :: forall m. ( MonadFork m + , MonadPlus (STM m) , MonadSTM m ) => Bool -> m Bool diff --git a/network-mux/network-mux.cabal b/network-mux/network-mux.cabal index 5922c4601d5..9d7a06d5135 100644 --- a/network-mux/network-mux.cabal +++ b/network-mux/network-mux.cabal @@ -45,8 +45,9 @@ common demo-deps library build-depends: base >=4.14 && <4.17, - io-classes ^>=0.3, - strict-stm ^>=0.2, + io-classes ^>=1.0, + strict-stm, + si-timers, contra-tracer >=0.1 && <0.2, monoidal-synchronisation >=0.1 && <0.2, @@ -125,8 +126,9 @@ test-suite test default-language: Haskell2010 build-depends: base >=4.14 && <4.17, io-classes, + si-timers, strict-stm, - io-sim >=0.3 && < 0.4, + io-sim ^>=1.0, contra-tracer, network-mux, Win32-network, diff --git a/network-mux/src/Network/Mux.hs b/network-mux/src/Network/Mux.hs index b6df534b6ae..599ef7fad78 100644 --- a/network-mux/src/Network/Mux.hs +++ b/network-mux/src/Network/Mux.hs @@ -58,8 +58,7 @@ import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer hiding (timeout) +import Control.Monad.Class.MonadTimer.SI hiding (timeout) import Control.Tracer import Network.Mux.Bearer @@ -202,8 +201,8 @@ runMux :: forall m mode. ( MonadAsync m , MonadFork m , MonadLabelledSTM m + , Alternative (STM m) , MonadThrow (STM m) - , MonadTime m , MonadTimer m , MonadMask m ) @@ -348,6 +347,7 @@ newtype MonitorCtx m mode = MonitorCtx { monitor :: forall mode m. ( MonadAsync m , MonadMask m + , Alternative (STM m) , MonadThrow (STM m) ) => Tracer m MuxTrace @@ -624,7 +624,8 @@ traceMuxBearerState tracer state = -- irrespective of the 'StartOnDemandOrEagerly' value. -- runMiniProtocol :: forall mode m a. - ( MonadSTM m + ( Alternative (STM m) + , MonadSTM m , MonadThrow m , MonadThrow (STM m) ) diff --git a/network-mux/src/Network/Mux/Bearer.hs b/network-mux/src/Network/Mux/Bearer.hs index 2637da82410..2518d13fa02 100644 --- a/network-mux/src/Network/Mux/Bearer.hs +++ b/network-mux/src/Network/Mux/Bearer.hs @@ -20,7 +20,7 @@ module Network.Mux.Bearer import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer) import Network.Socket (Socket) @@ -66,7 +66,7 @@ makePipeChannelBearer = MakeBearer $ pureBearer (\_ -> pipeAsMuxBearer size) size = SDUSize 32_768 makeQueueChannelBearer :: ( MonadSTM m - , MonadTime m + , MonadMonotonicTime m , MonadThrow m ) => MakeBearer m (QueueChannel m) diff --git a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs index 9444e43657f..387ff0767bc 100644 --- a/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs +++ b/network-mux/src/Network/Mux/Bearer/AttenuatedChannel.hs @@ -21,8 +21,8 @@ import Prelude hiding (read) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (when) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import GHC.IO.Exception @@ -156,7 +156,7 @@ data Attenuation = Attenuation { -- | Make a 'AttenuatedChannel' from a 'QueueChannel'. -- newAttenuatedChannel :: forall m. - ( MonadTime m + ( MonadDelay m , MonadTimer m , MonadThrow m , MonadThrow (STM m) @@ -232,8 +232,8 @@ newAttenuatedChannel tr Attenuation { aReadAttenuation, -- newConnectedAttenuatedChannelPair :: forall m. - ( MonadLabelledSTM m - , MonadTime m + ( MonadDelay m + , MonadLabelledSTM m , MonadTimer m , MonadThrow m , MonadThrow (STM m) diff --git a/network-mux/src/Network/Mux/Bearer/NamedPipe.hs b/network-mux/src/Network/Mux/Bearer/NamedPipe.hs index df803068cf2..74bfcd47916 100644 --- a/network-mux/src/Network/Mux/Bearer/NamedPipe.hs +++ b/network-mux/src/Network/Mux/Bearer/NamedPipe.hs @@ -10,8 +10,8 @@ import Data.Foldable (traverse_) import Data.Int (Int64) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer import qualified Network.Mux.Codec as Mx diff --git a/network-mux/src/Network/Mux/Bearer/Pipe.hs b/network-mux/src/Network/Mux/Bearer/Pipe.hs index 8db96f5320a..1f715d6faf2 100644 --- a/network-mux/src/Network/Mux/Bearer/Pipe.hs +++ b/network-mux/src/Network/Mux/Bearer/Pipe.hs @@ -16,7 +16,7 @@ module Network.Mux.Bearer.Pipe ( ) where import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer import qualified Data.ByteString.Lazy as BL import System.IO (Handle, hFlush) diff --git a/network-mux/src/Network/Mux/Bearer/Queues.hs b/network-mux/src/Network/Mux/Bearer/Queues.hs index 50fb5b761de..8bfda2a15e0 100644 --- a/network-mux/src/Network/Mux/Bearer/Queues.hs +++ b/network-mux/src/Network/Mux/Bearer/Queues.hs @@ -12,7 +12,7 @@ import qualified Data.ByteString.Lazy as BL import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer import qualified Network.Mux.Codec as Mx @@ -31,7 +31,7 @@ data QueueChannel m = QueueChannel { queueChannelAsMuxBearer :: forall m. ( MonadSTM m - , MonadTime m + , MonadMonotonicTime m , MonadThrow m ) => Mx.SDUSize diff --git a/network-mux/src/Network/Mux/Bearer/Socket.hs b/network-mux/src/Network/Mux/Bearer/Socket.hs index 65d8b70cb67..95178ab8817 100644 --- a/network-mux/src/Network/Mux/Bearer/Socket.hs +++ b/network-mux/src/Network/Mux/Bearer/Socket.hs @@ -12,8 +12,8 @@ import qualified Data.ByteString.Lazy as BL import Data.Int import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer hiding (timeout) +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI hiding (timeout) import qualified Network.Socket as Socket #if !defined(mingw32_HOST_OS) diff --git a/network-mux/src/Network/Mux/Channel.hs b/network-mux/src/Network/Mux/Channel.hs index 25933f86148..e95b5aaec47 100644 --- a/network-mux/src/Network/Mux/Channel.hs +++ b/network-mux/src/Network/Mux/Channel.hs @@ -30,7 +30,7 @@ import qualified System.Process as IO (createPipe) import Control.Concurrent.Class.MonadSTM import Control.Monad.Class.MonadSay -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI data Channel m = Channel { @@ -209,8 +209,7 @@ channelEffect beforeSend afterRecv Channel{send, recv} = -- This is intended for testing, as a crude approximation of network delays. -- More accurate models along these lines are of course possible. -- -delayChannel :: ( MonadTimer m - ) +delayChannel :: MonadDelay m => DiffTime -> Channel m -> Channel m diff --git a/network-mux/src/Network/Mux/Compat.hs b/network-mux/src/Network/Mux/Compat.hs index ce217e4d063..172b2b4f0fc 100644 --- a/network-mux/src/Network/Mux/Compat.hs +++ b/network-mux/src/Network/Mux/Compat.hs @@ -36,14 +36,12 @@ module Network.Mux.Compat import qualified Data.ByteString.Lazy as BL import Data.Void (Void) -import Control.Applicative ((<|>)) +import Control.Applicative (Alternative (..), (<|>)) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import Control.Tracer import Network.Mux (StartOnDemandOrEagerly (..), newMux, @@ -92,8 +90,8 @@ muxStart ( MonadAsync m , MonadFork m , MonadLabelledSTM m + , Alternative (STM m) , MonadThrow (STM m) - , MonadTime m , MonadTimer m , MonadMask m ) diff --git a/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs b/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs index 54f1e2003c3..d752decdd4a 100644 --- a/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs +++ b/network-mux/src/Network/Mux/DeltaQ/TraceStats.hs @@ -11,7 +11,7 @@ import qualified Data.IntMap.Strict as IM import Data.Maybe import Data.Word (Word32) -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Network.Mux.DeltaQ.TraceStatsSupport import Network.Mux.DeltaQ.TraceTypes import Network.Mux.Types diff --git a/network-mux/src/Network/Mux/Egress.hs b/network-mux/src/Network/Mux/Egress.hs index a39272d7d20..8a8e73b4383 100644 --- a/network-mux/src/Network/Mux/Egress.hs +++ b/network-mux/src/Network/Mux/Egress.hs @@ -18,10 +18,8 @@ import qualified Data.ByteString.Lazy as BL import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer hiding (timeout) +import Control.Monad.Class.MonadTimer.SI hiding (timeout) import Network.Mux.Timeout import Network.Mux.Types @@ -138,7 +136,6 @@ muxer , MonadMask m , MonadThrow (STM m) , MonadTimer m - , MonadTime m ) => EgressQueue m -> MuxBearer m diff --git a/network-mux/src/Network/Mux/Ingress.hs b/network-mux/src/Network/Mux/Ingress.hs index ca54f264bc6..aa305900f4e 100644 --- a/network-mux/src/Network/Mux/Ingress.hs +++ b/network-mux/src/Network/Mux/Ingress.hs @@ -19,10 +19,8 @@ import Text.Printf import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer hiding (timeout) +import Control.Monad.Class.MonadTimer.SI hiding (timeout) import Network.Mux.Timeout import Network.Mux.Trace @@ -98,7 +96,7 @@ data MiniProtocolDispatchInfo m = -- | demux runs as a single separate thread and reads complete 'MuxSDU's from -- the underlying Mux Bearer and forwards it to the matching ingress queue. demuxer :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m), - MonadTimer m, MonadTime m) + MonadTimer m) => [MiniProtocolState mode m] -> MuxBearer m -> m void diff --git a/network-mux/src/Network/Mux/Time.hs b/network-mux/src/Network/Mux/Time.hs index 50fd3f1a0d4..66aec7d3f7f 100644 --- a/network-mux/src/Network/Mux/Time.hs +++ b/network-mux/src/Network/Mux/Time.hs @@ -8,7 +8,7 @@ module Network.Mux.Time , timestampMicrosecondsLow32Bits ) where -import Control.Monad.Class.MonadTime (Time (..)) +import Control.Monad.Class.MonadTime.SI (Time (..)) import Data.Time.Clock (DiffTime, diffTimeToPicoseconds, picosecondsToDiffTime) import Data.Word (Word32) diff --git a/network-mux/src/Network/Mux/Timeout.hs b/network-mux/src/Network/Mux/Timeout.hs index 9fd8e5b9a8c..f194579af42 100644 --- a/network-mux/src/Network/Mux/Timeout.hs +++ b/network-mux/src/Network/Mux/Timeout.hs @@ -29,9 +29,9 @@ import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer (MonadTimer, registerDelay) -import qualified Control.Monad.Class.MonadTimer as MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI (MonadTimer, registerDelay) +import qualified Control.Monad.Class.MonadTimer.SI as MonadTimer -- | The type of the 'System.Timeout.timeout' function. @@ -305,8 +305,8 @@ timeout monitorState delay action = monitoringThread :: (MonadFork m, MonadSTM m, - MonadMonotonicTime m, MonadTimer m, - MonadThrow (STM m)) + MonadMonotonicTime m, + MonadTimer m, MonadThrow (STM m)) => MonitorState m -> m () monitoringThread monitorState@MonitorState{deadlineResetVar} = do threadId <- myThreadId diff --git a/network-mux/src/Network/Mux/Trace.hs b/network-mux/src/Network/Mux/Trace.hs index 119c90e54a8..7d4d2488732 100644 --- a/network-mux/src/Network/Mux/Trace.hs +++ b/network-mux/src/Network/Mux/Trace.hs @@ -23,7 +23,7 @@ import Text.Printf import Control.Exception hiding (throwIO) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Data.Bifunctor (Bifunctor (..)) import Data.Word import GHC.Generics (Generic (..)) diff --git a/network-mux/src/Network/Mux/Types.hs b/network-mux/src/Network/Mux/Types.hs index 4fa65197c57..273728758ca 100644 --- a/network-mux/src/Network/Mux/Types.hs +++ b/network-mux/src/Network/Mux/Types.hs @@ -52,7 +52,7 @@ import Quiet import GHC.Generics (Generic) import Control.Concurrent.Class.MonadSTM.Strict (StrictTVar) -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Network.Mux.Channel (Channel (..)) import Network.Mux.Timeout (TimeoutFn) diff --git a/network-mux/test/Test/Mux.hs b/network-mux/test/Test/Mux.hs index 8d883d4454f..f292d0f4fcc 100644 --- a/network-mux/test/Test/Mux.hs +++ b/network-mux/test/Test/Mux.hs @@ -41,8 +41,8 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Control.Tracer @@ -1007,13 +1007,13 @@ encodeInvalidMuxSDU sdu = -- | Verify ingress processing of valid and invalid SDUs. -- prop_demux_sdu :: forall m. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadFork m , MonadLabelledSTM m , MonadMask m , MonadSay m , MonadThrow (STM m) - , MonadTime m , MonadTimer m ) => ArbitrarySDU @@ -1254,8 +1254,8 @@ instance Arbitrary DummyApps where dummyAppToChannel :: forall m. ( MonadAsync m + , MonadDelay m , MonadCatch m - , MonadTimer m ) => DummyApp -> (Channel m -> m ((), Maybe BL.ByteString)) @@ -1290,7 +1290,7 @@ instance Arbitrary DummyRestartingApps where dummyRestartingAppToChannel :: forall a m. ( MonadAsync m , MonadCatch m - , MonadTimer m + , MonadDelay m ) => (DummyApp, a) -> (Channel m -> m ((DummyApp, a), Maybe BL.ByteString)) @@ -1306,9 +1306,8 @@ appToInfo d da = MiniProtocolInfo (daNum da) d defaultMiniProtocolLimits triggerApp :: forall m. ( MonadAsync m + , MonadDelay m , MonadSay m - , MonadTime m - , MonadTimer m ) => MuxBearer m -> DummyApp @@ -1322,13 +1321,14 @@ triggerApp bearer app = do return () prop_mux_start_mX :: forall m. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadFork m , MonadLabelledSTM m , MonadMask m , MonadSay m , MonadThrow (STM m) - , MonadTime m , MonadTimer m ) => DummyApps @@ -1376,13 +1376,14 @@ prop_mux_start_mX apps runTime = do Right _ -> return (counterexample "not-failed" False, r) prop_mux_restart_m :: forall m. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadFork m , MonadLabelledSTM m , MonadMask m , MonadSay m , MonadThrow (STM m) - , MonadTime m , MonadTimer m ) => DummyRestartingApps @@ -1543,13 +1544,14 @@ prop_mux_restart_m (DummyRestartingInitiatorResponderApps rapps) = do prop_mux_start_m :: forall m. - ( MonadAsync m - , MonadFork m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m + , MonadFork m , MonadLabelledSTM m , MonadMask m , MonadSay m , MonadThrow (STM m) - , MonadTime m , MonadTimer m ) => MuxBearer m @@ -1702,8 +1704,8 @@ instance (Show a) => Show (WithThreadAndTime a) where verboseTracer :: forall a m. ( MonadAsync m + , MonadMonotonicTime m , MonadSay m - , MonadTime m , Show a ) => Tracer m a @@ -1711,7 +1713,7 @@ verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say threadAndTimeTracer :: forall a m. ( MonadAsync m - , MonadTime m + , MonadMonotonicTime m ) => Tracer m (WithThreadAndTime a) -> Tracer m a threadAndTimeTracer tr = Tracer $ \s -> do @@ -1758,11 +1760,11 @@ withNetworkCtx NetworkCtx { ncSocket, ncClose, ncMuxBearer } k = close_experiment :: forall sock acc req resp m. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadFork m , MonadLabelledSTM m , MonadMask m - , MonadTime m , MonadTimer m , MonadThrow (STM m) , MonadST m diff --git a/network-mux/test/Test/Mux/Timeout.hs b/network-mux/test/Test/Mux/Timeout.hs index e6ed3a2f2bb..70faf5d00e8 100644 --- a/network-mux/test/Test/Mux/Timeout.hs +++ b/network-mux/test/Test/Mux/Timeout.hs @@ -15,8 +15,8 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer hiding (timeout) +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI hiding (timeout) import Control.Monad.IOSim import Network.Mux.Time (microsecondsToDiffTime) @@ -73,6 +73,7 @@ tests = type TimeoutConstraints m = ( MonadAsync m + , MonadDelay m , MonadFork m , MonadTime m , MonadTimer m diff --git a/nix/sources.json b/nix/sources.json index 11af3907aed..f9d40f12be9 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -17,10 +17,10 @@ "homepage": "", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "201bf9c5f90d5c408a931d33486aabf0906b71c9", - "sha256": "03msf6hbzdp9n6qv0fadfqs0azgwp5vh66aj3wd1vdf7b32068ns", + "rev": "1e52cafabbbe68ce59eabdc4103a2cd37da1b118", + "sha256": "0qfkmfm7xvkvqn6213mz2whmbkrqwnypyzyks6prmwnh8ysxx5r7", "type": "tarball", - "url": "https://github.com/input-output-hk/hackage.nix/archive/201bf9c5f90d5c408a931d33486aabf0906b71c9.tar.gz", + "url": "https://github.com/input-output-hk/hackage.nix/archive/1e52cafabbbe68ce59eabdc4103a2cd37da1b118.tar.gz", "url_template": "https://github.com///archive/.tar.gz", "version": "b3c99d7f13df89a9a918c835ecb7114098912962" }, @@ -30,10 +30,10 @@ "homepage": "https://input-output-hk.github.io/haskell.nix", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "9bc8625f18ed1aa633f5f3a52ee03d1718eaeebe", - "sha256": "0mm4z0wc7vic1185id912lfmrm2vy8ky25qa2ivf8fphi4ls5qb8", + "rev": "5f30c1ccf8eccc99660b745621df52c5923c231b", + "sha256": "1b3jli7jp1y87y3pb712krb678ncplp9jiz3b4nwv1xkcnw974hh", "type": "tarball", - "url": "https://github.com/input-output-hk/haskell.nix/archive/9bc8625f18ed1aa633f5f3a52ee03d1718eaeebe.tar.gz", + "url": "https://github.com/input-output-hk/haskell.nix/archive/5f30c1ccf8eccc99660b745621df52c5923c231b.tar.gz", "url_template": "https://github.com///archive/.tar.gz", "version": "962ecfed3a4fb656b5a91d89159291e00ed766bc" }, diff --git a/ouroboros-network-api/ouroboros-network-api.cabal b/ouroboros-network-api/ouroboros-network-api.cabal index a74c337fd85..31f50a82849 100644 --- a/ouroboros-network-api/ouroboros-network-api.cabal +++ b/ouroboros-network-api/ouroboros-network-api.cabal @@ -65,10 +65,11 @@ library cardano-strict-containers, contra-tracer, - io-classes ^>=0.3, + io-classes ^>=1.0, network-mux ^>=0.3, - strict-stm ^>=0.2, - typed-protocols ^>=0.1, + strict-stm, + si-timers, + typed-protocols ^>=0.1.0.4, ghc-options: -Wall -Wno-unticked-promoted-constructors diff --git a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerMetric/Type.hs b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerMetric/Type.hs index 1634ef8bd7f..66bbb66b3de 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerMetric/Type.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/PeerSelection/PeerMetric/Type.hs @@ -8,7 +8,7 @@ module Ouroboros.Network.PeerSelection.PeerMetric.Type ) where import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer) import Cardano.Slotting.Slot (SlotNo (..)) diff --git a/ouroboros-network-api/src/Ouroboros/Network/Protocol/Limits.hs b/ouroboros-network-api/src/Ouroboros/Network/Protocol/Limits.hs index c56eee5405b..0a948cc6d0e 100644 --- a/ouroboros-network-api/src/Ouroboros/Network/Protocol/Limits.hs +++ b/ouroboros-network-api/src/Ouroboros/Network/Protocol/Limits.hs @@ -9,7 +9,7 @@ module Ouroboros.Network.Protocol.Limits where import Control.Exception -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Network.TypedProtocol.Core diff --git a/ouroboros-network-framework/demo/connection-manager.hs b/ouroboros-network-framework/demo/connection-manager.hs index 949c1e3c9a4..cd56c4c4fbc 100644 --- a/ouroboros-network-framework/demo/connection-manager.hs +++ b/ouroboros-network-framework/demo/connection-manager.hs @@ -27,8 +27,8 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime (MonadTime (..)) -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI (MonadTime (..)) +import Control.Monad.Class.MonadTimer.SI import Control.Monad.Fix (MonadFix) import Control.Tracer (Tracer (..), contramap, nullTracer, traceWith) @@ -137,8 +137,9 @@ genClientAndServerData g0 len = ClientAndServerData { -- type ConnectionManagerMonad m = - ( MonadAsync m, MonadCatch m, MonadEvaluate m, MonadFork m, MonadMask m - , MonadST m, MonadTime m, MonadTimer m, MonadThrow m, MonadThrow (STM m) + ( Alternative (STM m), MonadAsync m, MonadCatch m, MonadEvaluate m, + MonadFork m, MonadMask m, MonadST m, MonadTime m, MonadTimer m, + MonadThrow m, MonadThrow (STM m) ) @@ -177,6 +178,7 @@ withBidirectionalConnectionManager -- debugging , MonadFix m , MonadAsync m + , MonadDelay m , MonadLabelledSTM m , MonadTraceSTM m , MonadSay m @@ -366,7 +368,8 @@ withBidirectionalConnectionManager snocket makeBearer socket -- runInitiatorProtocols :: forall muxMode m a b. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadCatch m , MonadSTM m , MonadThrow (STM m) diff --git a/ouroboros-network-framework/ouroboros-network-framework.cabal b/ouroboros-network-framework/ouroboros-network-framework.cabal index 844335cce92..66f5e1ec2c1 100644 --- a/ouroboros-network-framework/ouroboros-network-framework.cabal +++ b/ouroboros-network-framework/ouroboros-network-framework.cabal @@ -85,7 +85,7 @@ library , cardano-prelude , contra-tracer - , io-classes + , io-classes ^>=1.0 , monoidal-synchronisation >=0.1 && < 0.2 , network >=3.1.2.2 && < 3.2 @@ -93,8 +93,9 @@ library , ouroboros-network-api ^>=0.2 , ouroboros-network-testing - , strict-stm ^>=0.2 - , typed-protocols + , si-timers + , strict-stm + , typed-protocols >=0.1 && < 0.2 , typed-protocols-cborg ^>=0.1 , Win32-network ^>=0.1 @@ -130,7 +131,7 @@ library testlib , QuickCheck , io-sim - , io-classes + , si-timers , typed-protocols , ouroboros-network-framework @@ -179,6 +180,7 @@ test-suite test , io-sim , io-classes + , si-timers , strict-stm , network-mux , monoidal-synchronisation @@ -251,6 +253,7 @@ executable demo-connection-manager io-classes, network-mux, + si-timers, ouroboros-network-api, ouroboros-network-framework, strict-stm, diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Channel.hs b/ouroboros-network-framework/src/Ouroboros/Network/Channel.hs index 868cdb53752..166c9f212a7 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Channel.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Channel.hs @@ -23,7 +23,7 @@ module Ouroboros.Network.Channel import Control.Monad ((>=>)) import Control.Monad.Class.MonadSay -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.ByteString.Lazy.Internal (smallChunkSize) @@ -290,8 +290,7 @@ channelEffect beforeSend afterRecv Channel{send, recv} = -- This is intended for testing, as a crude approximation of network delays. -- More accurate models along these lines are of course possible. -- -delayChannel :: ( MonadTimer m - ) +delayChannel :: MonadDelay m => DiffTime -> Channel m a -> Channel m a diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs index dd75e700414..ae248e01082 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionHandler.hs @@ -35,13 +35,14 @@ module Ouroboros.Network.ConnectionHandler , ConnectionHandlerTrace (..) ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (SomeAsyncException) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow hiding (handle) -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) @@ -172,7 +173,8 @@ type MuxConnectionManager muxMode socket peerAddr versionData versionNumber byte -- makeConnectionHandler :: forall peerAddr muxMode socket versionNumber versionData m a b. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadFork m , MonadLabelledSTM m , MonadThrow (STM m) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs index c6a260405e1..77dee1e0707 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Core.hs @@ -23,15 +23,16 @@ module Ouroboros.Network.ConnectionManager.Core , abstractState ) where +import Control.Applicative (Alternative) import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad (forM_, guard, when, (>=>)) import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork (MonadFork, throwTo) +import Control.Monad.Class.MonadFork (throwTo) import Control.Monad.Class.MonadThrow hiding (handle) -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.Fix import Control.Tracer (Tracer, contramap, traceWith) import Data.Foldable (foldMap', traverse_) @@ -528,15 +529,16 @@ data DemoteToColdLocal peerAddr handlerTrace handle handleError version m -- withConnectionManager :: forall (muxMode :: MuxMode) peerAddr socket handlerTrace handle handleError version versionData m a. - ( MonadLabelledSTM m + ( Alternative (STM m) + , MonadLabelledSTM m , MonadTraceSTM m -- 'MonadFork' is only to get access to 'throwTo' , MonadFork m , MonadAsync m + , MonadDelay m , MonadEvaluate m , MonadFix m , MonadMask m - , MonadMonotonicTime m , MonadThrow (STM m) , MonadTimer m diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs index 5bb24271d1d..46a3649a4d9 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ConnectionManager/Types.hs @@ -158,7 +158,7 @@ module Ouroboros.Network.ConnectionManager.Types import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (unless) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime (DiffTime) +import Control.Monad.Class.MonadTime.SI (DiffTime) import Control.Tracer (Tracer) import Data.Functor (void) import Data.List (sortOn) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Driver/Limits.hs b/ouroboros-network-framework/src/Ouroboros/Network/Driver/Limits.hs index 8ccfb526183..a6e81df00e3 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Driver/Limits.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Driver/Limits.hs @@ -30,11 +30,9 @@ module Ouroboros.Network.Driver.Limits import Data.Maybe (fromMaybe) import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer (..), traceWith) import Network.Mux.Timeout @@ -152,7 +150,6 @@ runPeerWithLimits , MonadFork m , MonadMask m , MonadThrow (STM m) - , MonadMonotonicTime m , MonadTimer m , forall (st' :: ps). Show (ClientHasAgency st') , forall (st' :: ps). Show (ServerHasAgency st') @@ -185,7 +182,6 @@ runPipelinedPeerWithLimits , MonadFork m , MonadMask m , MonadThrow (STM m) - , MonadMonotonicTime m , MonadTimer m , forall (st' :: ps). Show (ClientHasAgency st') , forall (st' :: ps). Show (ServerHasAgency st') diff --git a/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs b/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs index d722eb2012b..5bcd092bbac 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/ErrorPolicy.hs @@ -40,7 +40,7 @@ import Text.Printf import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Ouroboros.Network.Subscription.PeerState diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs index 9fc4e70f972..54914205f70 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor.hs @@ -35,14 +35,15 @@ module Ouroboros.Network.InboundGovernor , TransitionTrace' (..) ) where +import Control.Applicative (Alternative) import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (SomeAsyncException (..), assert) import Control.Monad (foldM, when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import Data.ByteString.Lazy (ByteString) @@ -85,7 +86,8 @@ import Ouroboros.Network.Server.RateLimiting -- other is useful for running a server for the /Node-To-Client protocol/. -- inboundGovernor :: forall (muxMode :: MuxMode) socket peerAddr versionData versionNumber m a b. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadCatch m , MonadEvaluate m , MonadThrow m @@ -469,7 +471,8 @@ inboundGovernor trTracer tracer serverControlChannel inboundIdleTimeout -- 'InitiatorProtocolOnly' case. -- runResponder :: forall (mode :: MuxMode) m a b. - ( HasResponder mode ~ True + ( Alternative (STM m) + , HasResponder mode ~ True , MonadAsync m , MonadCatch m , MonadThrow (STM m) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs index 77e12b6963b..39bf09853a7 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/InboundGovernor/Event.hs @@ -23,6 +23,7 @@ module Ouroboros.Network.InboundGovernor.Event , firstPeerCommitRemote ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow hiding (handle) @@ -123,7 +124,7 @@ data Terminated muxMode peerAddr m a b = Terminated { -- -- /triggers:/ 'MiniProtocolTerminated'. -- -firstMiniProtocolToFinish :: MonadSTM m +firstMiniProtocolToFinish :: Alternative (STM m) => EventSignal muxMode peerAddr versionData m a b firstMiniProtocolToFinish connId @@ -158,7 +159,9 @@ firstMiniProtocolToFinish -- @Unidirectional@ connections. -- firstPeerPromotedToWarm :: forall muxMode peerAddr versionData m a b. - MonadSTM m + ( Alternative (STM m) + , MonadSTM m + ) => EventSignal muxMode peerAddr versionData m a b firstPeerPromotedToWarm connId @@ -209,7 +212,9 @@ firstPeerPromotedToWarm -- run running). -- firstPeerPromotedToHot :: forall muxMode peerAddr versionData m a b. - MonadSTM m + ( Alternative (STM m) + , MonadSTM m + ) => EventSignal muxMode peerAddr versionData m a b firstPeerPromotedToHot connId connState@ConnectionState { csRemoteState } @@ -259,7 +264,9 @@ firstPeerPromotedToHot -- `RemoteHot → RemoteWarm` transition. -- firstPeerDemotedToWarm :: forall muxMode peerAddr versionData m a b. - MonadSTM m + ( Alternative (STM m) + , MonadSTM m + ) => EventSignal muxMode peerAddr versionData m a b firstPeerDemotedToWarm connId connState@ConnectionState { csRemoteState } @@ -302,7 +309,9 @@ firstPeerDemotedToWarm -- -- /triggers:/ 'DemotedToColdRemote' -- -firstPeerDemotedToCold :: MonadSTM m +firstPeerDemotedToCold :: ( Alternative (STM m) + , MonadSTM m + ) => EventSignal muxMode peerAddr versionData m a b firstPeerDemotedToCold connId @@ -343,7 +352,7 @@ firstPeerDemotedToCold -- | First peer for which the 'RemoteIdle' timeout expires. -- -firstPeerCommitRemote :: MonadSTM m +firstPeerCommitRemote :: Alternative (STM m) => EventSignal muxMode peerAddr versionData m a b firstPeerCommitRemote connId ConnectionState { csRemoteState } diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs index 142af204251..6ac8f87a280 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake.hs @@ -17,11 +17,9 @@ module Ouroboros.Network.Protocol.Handshake ) where import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Term as CBOR @@ -111,7 +109,6 @@ data HandshakeArguments connectionId vNumber vData m = HandshakeArguments { runHandshakeClient :: ( MonadAsync m , MonadFork m - , MonadMonotonicTime m , MonadTimer m , MonadMask m , MonadThrow (STM m) @@ -149,7 +146,6 @@ runHandshakeClient bearer runHandshakeServer :: ( MonadAsync m , MonadFork m - , MonadMonotonicTime m , MonadTimer m , MonadMask m , MonadThrow (STM m) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Codec.hs b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Codec.hs index 8f5c9638495..03da1bb9f23 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Codec.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Protocol/Handshake/Codec.hs @@ -24,7 +24,7 @@ module Ouroboros.Network.Protocol.Handshake.Codec import Control.Monad (replicateM, unless) import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BL import Data.Either (partitionEithers) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server/RateLimiting.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/RateLimiting.hs index 163271d48d8..ec6c6e81260 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server/RateLimiting.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server/RateLimiting.hs @@ -11,8 +11,8 @@ module Ouroboros.Network.Server.RateLimiting import Control.Monad (when) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import Data.Typeable (Typeable) @@ -98,7 +98,6 @@ getRateLimitDecision numberOfConnections runConnectionRateLimits :: ( MonadSTM m , MonadDelay m - , MonadTime m ) => Tracer m AcceptConnectionsPolicyTrace -> STM m Int diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs index a3c1a52fe85..5f56fce1103 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server/Socket.hs @@ -31,8 +31,8 @@ import qualified Control.Concurrent.STM as STM import Control.Exception (IOException, SomeException (..), finally, mask, mask_, onException, try) import Control.Monad (forM_, join) -import Control.Monad.Class.MonadTime (Time, getMonotonicTime) -import Control.Monad.Class.MonadTimer (threadDelay) +import Control.Monad.Class.MonadTime.SI (Time, getMonotonicTime) +import Control.Monad.Class.MonadTimer.SI (threadDelay) import Control.Tracer (Tracer, traceWith) import Data.Foldable (traverse_) import Data.Set (Set) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs index 5d1bd58d190..abed17e188d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Server2.hs @@ -31,12 +31,13 @@ module Ouroboros.Network.Server2 , module ControlChannel ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow hiding (handle) -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) @@ -116,7 +117,9 @@ server_CONNABORTED_DELAY = 0.5 -- other is useful for running a server for the /Node-To-Client protocol/. -- run :: forall muxMode socket peerAddr versionData versionNumber m a b. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadCatch m , MonadEvaluate m , MonadLabelledSTM m diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs index 14b555bab8a..8f87cbd031d 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Socket.hs @@ -76,7 +76,7 @@ import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Term as CBOR import Control.Monad (unless, when) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import qualified Control.Monad.STM as STM import qualified Data.ByteString.Lazy as BL import Data.Hashable diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs index ebb3ca116f7..e89f2338806 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Client.hs @@ -8,7 +8,7 @@ module Ouroboros.Network.Subscription.Client , clientSubscriptionWorker ) where -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer import Data.Functor.Identity (Identity (..)) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs index 79a9f1d5ce1..37e2bfc0908 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Dns.hs @@ -30,8 +30,8 @@ import qualified Control.Concurrent.Class.MonadSTM as Lazy import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer import qualified Data.IP as IP import Data.Maybe (isJust) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs index 24b6c5142b7..45162bd6800 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Ip.hs @@ -35,7 +35,7 @@ module Ouroboros.Network.Subscription.Ip import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer import Data.Void (Void) import qualified Network.Socket as Socket @@ -122,8 +122,8 @@ selectSockAddr _ _ = Nothing ipSubscriptionTarget :: forall m addr. - ( MonadSTM m - , MonadTime m + ( MonadMonotonicTime m + , MonadSTM m , Ord addr ) => Tracer m (SubscriptionTrace addr) diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs index 8ee792638d8..44784196423 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/PeerState.hs @@ -46,8 +46,8 @@ import Data.Typeable (eqT, (:~:) (..)) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Data.Semigroup.Action @@ -253,7 +253,8 @@ newPeerStatesVar = atomically newPeerStatesVarSTM -- | Periodically clean 'PeerState'. It will stop when 'PeerState' becomes -- 'ThrowException'. -- -cleanPeerStates :: ( MonadTime m +cleanPeerStates :: ( MonadDelay m + , MonadTime m , MonadTimer m ) => DiffTime @@ -505,8 +506,8 @@ type BeforeConnect m s addr = Time -> addr -> s -> STM m (ConnectDecision s) -- | Run 'BeforeConnect' callback in a 'MonadTime' monad. -- -runBeforeConnect :: ( MonadSTM m - , MonadTime m +runBeforeConnect :: ( MonadMonotonicTime m + , MonadSTM m ) => StrictTVar m s -> BeforeConnect m s addr diff --git a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs index 6fd64dcca45..e65a3fae4e7 100644 --- a/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs +++ b/ouroboros-network-framework/src/Ouroboros/Network/Subscription/Worker.hs @@ -50,8 +50,8 @@ import Text.Printf import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer import Ouroboros.Network.ErrorPolicy (CompleteApplication, @@ -209,9 +209,9 @@ data ConnectResult = subscriptionLoop :: forall m s sock localAddrs addr a x. ( MonadAsync m + , MonadDelay m , MonadMask m , MonadTime m - , MonadTimer m , MonadFix m , Ord (Async m ()) , Ord addr diff --git a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs index 03db9005a02..c7cd27e525c 100644 --- a/ouroboros-network-framework/src/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/src/Simulation/Network/Snocket.hs @@ -45,12 +45,13 @@ module Simulation.Network.Snocket import Prelude hiding (read) +import Control.Applicative (Alternative) import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (when) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, contramap, contramapM, traceWith) import GHC.IO.Exception @@ -126,8 +127,8 @@ dualConnection conn@Connection { connChannelLocal, connChannelRemote } = } -mkConnection :: ( MonadLabelledSTM m - , MonadTime m +mkConnection :: ( MonadDelay m + , MonadLabelledSTM m , MonadTimer m , MonadThrow m , MonadThrow (STM m) @@ -381,7 +382,9 @@ instance GlobalAddressScheme Int where -- withSnocket :: forall m peerAddr a. - ( MonadLabelledSTM m + ( Alternative (STM m) + , MonadDelay m + , MonadLabelledSTM m , MonadMask m , MonadTime m , MonadTimer m @@ -630,7 +633,9 @@ connectTimeout = 120 -- should be shared with all nodes in the same network. -- mkSnocket :: forall m addr. - ( MonadLabelledSTM m + ( Alternative (STM m) + , MonadDelay m + , MonadLabelledSTM m , MonadThrow (STM m) , MonadMask m , MonadTime m diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/ConnectionManager.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/ConnectionManager.hs index d6f8ab25f39..275993f5511 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/ConnectionManager.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/ConnectionManager.hs @@ -29,8 +29,8 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Control.Tracer (Tracer (..), contramap, nullTracer) @@ -336,9 +336,7 @@ data FDState = FDState { newtype FD m = FD { fdState :: StrictTVar m FDState } -makeFDBearer :: ( MonadDelay m - , MonadMonotonicTime m - ) +makeFDBearer :: MonadDelay m => MakeBearer m (FD m) makeFDBearer = MakeBearer $ \_ _ _ -> return MuxBearer { @@ -402,7 +400,6 @@ instance Exception TestError mkSnocket :: forall m. ( MonadDelay m , MonadMask m - , MonadMonotonicTime m , MonadSTM m , MonadThrow (STM m) ) @@ -587,10 +584,10 @@ data Version = Version DataFlow -- a connection and connection manager thrown 'ConnectionManagerError'. -- mkConnectionHandler :: forall m handlerTrace. - ( MonadLabelledSTM m + ( MonadDelay m + , MonadLabelledSTM m , MonadCatch m - , MonadFork m - , MonadTimer m + , MonadThread m , MonadFail m ) => Snocket m (FD m) Addr diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Driver.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Driver.hs index f46c439e1cc..7633e5fe9a6 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Driver.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Driver.hs @@ -27,11 +27,10 @@ import Network.TypedProtocol.ReqResp.Type import Control.Monad (replicateM, void) import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSTM import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim (runSimOrThrow) import Control.Tracer @@ -107,7 +106,7 @@ data ShouldFail -- with the given payloads. -- prop_runPeerWithLimits - :: forall m. ( MonadAsync m, MonadFork m, MonadMask m, + :: forall m. ( MonadAsync m, MonadDelay m, MonadFork m, MonadMask m, MonadThrow (STM m), MonadTime m, MonadTimer m) => Tracer m (TraceSendRecv (ReqResp String ())) -> Word diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/RateLimiting.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/RateLimiting.hs index 98088a21a07..a9fc8cb5458 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/RateLimiting.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/RateLimiting.hs @@ -9,8 +9,8 @@ module Test.Ouroboros.Network.RateLimiting where import Control.Concurrent.Class.MonadSTM import Control.Monad (when) import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Control.Tracer (Tracer (..), contramapM) import Data.List (scanl') diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs index bc8ae06bacb..b37a15100d3 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Server2.hs @@ -19,6 +19,7 @@ module Test.Ouroboros.Network.Server2 (tests) where +import Control.Applicative (Alternative) import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (AssertionFailed, SomeAsyncException (..)) @@ -29,8 +30,8 @@ import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadTest import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.Fix (MonadFix) import Control.Monad.IOSim import Control.Tracer (Tracer (..), contramap, nullTracer) @@ -299,8 +300,9 @@ oneshotNextRequests ClientAndServerData { -- type ConnectionManagerMonad m = - ( MonadAsync m, MonadCatch m, MonadEvaluate m, MonadFork m, MonadMask m - , MonadST m, MonadTime m, MonadTimer m, MonadThrow m, MonadThrow (STM m) + ( Alternative (STM m), MonadAsync m, MonadCatch m, MonadEvaluate m, + MonadFork m, MonadMask m, MonadST m, MonadTime m, MonadTimer m, + MonadThrow m, MonadThrow (STM m) ) @@ -312,6 +314,7 @@ withInitiatorOnlyConnectionManager , Ord peerAddr, Show peerAddr, Typeable peerAddr , Serialise req, Typeable req , MonadAsync m + , MonadDelay m , MonadFix m , MonadLabelledSTM m , MonadTraceSTM m @@ -471,6 +474,7 @@ withBidirectionalConnectionManager -- debugging , MonadAsync m + , MonadDelay m , MonadFix m , MonadLabelledSTM m , MonadTraceSTM m @@ -677,7 +681,8 @@ reqRespTimeLimits = ProtocolTimeLimits { timeLimitForState } -- runInitiatorProtocols :: forall muxMode m a b. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadCatch m , MonadSTM m , MonadThrow (STM m) @@ -730,6 +735,7 @@ unidirectionalExperiment :: forall peerAddr socket acc req resp m. ( ConnectionManagerMonad m , MonadAsync m + , MonadDelay m , MonadFix m , MonadLabelledSTM m , MonadTraceSTM m @@ -837,6 +843,7 @@ bidirectionalExperiment :: forall peerAddr socket acc req resp m. ( ConnectionManagerMonad m , MonadAsync m + , MonadDelay m , MonadFix m , MonadLabelledSTM m , MonadTraceSTM m @@ -1439,6 +1446,7 @@ multinodeExperiment :: forall peerAddr socket acc req resp m. ( ConnectionManagerMonad m , MonadAsync m + , MonadDelay m , MonadFix m , MonadLabelledSTM m , MonadTraceSTM m @@ -2921,7 +2929,8 @@ unit_server_accept_error ioErrType = -multiNodeSimTracer :: ( Monad m, MonadFix m, MonadTimer m, MonadLabelledSTM m +multiNodeSimTracer :: ( Alternative (STM m), Monad m, MonadFix m + , MonadDelay m, MonadTimer m, MonadLabelledSTM m , MonadTraceSTM m, MonadMask m, MonadTime m , MonadThrow (STM m), MonadSay m, MonadAsync m , MonadEvaluate m, MonadFork m, MonadST m diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Socket.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Socket.hs index 5dd3cbbcab0..d616d8bc193 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Socket.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Socket.hs @@ -36,7 +36,7 @@ import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork hiding (ThreadId) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTimer (threadDelay) +import Control.Monad.Class.MonadTimer.SI (threadDelay) import Control.Tracer import Network.TypedProtocol.Core diff --git a/ouroboros-network-framework/test/Test/Ouroboros/Network/Subscription.hs b/ouroboros-network-framework/test/Test/Ouroboros/Network/Subscription.hs index 5ef8cccffeb..289652f6177 100644 --- a/ouroboros-network-framework/test/Test/Ouroboros/Network/Subscription.hs +++ b/ouroboros-network-framework/test/Test/Ouroboros/Network/Subscription.hs @@ -18,8 +18,8 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (replicateM, unless, when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim (runSimStrictShutdown) import Control.Tracer import qualified Data.ByteString.Char8 as BSC @@ -143,7 +143,7 @@ data LookupResultIO = LookupResultIO { , lrioValency :: !Int } -mockResolver :: forall m. (MonadTimer m) => LookupResult -> Resolver m +mockResolver :: forall m. MonadDelay m => LookupResult -> Resolver m mockResolver lr = Resolver lA lAAAA where lA :: DNS.Domain -> m (Either DNS.DNSError [Socket.SockAddr]) @@ -156,7 +156,7 @@ mockResolver lr = Resolver lA lAAAA threadDelay (lrIpv6Delay lr) return $ lrIpv6Result lr -withMockResolver :: MonadTimer m +withMockResolver :: MonadDelay m => LookupResult -> (Resolver m -> m a) -> m a @@ -303,6 +303,7 @@ permCheck a b = L.sort a === L.sort b prop_resolv :: forall m. ( MonadAsync m , MonadCatch m + , MonadDelay m , MonadTime m , MonadTimer m ) diff --git a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs index 4d0a8642b8f..f9b6592b196 100644 --- a/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs +++ b/ouroboros-network-framework/test/Test/Simulation/Network/Snocket.hs @@ -18,14 +18,15 @@ module Test.Simulation.Network.Snocket , toBearerInfo ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Control.Tracer (Tracer (..), contramap, contramapM, nullTracer) @@ -165,7 +166,9 @@ untilSuccess go = clientServerSimulation :: forall m addr payload. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadFork m , MonadLabelledSTM m , MonadMask m diff --git a/ouroboros-network-framework/testlib/TestLib/Utils.hs b/ouroboros-network-framework/testlib/TestLib/Utils.hs index 8d4894f7e4d..63b8305c2a9 100644 --- a/ouroboros-network-framework/testlib/TestLib/Utils.hs +++ b/ouroboros-network-framework/testlib/TestLib/Utils.hs @@ -3,7 +3,7 @@ module TestLib.Utils where -import Control.Monad.Class.MonadTime (DiffTime, Time, diffTime) +import Control.Monad.Class.MonadTime.SI (DiffTime, Time, diffTime) import Control.Monad.IOSim import Data.Bifoldable (bifoldMap) diff --git a/ouroboros-network-protocols/ouroboros-network-protocols.cabal b/ouroboros-network-protocols/ouroboros-network-protocols.cabal index 7f90f5dbcbc..2e9871a5eae 100644 --- a/ouroboros-network-protocols/ouroboros-network-protocols.cabal +++ b/ouroboros-network-protocols/ouroboros-network-protocols.cabal @@ -98,10 +98,12 @@ library bytestring >=0.10 && <0.12, cborg >=0.2.1 && <0.3, - io-classes ^>=0.3, + io-classes ^>=1.0, + si-timers, + ouroboros-network-api, serialise, - typed-protocols >=0.1 && <1.0, + typed-protocols >=0.1.0.4 && <1.0, typed-protocols-cborg >=0.1 && <1.0 @@ -176,6 +178,7 @@ library testlib ouroboros-network-framework, ouroboros-network-mock, ouroboros-network-protocols, + si-timers, strict-stm, typed-protocols diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs index 7e5821d24ae..ce29cad0443 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/BlockFetch/Codec.hs @@ -15,7 +15,7 @@ module Ouroboros.Network.Protocol.BlockFetch.Codec ) where import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import qualified Data.ByteString.Lazy as LBS diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Codec.hs index 2fc2a66b3d2..ab44a697830 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/ChainSync/Codec.hs @@ -14,7 +14,7 @@ module Ouroboros.Network.Protocol.ChainSync.Codec ) where import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Network.TypedProtocol.Codec.CBOR diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/KeepAlive/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/KeepAlive/Codec.hs index 669406e3b13..6176399494f 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/KeepAlive/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/KeepAlive/Codec.hs @@ -14,7 +14,7 @@ module Ouroboros.Network.Protocol.KeepAlive.Codec ) where import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadTime (DiffTime) +import Control.Monad.Class.MonadTime.SI (DiffTime) import Data.ByteString.Lazy (ByteString) import Text.Printf diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs index 9a30e02d1b0..13dd16a170d 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/PeerSharing/Codec.hs @@ -22,7 +22,7 @@ import Ouroboros.Network.Protocol.PeerSharing.Type (ClientHasAgency (..), Message (..), PeerSharing, ServerHasAgency (..)) -import Control.Monad.Class.MonadTime (DiffTime) +import Control.Monad.Class.MonadTime.SI (DiffTime) import Ouroboros.Network.Protocol.Limits codecPeerSharing :: forall m peerAddress. diff --git a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs index 89792ce2b52..407dc894f1c 100644 --- a/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs +++ b/ouroboros-network-protocols/src/Ouroboros/Network/Protocol/TxSubmission2/Codec.hs @@ -16,7 +16,7 @@ module Ouroboros.Network.Protocol.TxSubmission2.Codec ) where import Control.Monad.Class.MonadST -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import qualified Data.List.NonEmpty as NonEmpty import qualified Codec.CBOR.Decoding as CBOR diff --git a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/Handshake/Test.hs b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/Handshake/Test.hs index 2a66c290963..3d738009269 100644 --- a/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/Handshake/Test.hs +++ b/ouroboros-network-protocols/testlib/Ouroboros/Network/Protocol/Handshake/Test.hs @@ -30,13 +30,15 @@ import GHC.Generics import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Term as CBOR +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadCatch, MonadMask, MonadThrow, bracket) -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim (runSimOrThrow) import Control.Tracer (nullTracer) @@ -1010,10 +1012,14 @@ prop_channel_simultaneous_open_NodeToClient_IO prop_channel_simultaneous_open_sim :: forall vNumber vData m. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadCatch m + , MonadDelay m + , MonadFork m , MonadLabelledSTM m , MonadMask m + , MonadMonotonicTime m , MonadST m , MonadThrow (STM m) , MonadTime m diff --git a/ouroboros-network-testing/ouroboros-network-testing.cabal b/ouroboros-network-testing/ouroboros-network-testing.cabal index 9cc4f4e4587..4019cf4cfde 100644 --- a/ouroboros-network-testing/ouroboros-network-testing.cabal +++ b/ouroboros-network-testing/ouroboros-network-testing.cabal @@ -62,9 +62,10 @@ library containers, contra-tracer, deque, - io-classes ^>=0.3, + io-classes ^>=1.0, io-sim, psqueues >=0.2.3 && <0.3, + si-timers, tasty, tasty-expected-failure, diff --git a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/AbsBearerInfo.hs b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/AbsBearerInfo.hs index 4a4a7329d79..55ae5137f6b 100644 --- a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/AbsBearerInfo.hs +++ b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/AbsBearerInfo.hs @@ -22,7 +22,7 @@ module Ouroboros.Network.Testing.Data.AbsBearerInfo , AbsIOErrType (..) ) where -import Control.Monad.Class.MonadTime (DiffTime, Time (..), addTime) +import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..), addTime) import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty diff --git a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Script.hs b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Script.hs index 093b825e1b0..ce93b6be339 100644 --- a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Script.hs +++ b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Script.hs @@ -37,7 +37,7 @@ import qualified Data.Set as Set import Control.Concurrent.Class.MonadSTM import Control.Concurrent.Class.MonadSTM as LazySTM import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import Ouroboros.Network.Testing.Utils (prop_shrink_nonequal, @@ -140,7 +140,7 @@ instance Arbitrary ScriptDelay where shrink NoDelay = [] shrink (Delay _) = [] -playTimedScript :: (MonadAsync m, MonadTimer m) +playTimedScript :: (MonadAsync m, MonadDelay m) => Tracer m a -> TimedScript a -> m (TVar m a) playTimedScript tracer (Script ((x0,d0) :| script)) = do v <- newTVarIO x0 diff --git a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Signal.hs b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Signal.hs index f23589eb985..2be71fac62d 100644 --- a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Signal.hs +++ b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Data/Signal.hs @@ -51,7 +51,7 @@ import qualified Data.Set as Set import Deque.Lazy (Deque) import qualified Deque.Lazy as Deque -import Control.Monad.Class.MonadTime (DiffTime, Time (..), addTime) +import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..), addTime) import Test.QuickCheck diff --git a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Utils.hs b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Utils.hs index e647f44a70a..fce674fb1c7 100644 --- a/ouroboros-network-testing/src/Ouroboros/Network/Testing/Utils.hs +++ b/ouroboros-network-testing/src/Ouroboros/Network/Testing/Utils.hs @@ -35,7 +35,7 @@ module Ouroboros.Network.Testing.Utils ) where import Control.Monad.Class.MonadSay -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Contravariant (contramap), Tracer (..), contramapM) diff --git a/ouroboros-network/ouroboros-network.cabal b/ouroboros-network/ouroboros-network.cabal index 7da76b7aafd..698a2d0a0ae 100644 --- a/ouroboros-network/ouroboros-network.cabal +++ b/ouroboros-network/ouroboros-network.cabal @@ -118,13 +118,15 @@ library contra-tracer, monoidal-synchronisation, - io-classes, + io-classes ^>=1.0, + io-classes-mtl ^>=0.1, network-mux, + si-timers, ouroboros-network-api, ouroboros-network-framework ^>=0.4, ouroboros-network-protocols ^>=0.4, strict-stm, - typed-protocols, + typed-protocols >=0.1.0.4 && <1.0, if !os(windows) build-depends: directory, unix @@ -218,6 +220,7 @@ test-suite test ouroboros-network-protocols:testlib, ouroboros-network-framework:testlib, ouroboros-network-testing, + si-timers, strict-stm, typed-protocols, typed-protocols-examples, diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs index 2d89ea012cc..f344589bd90 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch.hs @@ -105,8 +105,8 @@ import Data.Hashable (Hashable) import Data.Void import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer) import Ouroboros.Network.Block @@ -158,7 +158,6 @@ blockFetchLogic :: forall addr header block m. , HasHeader block , HeaderHash header ~ HeaderHash block , MonadDelay m - , MonadMonotonicTime m , MonadSTM m , Ord addr , Hashable addr diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs index e8a58beffdb..7191c368cf9 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Client.hs @@ -24,7 +24,7 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad (unless) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import qualified Data.Set as Set @@ -75,8 +75,8 @@ type BlockFetchClient header block m a = -- blockFetchClient :: forall header block versionNumber m. (MonadSTM m, MonadThrow m, MonadTime m, - HasHeader header, HasHeader block, - HeaderHash header ~ HeaderHash block) + MonadMonotonicTime m, HasHeader header, + HasHeader block, HeaderHash header ~ HeaderHash block) => versionNumber -> ControlMessageSTM m -> FetchedMetricsTracer m diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs index cf60f63ae36..dc684429cb0 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/ClientState.hs @@ -39,7 +39,7 @@ import qualified Data.Set as Set import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad (when) -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer, traceWith) import Network.Mux.Trace (TraceLabelPeer (..)) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs index a99aea88b99..66a39528f03 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/Decision.hs @@ -33,7 +33,7 @@ import GHC.Stack (HasCallStack) import Control.Exception (assert) import Control.Monad (guard) -import Control.Monad.Class.MonadTime (DiffTime) +import Control.Monad.Class.MonadTime.SI (DiffTime) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/DeltaQ.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/DeltaQ.hs index 27c6ee1da2e..6a9d40391dd 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/DeltaQ.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/DeltaQ.hs @@ -18,7 +18,7 @@ module Ouroboros.Network.BlockFetch.DeltaQ , comparePeerGSV' ) where -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Data.Fixed as Fixed (Pico) import Data.Hashable import Data.Set (Set) diff --git a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs index 15e21c9ba9f..1dfa6b2b10a 100644 --- a/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs +++ b/ouroboros-network/src/Ouroboros/Network/BlockFetch/State.hs @@ -25,8 +25,8 @@ import Data.Void import Control.Exception (assert) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) @@ -49,7 +49,6 @@ fetchLogicIterations , HasHeader block , HeaderHash header ~ HeaderHash block , MonadDelay m - , MonadMonotonicTime m , MonadSTM m , Ord peer , Hashable peer diff --git a/ouroboros-network/src/Ouroboros/Network/DeltaQ.hs b/ouroboros-network/src/Ouroboros/Network/DeltaQ.hs index 80435304c82..ae3e044bf01 100644 --- a/ouroboros-network/src/Ouroboros/Network/DeltaQ.hs +++ b/ouroboros-network/src/Ouroboros/Network/DeltaQ.hs @@ -33,7 +33,8 @@ module Ouroboros.Network.DeltaQ , fromSample ) where -import Control.Monad.Class.MonadTime (DiffTime, Time (..), diffTime) +import Control.Monad.Class.MonadTime.SI (DiffTime, Time (..), + diffTime) import Ouroboros.Network.SizeInBytes (SizeInBytes (..)) diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs index 4c6bdf789e9..59c31b65566 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/P2P.hs @@ -29,14 +29,15 @@ module Ouroboros.Network.Diffusion.P2P ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (IOException) import Control.Monad.Class.MonadAsync (Async, MonadAsync) import qualified Control.Monad.Class.MonadAsync as Async import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.Fix (MonadFix) import Control.Tracer (Tracer, contramap, nullTracer, traceWith) import Data.ByteString.Lazy (ByteString) @@ -568,7 +569,9 @@ runM :: forall m ntnFd ntnAddr ntnVersion ntnVersionData ntcFd ntcAddr ntcVersion ntcVersionData resolver resolverError a. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadEvaluate m , MonadFix m , MonadFork m diff --git a/ouroboros-network/src/Ouroboros/Network/Diffusion/Policies.hs b/ouroboros-network/src/Ouroboros/Network/Diffusion/Policies.hs index a03fb3f2350..c92a46722a7 100644 --- a/ouroboros-network/src/Ouroboros/Network/Diffusion/Policies.hs +++ b/ouroboros-network/src/Ouroboros/Network/Diffusion/Policies.hs @@ -6,7 +6,7 @@ module Ouroboros.Network.Diffusion.Policies where import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Data.List (sortOn, unfoldr) import qualified Data.Map.Merge.Strict as Map diff --git a/ouroboros-network/src/Ouroboros/Network/ExitPolicy.hs b/ouroboros-network/src/Ouroboros/Network/ExitPolicy.hs index 3428efb48b1..f24d4b8d14b 100644 --- a/ouroboros-network/src/Ouroboros/Network/ExitPolicy.hs +++ b/ouroboros-network/src/Ouroboros/Network/ExitPolicy.hs @@ -11,7 +11,7 @@ module Ouroboros.Network.ExitPolicy , alwaysCleanReturnPolicy ) where -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Data.Semigroup (Max (..)) newtype ReconnectDelay = ReconnectDelay { reconnectDelay :: DiffTime } diff --git a/ouroboros-network/src/Ouroboros/Network/KeepAlive.hs b/ouroboros-network/src/Ouroboros/Network/KeepAlive.hs index 02ad79db252..1e900d33cc9 100644 --- a/ouroboros-network/src/Ouroboros/Network/KeepAlive.hs +++ b/ouroboros-network/src/Ouroboros/Network/KeepAlive.hs @@ -14,8 +14,8 @@ module Ouroboros.Network.KeepAlive import qualified Control.Concurrent.Class.MonadSTM as Lazy import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, traceWith) import qualified Data.Map.Strict as M import Data.Maybe (fromJust) @@ -40,8 +40,7 @@ instance Show peer => Show (TraceKeepAliveClient peer) where keepAliveClient :: forall m peer. - ( MonadMonotonicTime m - , MonadTimer m + ( MonadTimer m , Ord peer ) => Tracer m (TraceKeepAliveClient peer) diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs index 1d0f5bd775b..a4ec84aa5e9 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToClient.hs @@ -76,7 +76,7 @@ import qualified Control.Concurrent.Async as Async import Control.Exception (ErrorCall, IOException) import Control.Monad (forever) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import qualified Codec.CBOR.Term as CBOR import qualified Data.ByteString.Lazy as BL @@ -431,7 +431,7 @@ type LocalConnectionId = ConnectionId LocalAddress -- chainSyncPeerNull - :: forall (header :: Type) (point :: Type) (tip :: Type) m a. MonadTimer m + :: forall (header :: Type) (point :: Type) (tip :: Type) m a. MonadDelay m => Peer (ChainSync.ChainSync header point tip) AsClient ChainSync.StIdle m a chainSyncPeerNull = @@ -440,7 +440,7 @@ chainSyncPeerNull = localStateQueryPeerNull :: forall (block :: Type) (point :: Type) (query :: Type -> Type) m a. - MonadTimer m + MonadDelay m => Peer (LocalStateQuery.LocalStateQuery block point query) AsClient LocalStateQuery.StIdle m a localStateQueryPeerNull = @@ -448,7 +448,7 @@ localStateQueryPeerNull = (LocalStateQuery.LocalStateQueryClient untilTheCowsComeHome) localTxSubmissionPeerNull - :: forall (tx :: Type) (reject :: Type) m a. MonadTimer m + :: forall (tx :: Type) (reject :: Type) m a. MonadDelay m => Peer (LocalTxSubmission.LocalTxSubmission tx reject) AsClient LocalTxSubmission.StIdle m a localTxSubmissionPeerNull = @@ -456,7 +456,7 @@ localTxSubmissionPeerNull = (LocalTxSubmission.LocalTxSubmissionClient untilTheCowsComeHome) localTxMonitorPeerNull - :: forall (txid :: Type) (tx :: Type) (slot :: Type) m a. MonadTimer m + :: forall (txid :: Type) (tx :: Type) (slot :: Type) m a. MonadDelay m => Peer (LocalTxMonitor.LocalTxMonitor txid tx slot) AsClient LocalTxMonitor.StIdle m a localTxMonitorPeerNull = @@ -464,5 +464,5 @@ localTxMonitorPeerNull = (LocalTxMonitor.LocalTxMonitorClient untilTheCowsComeHome) -- ;) -untilTheCowsComeHome :: MonadTimer m => m a +untilTheCowsComeHome :: MonadDelay m => m a untilTheCowsComeHome = forever $ threadDelay 43200 {- day in seconds -} diff --git a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs index 50f506e83da..38282608b61 100644 --- a/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs +++ b/ouroboros-network/src/Ouroboros/Network/NodeToNode.hs @@ -103,7 +103,7 @@ module Ouroboros.Network.NodeToNode import qualified Control.Concurrent.Async as Async import Control.Exception (IOException) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime (DiffTime) +import Control.Monad.Class.MonadTime.SI (DiffTime) import qualified Codec.CBOR.Read as CBOR import qualified Codec.CBOR.Term as CBOR diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/EstablishedPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/EstablishedPeers.hs index 403b4dce945..a517f824348 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/EstablishedPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/EstablishedPeers.hs @@ -42,7 +42,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Control.Exception (assert) -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI ------------------------------- diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs index 111e5a4ffad..69a05e3b39d 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -44,8 +45,8 @@ import Control.Concurrent.JobPool (JobPool) import qualified Control.Concurrent.JobPool as JobPool import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer (..), traceWith) import System.Random @@ -434,9 +435,16 @@ base our decision on include: -- | -- -peerSelectionGovernor :: (MonadAsync m, MonadLabelledSTM m, MonadMask m, - MonadTime m, MonadTimer m, Ord peeraddr, - Show peerconn) +peerSelectionGovernor :: ( Alternative (STM m) + , MonadAsync m + , MonadDelay m + , MonadLabelledSTM m + , MonadMask m + , MonadTime m + , MonadTimer m + , Ord peeraddr + , Show peerconn + ) => Tracer m (TracePeerSelection peeraddr) -> Tracer m (DebugPeerSelection peeraddr) -> Tracer m PeerSelectionCounters @@ -475,9 +483,15 @@ peerSelectionGovernor tracer debugTracer countersTracer fuzzRng stateVar actions -- action asynchronously. -- peerSelectionGovernorLoop :: forall m peeraddr peerconn. - (MonadAsync m, MonadMask m, - MonadTime m, MonadTimer m, - Ord peeraddr, Show peerconn) + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m + , MonadMask m + , MonadTime m + , MonadTimer m + , Ord peeraddr + , Show peerconn + ) => Tracer m (TracePeerSelection peeraddr) -> Tracer m (DebugPeerSelection peeraddr) -> Tracer m PeerSelectionCounters @@ -540,10 +554,12 @@ peerSelectionGovernorLoop tracer Guarded (Just (Min wakeupAt)) decisionAction -> do let wakeupIn = diffTime wakeupAt blockedAt traceWith debugTracer (TraceGovernorState blockedAt (Just wakeupIn) st) - wakupTimeout <- newTimeout wakeupIn - let wakeup = awaitTimeout wakupTimeout >> pure (wakeupDecision st) + (readTimeout, cancelTimeout) <- registerDelayCancellable wakeupIn + let wakeup = readTimeout >>= (\case TimeoutPending -> retry + _ -> return ()) + >> pure (wakeupDecision st) timedDecision <- atomically (decisionAction <|> wakeup) - cancelTimeout wakupTimeout + cancelTimeout return timedDecision guardedDecisions :: Time @@ -599,7 +615,6 @@ $peer-churn-governor -- peerChurnGovernor :: forall m peeraddr. ( MonadSTM m - , MonadMonotonicTime m , MonadDelay m ) => Tracer m (TracePeerSelection peeraddr) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs index bcf79751711..02a17c2e713 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/ActivePeers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -13,11 +14,12 @@ import Data.Semigroup (Min (..)) import Data.Set (Set) import qualified Data.Set as Set +import Control.Applicative (Alternative) import Control.Concurrent.JobPool (Job (..)) import Control.Exception (SomeException, assert) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import System.Random (randomR) import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers @@ -36,7 +38,11 @@ import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeer -- peers/ according to 'policyPickWarmPeersToPromote' policy. -- belowTarget :: forall peeraddr peerconn m. - (MonadDelay m, MonadSTM m, Ord peeraddr) + ( Alternative (STM m) + , MonadDelay m + , MonadSTM m + , Ord peeraddr + ) => PeerSelectionActions peeraddr peerconn m -> MkGuardedDecision peeraddr peerconn m belowTarget = belowTargetLocal <> belowTargetOther @@ -323,7 +329,10 @@ jobPromoteWarmPeer PeerSelectionActions{peerStateActions = PeerStateActions {act -- /warm peers/, according to 'policyPickHotPeersToDemote'. -- aboveTarget :: forall peeraddr peerconn m. - (MonadSTM m, Ord peeraddr) + ( Alternative (STM m) + , MonadSTM m + , Ord peeraddr + ) => PeerSelectionActions peeraddr peerconn m -> MkGuardedDecision peeraddr peerconn m aboveTarget = aboveTargetLocal <> aboveTargetOther diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs index 247e3904f2f..89fc7364813 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/EstablishedPeers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -12,10 +13,11 @@ import Data.Semigroup (Min (..)) import Data.Set (Set) import qualified Data.Set as Set +import Control.Applicative (Alternative) import Control.Concurrent.JobPool (Job (..)) import Control.Exception (SomeException) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import System.Random (randomR) import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers @@ -48,7 +50,10 @@ import qualified Ouroboros.Network.PeerSelection.LocalRootPeers as LocalRootPeer -- action never picks local root peers. -- belowTarget :: forall peeraddr peerconn m. - (MonadSTM m, Ord peeraddr) + ( Alternative (STM m) + , MonadSTM m + , Ord peeraddr + ) => PeerSelectionActions peeraddr peerconn m -> MkGuardedDecision peeraddr peerconn m belowTarget = belowTargetLocal <> belowTargetOther diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs index cf60db85c00..08b31623cc5 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/KnownPeers.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -16,8 +17,8 @@ import Control.Concurrent.JobPool (Job (..)) import Control.Exception (Exception (..), SomeException, assert) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import qualified Ouroboros.Network.PeerSelection.EstablishedPeers as EstablishedPeers import Ouroboros.Network.PeerSelection.Governor.Types @@ -422,11 +423,12 @@ waitAllCatchOrTimeout :: (MonadAsync m, MonadTimer m) -> m (Either [Maybe (Either SomeException a)] [Either SomeException a]) waitAllCatchOrTimeout as time = do - t <- newTimeout time + (readTimeout, cancelTimeout) <- registerDelayCancellable time results <- atomically $ (Right <$> mapM waitCatchSTM as) - `orElse` (Left <$> (awaitTimeout t >> mapM pollSTM as)) + `orElse` (Left <$> (readTimeout >>= \case TimeoutPending -> retry + _ -> mapM pollSTM as)) case results of - Right{} -> cancelTimeout t + Right{} -> cancelTimeout _ -> return () return results diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs index a7db121622f..7bdecea0d24 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Monitor.hs @@ -25,7 +25,7 @@ import Control.Concurrent.JobPool (JobPool) import qualified Control.Concurrent.JobPool as JobPool import Control.Exception (assert) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import System.Random (randomR) import Ouroboros.Network.ExitPolicy (ReconnectDelay) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/RootPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/RootPeers.hs index 522929c42e7..bf5f4688f20 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/RootPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/RootPeers.hs @@ -10,7 +10,7 @@ import qualified Data.Set as Set import Control.Concurrent.JobPool (Job (..)) import Control.Exception (SomeException, assert) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Ouroboros.Network.PeerSelection.Governor.Types import qualified Ouroboros.Network.PeerSelection.KnownPeers as KnownPeers diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs index 51289a5136c..88b2ea1cc6f 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Governor/Types.hs @@ -56,7 +56,7 @@ import Control.Applicative (Alternative) import Control.Concurrent.JobPool (Job) import Control.Exception (SomeException, assert) import Control.Monad.Class.MonadSTM -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import System.Random (StdGen) import Ouroboros.Network.ExitPolicy diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/KnownPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/KnownPeers.hs index 99e46522b52..7f22a570963 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/KnownPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/KnownPeers.hs @@ -43,7 +43,7 @@ import qualified Data.Set as Set --import System.Random (RandomGen(..)) import Control.Exception (assert) -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Ouroboros.Network.PeerSelection.LedgerPeers (IsLedgerPeer (..)) import Ouroboros.Network.PeerSelection.PeerAdvertise (PeerAdvertise) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs index 1aab3e7ba4e..e210d01b298 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/LedgerPeers.hs @@ -27,7 +27,7 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (assert) import Control.Monad (when) import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer, traceWith) import qualified Data.IP as IP import Data.List (foldl') @@ -204,6 +204,7 @@ long_PEER_LIST_LIFE_TIME = 1847 -- a prime number! -- ledgerPeersThread :: forall m peerAddr. ( MonadAsync m + , MonadMonotonicTime m , MonadTime m , Ord peerAddr ) @@ -303,6 +304,7 @@ ledgerPeersThread inRng toPeerAddr tracer readUseLedgerAfter LedgerPeersConsensu -- withLedgerPeers :: forall peerAddr m a. ( MonadAsync m + , MonadMonotonicTime m , MonadTime m , Ord peerAddr ) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs index a26004e3d02..43cf98f8387 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -30,7 +30,7 @@ module Ouroboros.Network.PeerSelection.PeerMetric import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (when) -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer (Tracer (..), contramap, nullTracer) import Data.Bifunctor (Bifunctor (..)) import Data.IntPSQ (IntPSQ) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs index df1f8202880..eaeb06bdb68 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/PeerStateActions.hs @@ -29,12 +29,13 @@ module Ouroboros.Network.PeerSelection.PeerStateActions , FailureType (..) ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (SomeAsyncException (..)) import Control.Monad (when, (<=<)) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import Control.Concurrent.JobPool (Job (..), JobPool) import qualified Control.Concurrent.JobPool as JobPool @@ -539,7 +540,8 @@ data PeerStateActionsArguments muxMode socket peerAddr versionData versionNumber withPeerStateActions :: forall (muxMode :: MuxMode) socket peerAddr versionData versionNumber m a b x. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadCatch m , MonadLabelledSTM m , MonadMask m @@ -1017,7 +1019,8 @@ mkApplicationHandleBundle muxBundle controlMessageBundle awaitVarsBundle = -- protocol bundle indicated by the type of the first argument. -- startProtocols :: forall (muxMode :: MuxMode) (pt :: ProtocolTemperature) peerAddr versionData m a b. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadCatch m , MonadThrow (STM m) , HasInitiator muxMode ~ True diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index dde9c567f38..6e0acba8ba1 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -45,13 +45,13 @@ import qualified Data.Set as Set import Data.Void (Void, absurd) import Data.Word (Word32) -import Control.Applicative ((<|>)) +import Control.Applicative (Alternative, (<|>)) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer (..), contramap, traceWith) @@ -91,7 +91,8 @@ data TraceLocalRootPeers peerAddr exception = -- localRootPeersProvider :: forall m peerAddr resolver exception. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadDelay m , Eq (Async m Void) , Ord peerAddr diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs index bed224493f8..8f50200e4ae 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/RootPeersDNS/DNSActions.hs @@ -24,12 +24,13 @@ import qualified Data.List.NonEmpty as NonEmpty import Control.Exception (IOException) import Control.Monad.Class.MonadAsync +import Control.Monad.Class.Trans () import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.Except import Control.Tracer (Tracer (..), traceWith) diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Simple.hs b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Simple.hs index 2fb2937aeae..c1217e543f5 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSelection/Simple.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSelection/Simple.hs @@ -12,11 +12,12 @@ module Ouroboros.Network.PeerSelection.Simple ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer) import Data.Foldable (toList) @@ -43,7 +44,8 @@ import Ouroboros.Network.Protocol.PeerSharing.Type withPeerSelectionActions :: forall peeraddr peerconn resolver exception m a. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadDelay m , MonadThrow m , MonadMVar m diff --git a/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs b/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs index c0c953248cd..13a17f4cd7e 100644 --- a/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs +++ b/ouroboros-network/src/Ouroboros/Network/PeerSharing.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TupleSections #-} module Ouroboros.Network.PeerSharing where -import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM, +import Control.Applicative (Alternative) +import Control.Concurrent.Class.MonadSTM.Strict (MonadSTM, STM, StrictTMVar, StrictTVar, atomically, modifyTVar, newEmptyTMVarIO, newTVarIO, retry, takeTMVar) import Control.Monad.Class.MonadMVar (MVar, MonadMVar (putMVar)) @@ -65,7 +67,8 @@ bracketPeerSharingClient (PeerSharingRegistry registry) peer k = do (\_ -> atomically (modifyTVar registry (Map.delete peer))) (\_ -> k newPSController) -peerSharingClient :: ( MonadMVar m +peerSharingClient :: ( Alternative (STM m) + , MonadMVar m , MonadSTM m ) => ControlMessageSTM m diff --git a/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs b/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs index 001f6f02d3b..6b4230a513a 100644 --- a/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs +++ b/ouroboros-network/test/Ouroboros/Network/BlockFetch/Examples.hs @@ -29,8 +29,8 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer, contramap, nullTracer) import Ouroboros.Network.AnchoredFragment (AnchoredFragment, @@ -61,8 +61,9 @@ import Ouroboros.Network.Mock.ConcreteBlock -- | Run a single block fetch protocol until the chain is downloaded. -- blockFetchExample0 :: forall m. - (MonadSTM m, MonadST m, MonadAsync m, MonadFork m, - MonadTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) + (MonadSTM m, MonadST m, MonadAsync m, MonadDelay m, + MonadFork m, MonadTime m, MonadTimer m, MonadMask m, + MonadThrow (STM m)) => Tracer m [TraceLabelPeer Int (FetchDecision [Point BlockHeader])] -> Tracer m (TraceLabelPeer Int @@ -169,8 +170,9 @@ blockFetchExample0 decisionTracer clientStateTracer clientMsgTracer -- will be interested in downloading them all. -- blockFetchExample1 :: forall m. - (MonadSTM m, MonadST m, MonadAsync m, MonadFork m, - MonadTime m, MonadTimer m, MonadMask m, MonadThrow (STM m)) + (MonadSTM m, MonadST m, MonadAsync m, MonadDelay m, + MonadFork m, MonadTime m, MonadTimer m, MonadMask m, + MonadThrow (STM m)) => Tracer m [TraceLabelPeer Int (FetchDecision [Point BlockHeader])] -> Tracer m (TraceLabelPeer Int @@ -317,8 +319,8 @@ exampleFixedPeerGSVs = -- Utils to run fetch clients and servers -- -runFetchClient :: (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m), - MonadST m, MonadTime m, MonadTimer m, +runFetchClient :: (MonadAsync m, MonadDelay m, MonadFork m, MonadMask m, + MonadThrow (STM m), MonadST m, MonadTime m, MonadTimer m, Ord peerid, Serialise block, Serialise point, Typeable block, ShowProxy block) => Tracer m (TraceSendRecv (BlockFetch block point)) @@ -356,8 +358,8 @@ runFetchServer tracer channel server = runFetchClientAndServerAsync :: forall peerid block header version m a b. - (MonadAsync m, MonadFork m, MonadMask m, MonadThrow (STM m), - MonadST m, MonadTime m, MonadTimer m, + (MonadAsync m, MonadDelay m, MonadFork m, MonadMask m, + MonadThrow (STM m), MonadST m, MonadTime m, MonadTimer m, Ord peerid, Show peerid, Serialise header, Serialise block, Serialise (HeaderHash block), diff --git a/ouroboros-network/test/Ouroboros/Network/MockNode.hs b/ouroboros-network/test/Ouroboros/Network/MockNode.hs index 2d8f1538b7d..7a48313c7a1 100644 --- a/ouroboros-network/test/Ouroboros/Network/MockNode.hs +++ b/ouroboros-network/test/Ouroboros/Network/MockNode.hs @@ -28,7 +28,7 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (nullTracer) import Network.TypedProtocol.Codec @@ -124,6 +124,7 @@ instance Monoid (NodeChannels m block tip) where createOneWaySubscriptionChannels :: forall block tip m. ( MonadSTM m + , MonadDelay m , MonadTimer m ) => DiffTime @@ -147,7 +148,8 @@ createOneWaySubscriptionChannels trDelay1 trDelay2 = do -- createTwoWaySubscriptionChannels :: forall block tip m. - ( MonadSTM m + ( MonadDelay m + , MonadSTM m , MonadTimer m ) => DiffTime @@ -162,6 +164,7 @@ createTwoWaySubscriptionChannels trDelay1 trDelay2 = do -- @slotDuration * blockSlot block@ time. blockGenerator :: forall block m. ( HasHeader block + , MonadDelay m , MonadSTM m , MonadFork m , MonadTimer m @@ -337,6 +340,7 @@ relayNode _nid initChain chans = do -- forkCoreKernel :: forall block m. ( HasFullHeader block + , MonadDelay m , MonadSTM m , MonadFork m , MonadTimer m @@ -383,7 +387,8 @@ forkCoreKernel slotDuration gchain fixupBlock cpsVar = do -- occupied, it will replace it with its block. -- coreNode :: forall m. - ( MonadSTM m + ( MonadDelay m + , MonadSTM m , MonadFork m , MonadThrow m , MonadTimer m diff --git a/ouroboros-network/test/Test/LedgerPeers.hs b/ouroboros-network/test/Test/LedgerPeers.hs index f61cf572f81..fee0f56e553 100644 --- a/ouroboros-network/test/Test/LedgerPeers.hs +++ b/ouroboros-network/test/Test/LedgerPeers.hs @@ -10,8 +10,8 @@ import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim hiding (SimResult) import Control.Tracer (Tracer (..), showTracing, traceWith) import qualified Data.IP as IP diff --git a/ouroboros-network/test/Test/Mux.hs b/ouroboros-network/test/Test/Mux.hs index 0efc545bc8f..0ea8789fb40 100644 --- a/ouroboros-network/test/Test/Mux.hs +++ b/ouroboros-network/test/Test/Mux.hs @@ -12,14 +12,15 @@ module Test.Mux (tests) where import Codec.Serialise (Serialise (..)) +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Control.Tracer @@ -79,7 +80,9 @@ testProtocols chainSync = demo :: forall m block. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadCatch m , MonadFork m , MonadLabelledSTM m diff --git a/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs b/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs index 55159838818..9d49da73ad0 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/BlockFetch.hs @@ -29,8 +29,8 @@ import Control.Monad (unless) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime (Time (..)) -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI (Time (..)) +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Control.Tracer (Tracer (Tracer), contramap, nullTracer) @@ -556,8 +556,8 @@ _unit_bracketSyncWithFetchClient step = do checkResult _ = assertFailure "unexpected result" testSkeleton :: forall m a b. - (MonadAsync m, MonadFork m, MonadMask m, MonadSTM m, - MonadTimer m, MonadThrow m, MonadThrow (STM m)) + (MonadAsync m, MonadDelay m, MonadFork m, MonadMask m, + MonadSTM m, MonadTimer m, MonadThrow m, MonadThrow (STM m)) => ((forall c. m c -> m c) -> m a) -> ((forall c. m c -> m c) -> m b) -> m (Either (Either SomeException a) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs index f60c583cd8e..780ce14b298 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node.hs @@ -30,6 +30,7 @@ module Test.Ouroboros.Network.Diffusion.Node , config_RECONNECT_DELAY ) where +import Control.Applicative (Alternative) import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad ((>=>)) @@ -40,8 +41,8 @@ import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadEvaluate, MonadMask, MonadThrow, SomeException) -import Control.Monad.Class.MonadTime (DiffTime, MonadTime) -import Control.Monad.Class.MonadTimer (MonadTimer) +import Control.Monad.Class.MonadTime.SI (DiffTime, MonadTime) +import Control.Monad.Class.MonadTimer.SI (MonadDelay, MonadTimer) import Control.Monad.Fix (MonadFix) import Control.Tracer (Tracer (..), nullTracer) @@ -162,7 +163,9 @@ data Arguments m = Arguments type ResolverException = SomeException run :: forall resolver m. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadEvaluate m , MonadFix m , MonadFork m diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs index c59e3c92054..eca1a62a404 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/MiniProtocols.hs @@ -16,6 +16,7 @@ module Test.Ouroboros.Network.Diffusion.Node.MiniProtocols , applications ) where +import Control.Applicative (Alternative) import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync @@ -23,8 +24,8 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer (..), contramap, nullTracer) import Data.ByteString.Lazy (ByteString) import Data.Functor (($>)) @@ -215,7 +216,8 @@ data AppArgs header block m = AppArgs -- | Protocol handlers. -- applications :: forall block header m. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadFork m , MonadMask m , MonadMVar m diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs index 73964690e0c..4761e035458 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Node/NodeKernel.hs @@ -30,13 +30,14 @@ module Test.Ouroboros.Network.Diffusion.Node.NodeKernel import GHC.Generics (Generic) +import Control.Applicative (Alternative) import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (replicateM, when) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import qualified Data.ByteString.Char8 as BSC import Data.Hashable (Hashable) import Data.IP (IP (..), fromIPv4w, fromIPv6w, toIPv4, toIPv4w, @@ -327,7 +328,9 @@ instance Exception NodeKernelError where -- withNodeKernelThread :: forall block header m seed a. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadMonotonicTime m , MonadTimer m , MonadThrow m diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Policies.hs b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Policies.hs index f4cd2d151dc..2a734224b20 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Policies.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Diffusion/Policies.hs @@ -10,7 +10,7 @@ module Test.Ouroboros.Network.Diffusion.Policies where import Control.Concurrent.Class.MonadSTM.Strict -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Monad.IOSim (runSimOrThrow) import qualified Data.IntPSQ as Pq import Data.List (foldl') @@ -126,8 +126,8 @@ instance Arbitrary ArbitraryPolicyArguments where return (slotNo, SlotNo $ fromIntegral slotNo, (peer, Time 0)) fetchedMetric :: [SockAddr] - -> Int - -> Gen (Int, SlotNo, ((SockAddr, SizeInBytes), Time)) + -> Int + -> Gen (Int, SlotNo, ((SockAddr, SizeInBytes), Time)) fetchedMetric peers slotNo = do peer <- elements peers fetched <- SizeInBytes <$> choose (1, 0xffff) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/KeepAlive.hs b/ouroboros-network/test/Test/Ouroboros/Network/KeepAlive.hs index 16360d33d49..4f7d74a4e27 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/KeepAlive.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/KeepAlive.hs @@ -14,8 +14,8 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim import Control.Tracer import qualified Data.ByteString.Lazy as BL @@ -99,6 +99,7 @@ runKeepAliveServer channel = runKeepAliveClientAndServer :: forall m peer header block. ( MonadAsync m + , MonadDelay m , MonadFork m , MonadMask m , MonadMonotonicTime m @@ -138,6 +139,7 @@ prop_keepAlive_convergenceM :: forall m. ( Eq (Async m ()) , MonadAsync m + , MonadDelay m , MonadFork m , MonadMask m , MonadMonotonicTime m diff --git a/ouroboros-network/test/Test/Ouroboros/Network/MockNode.hs b/ouroboros-network/test/Test/Ouroboros/Network/MockNode.hs index b0717c9f629..1f4b150275e 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/MockNode.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/MockNode.hs @@ -29,8 +29,8 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import qualified Control.Monad.IOSim as Sim import Ouroboros.Network.Block @@ -66,8 +66,9 @@ partitionProbe -- test_blockGenerator :: forall m. - ( MonadSTM m + ( MonadDelay m , MonadFork m + , MonadSTM m , MonadTime m , MonadTimer m ) @@ -127,10 +128,11 @@ prop_blockGenerator_IO (TestBlockChain chain) (Positive slotDuration) = slotDuration' :: DiffTime slotDuration' = fromIntegral slotDuration -coreToRelaySim :: ( MonadSTM m +coreToRelaySim :: ( MonadDelay m , MonadFork m - , MonadThrow m + , MonadSTM m , MonadSay m + , MonadThrow m , MonadTime m , MonadTimer m ) @@ -207,7 +209,8 @@ prop_coreToRelay (TestNodeSim chain slotDuration coreTrDelay relayTrDelay) = else mchain1 === Just chain -- Node graph: c → r → r -coreToRelaySim2 :: ( MonadSTM m +coreToRelaySim2 :: ( MonadDelay m + , MonadSTM m , MonadFork m , MonadThrow m , MonadSay m @@ -304,7 +307,8 @@ instance Arbitrary TestNetworkGraph where [ TestNetworkGraph g cs' | cs' <- shrinkList (:[]) cs, not (null cs') ] networkGraphSim :: forall m. - ( MonadSTM m + ( MonadDelay m + , MonadSTM m , MonadFork m , MonadThrow m , MonadSay m diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs index 409c86feee5..cc1fbc58c81 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection.hs @@ -43,8 +43,8 @@ import System.Random (mkStdGen) import Control.Exception (AssertionFailed (..), catch, evaluate) import Control.Monad.Class.MonadSTM (STM) -import Control.Monad.Class.MonadTime -import Control.Monad.IOSim.Types hiding (STM) +import Control.Monad.Class.MonadTime.SI +import Control.Monad.IOSim import Control.Tracer (Tracer (..)) import qualified Network.DNS as DNS (defaultResolvConf) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs index 07cf856f08e..dc89d4d1cba 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/MockEnvironment.hs @@ -46,8 +46,8 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadTest import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer hiding (timeout) +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI hiding (timeout) import qualified Control.Monad.Fail as Fail import Control.Monad.IOSim import Control.Tracer (Tracer (..), contramap, traceWith) @@ -231,8 +231,8 @@ data TraceMockEnv = TraceEnvAddPeers PeerGraph deriving Show mockPeerSelectionActions :: forall m. - (MonadAsync m, MonadTimer m, Fail.MonadFail m, - MonadThrow (STM m), MonadTraceSTM m) + (MonadAsync m, MonadDelay m, MonadTimer m, + Fail.MonadFail m, MonadThrow (STM m), MonadTraceSTM m) => Tracer m TraceMockEnv -> GovernorMockEnvironment -> PeerSelectionPolicy PeerAddr m @@ -283,7 +283,7 @@ instance Exception TransitionError where mockPeerSelectionActions' :: forall m. - (MonadAsync m, MonadSTM m, MonadTimer m, Fail.MonadFail m, + (MonadAsync m, MonadDelay m, MonadSTM m, MonadTimer m, Fail.MonadFail m, MonadThrow (STM m)) => Tracer m TraceMockEnv -> GovernorMockEnvironment diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerGraph.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerGraph.hs index 30b5c89d495..93599fac9fa 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerGraph.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerGraph.hs @@ -32,7 +32,7 @@ import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Tree as Tree -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Ouroboros.Network.Testing.Data.Script (Script (..), ScriptDelay (NoDelay), TimedScript, arbitraryScriptOf) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs index d9c8f4416d2..a82671c14a9 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/PeerMetric.hs @@ -10,8 +10,8 @@ import qualified Control.Concurrent.Class.MonadSTM as LazySTM import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (when) import Control.Monad.Class.MonadAsync -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer (Tracer (..), traceWith) import Data.Foldable (Foldable (foldl'), foldr') @@ -151,6 +151,7 @@ data PeerMetricsTrace = PeerMetricsTrace { simulatePeerMetricScript :: forall m. ( MonadAsync m + , MonadDelay m , MonadTimer m , MonadMonotonicTime m ) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs index db7c1bbf55d..bb7bac9f8c5 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/PeerSelection/RootPeersDNS.hs @@ -17,6 +17,7 @@ module Test.Ouroboros.Network.PeerSelection.RootPeersDNS import Ouroboros.Network.PeerSelection.RootPeersDNS +import Control.Applicative (Alternative) import Control.Monad (forever, replicateM_) import Data.ByteString.Char8 (pack) import Data.Dynamic (Typeable, fromDynamic) @@ -42,9 +43,9 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Exception (throw) import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime (Time (..)) -import Control.Monad.Class.MonadTimer -import qualified Control.Monad.Class.MonadTimer as MonadTimer +import Control.Monad.Class.MonadTime.SI (Time (..)) +import Control.Monad.Class.MonadTimer.SI +import qualified Control.Monad.Class.MonadTimer.SI as MonadTimer import Control.Monad.IOSim import Control.Tracer (Tracer (Tracer), contramap) @@ -307,7 +308,8 @@ newtype Solo a = Solo { unSolo :: a } -- | 'localRootPeersProvider' running with a given MockRoots env -- mockLocalRootPeersProvider :: forall m. - ( MonadAsync m + ( Alternative (STM m) + , MonadAsync m , MonadDelay m , MonadTimer m , MonadTraceSTM m @@ -360,6 +362,7 @@ mockLocalRootPeersProvider tracer (MockRoots localRootPeers dnsMapScript _ _) -- mockPublicRootPeersProvider :: forall m a. ( MonadAsync m + , MonadDelay m , MonadThrow m , MonadTimer m ) @@ -395,6 +398,7 @@ mockPublicRootPeersProvider tracer (MockRoots _ _ publicRootPeers dnsMapScript) -- | 'resolveDomainAddresses' running with a given MockRoots env -- mockResolveDomainAddresses :: ( MonadAsync m + , MonadDelay m , MonadThrow m , MonadTimer m ) diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs index 35d70cc91da..61085e64a02 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet.hs @@ -12,10 +12,10 @@ module Test.Ouroboros.Network.Testnet (tests) where -import Control.Monad.Class.MonadTime (DiffTime, Time (Time), addTime, - diffTime) +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadTime.SI (DiffTime, Time (Time), + addTime, diffTime) import Control.Monad.IOSim -import Control.Monad.IOSim.Types (ThreadId) import Control.Tracer (Tracer (Tracer)) import Data.Bifoldable (bifoldMap) @@ -607,7 +607,7 @@ prop_diffusion_nolivelock defaultBearerInfo diffScript@(DiffusionScript _ l) = iosimTracer tracerDiffusionSimWithTimeName - trace :: [(Time, ThreadId, Maybe ThreadLabel, SimEventType)] + trace :: [(Time, ThreadId (IOSim s), Maybe ThreadLabel, SimEventType)] trace = take 125000 . traceEvents $ runSimTrace sim @@ -620,7 +620,7 @@ prop_diffusion_nolivelock defaultBearerInfo diffScript@(DiffusionScript _ l) = trace where check_governor_nolivelock :: DiffTime - -> [(Time, ThreadId, Maybe ThreadLabel, SimEventType)] + -> [(Time, ThreadId (IOSim s), Maybe ThreadLabel, SimEventType)] -> Property check_governor_nolivelock dt trace = let trace' = (\(t, tid, tl, e) -> (t, (tid, tl, e))) @@ -2670,7 +2670,7 @@ fromJoinedOrKilled :: c -> c -> JoinedOrKilled -> c fromJoinedOrKilled j _ Joined = j fromJoinedOrKilled _ k Killed = k -getTime :: (Time, ThreadId, Maybe ThreadLabel, SimEventType) -> Time +getTime :: (Time, ThreadId (IOSim s), Maybe ThreadLabel, SimEventType) -> Time getTime (t, _, _, _) = t classifySimulatedTime :: Time -> Property -> Property @@ -2794,8 +2794,8 @@ toBearerInfo abi = -- index. -- takeUntilEndofTurn :: Int - -> [(Time, ThreadId, Maybe ThreadLabel, SimEventType)] - -> [(Time, ThreadId, Maybe ThreadLabel, SimEventType)] + -> [(Time, ThreadId (IOSim s), Maybe ThreadLabel, SimEventType)] + -> [(Time, ThreadId (IOSim s), Maybe ThreadLabel, SimEventType)] takeUntilEndofTurn n as = case splitAt n as of ([], _) -> [] diff --git a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs index dfe2f6466be..0d9686e2c2e 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/Testnet/Simulation/Node.hs @@ -30,6 +30,7 @@ module Test.Ouroboros.Network.Testnet.Simulation.Node , module PeerSelection ) where +import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad (forM, replicateM, (>=>)) import Control.Monad.Class.MonadAsync @@ -37,8 +38,8 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.Fix import Control.Tracer (Tracer (..), contramap, nullTracer, traceWith) @@ -635,7 +636,9 @@ iosimTracer = Tracer traceM -- | Run an arbitrary topology diffusionSimulation - :: forall m. ( MonadAsync m + :: forall m. ( Alternative (STM m) + , MonadAsync m + , MonadDelay m , MonadFix m , MonadFork m , MonadSay m diff --git a/ouroboros-network/test/Test/Ouroboros/Network/TxSubmission.hs b/ouroboros-network/test/Test/Ouroboros/Network/TxSubmission.hs index de56d11be24..39e12f67785 100644 --- a/ouroboros-network/test/Test/Ouroboros/Network/TxSubmission.hs +++ b/ouroboros-network/test/Test/Ouroboros/Network/TxSubmission.hs @@ -19,8 +19,8 @@ import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadSay import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Monad.IOSim hiding (SimResult) import Control.Tracer (Tracer (..), contramap, nullTracer, showTracing, traceWith) @@ -190,6 +190,7 @@ txSubmissionCodec2 = txSubmissionSimulation :: forall m txid. ( MonadAsync m + , MonadDelay m , MonadFork m , MonadMask m , MonadSay m @@ -360,6 +361,7 @@ instance (Show a) => Show (WithThreadAndTime a) where verboseTracer :: forall a m. ( MonadAsync m + , MonadDelay m , MonadSay m , MonadMonotonicTime m , Show a @@ -369,6 +371,7 @@ verboseTracer = threadAndTimeTracer $ showTracing $ Tracer say threadAndTimeTracer :: forall a m. ( MonadAsync m + , MonadDelay m , MonadMonotonicTime m ) => Tracer m (WithThreadAndTime a) -> Tracer m a diff --git a/ouroboros-network/test/Test/PeerState.hs b/ouroboros-network/test/Test/PeerState.hs index c30adb196fa..a23232c1375 100644 --- a/ouroboros-network/test/Test/PeerState.hs +++ b/ouroboros-network/test/Test/PeerState.hs @@ -24,7 +24,7 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadTime +import Control.Monad.Class.MonadTime.SI import Control.Tracer import Data.Semigroup.Action diff --git a/ouroboros-network/test/Test/Pipe.hs b/ouroboros-network/test/Test/Pipe.hs index 72400ea37b0..f72ee082a3f 100644 --- a/ouroboros-network/test/Test/Pipe.hs +++ b/ouroboros-network/test/Test/Pipe.hs @@ -15,7 +15,7 @@ import Control.Exception import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTimer.SI import qualified Data.ByteString.Lazy as BL import Data.Void (Void) import Test.ChainGenerators (TestBlockChainAndUpdates (..)) diff --git a/ouroboros-network/test/Test/Socket.hs b/ouroboros-network/test/Test/Socket.hs index 8319db33db8..aa89fb6ebfa 100644 --- a/ouroboros-network/test/Test/Socket.hs +++ b/ouroboros-network/test/Test/Socket.hs @@ -21,8 +21,8 @@ import Control.Concurrent.Class.MonadSTM.Strict import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadFork hiding (ThreadId) -import Control.Monad.Class.MonadTime -import Control.Monad.Class.MonadTimer +import Control.Monad.Class.MonadTime.SI +import Control.Monad.Class.MonadTimer.SI import Control.Tracer import Ouroboros.Network.Mux