diff --git a/cabal.project b/cabal.project index d7986e2912..5b34ec9e98 100644 --- a/cabal.project +++ b/cabal.project @@ -20,6 +20,7 @@ index-state: packages: nf-vars + resource-registry ouroboros-consensus ouroboros-consensus-cardano ouroboros-consensus-protocol diff --git a/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm.hs b/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm.hs index 8708d6210e..69583c869c 100644 --- a/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm.hs +++ b/nf-vars/src/Control/Concurrent/Class/MonadSTM/NormalForm.hs @@ -1,13 +1,13 @@ module Control.Concurrent.Class.MonadSTM.NormalForm ( - module Control.Concurrent.Class.MonadSTM.NormalForm.SVar - , module Control.Concurrent.Class.MonadSTM.NormalForm.TVar - , module Control.Concurrent.Class.MonadSTM.Strict.TBQueue - , module Control.Concurrent.Class.MonadSTM.Strict.TQueue - , module Control.Concurrent.Class.MonadSTM.Strict.TMVar -) where + module Control.Concurrent.Class.MonadSTM.NormalForm.SVar + , module Control.Concurrent.Class.MonadSTM.NormalForm.TVar + , module Control.Concurrent.Class.MonadSTM.Strict.TBQueue + , module Control.Concurrent.Class.MonadSTM.Strict.TMVar + , module Control.Concurrent.Class.MonadSTM.Strict.TQueue + ) where -import Control.Concurrent.Class.MonadSTM.NormalForm.SVar -import Control.Concurrent.Class.MonadSTM.NormalForm.TVar -import Control.Concurrent.Class.MonadSTM.Strict.TBQueue -import Control.Concurrent.Class.MonadSTM.Strict.TQueue -import Control.Concurrent.Class.MonadSTM.Strict.TMVar +import Control.Concurrent.Class.MonadSTM.NormalForm.SVar +import Control.Concurrent.Class.MonadSTM.NormalForm.TVar +import Control.Concurrent.Class.MonadSTM.Strict.TBQueue +import Control.Concurrent.Class.MonadSTM.Strict.TMVar +import Control.Concurrent.Class.MonadSTM.Strict.TQueue diff --git a/nf-vars/test/Main.hs b/nf-vars/test/Main.hs index dd08e78b03..4110b340f2 100644 --- a/nf-vars/test/Main.hs +++ b/nf-vars/test/Main.hs @@ -6,12 +6,12 @@ module Main (main) where +import Control.Concurrent.Class.MonadSTM (MonadSTM) +import Control.Concurrent.Class.MonadSTM.NormalForm (newSVar, + updateSVar) import Control.Monad.IOSim import GHC.Generics import NoThunks.Class -import Control.Concurrent.Class.MonadSTM.NormalForm ( - newSVar, updateSVar) -import Control.Concurrent.Class.MonadSTM (MonadSTM) import Test.Tasty import Test.Tasty.QuickCheck diff --git a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal index f2702465e0..fa42472f4f 100644 --- a/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal +++ b/ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal @@ -554,6 +554,7 @@ library unstable-cardano-tools ouroboros-network-api, ouroboros-network-framework ^>=0.13.2, ouroboros-network-protocols, + resource-registry ^>=0.1, serialise ^>=0.2, singletons, sop-core, diff --git a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs index 3736127610..7e886309a9 100644 --- a/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs +++ b/ouroboros-consensus-cardano/src/ouroboros-consensus-cardano/Ouroboros/Consensus/Cardano/Block.hs @@ -4,7 +4,6 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} module Ouroboros.Consensus.Cardano.Block ( -- * Eras diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs index 1bc5dbe099..35322617e5 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Analysis.hs @@ -35,6 +35,7 @@ import qualified Cardano.Tools.DBAnalyser.HasAnalysis as HasAnalysis import Codec.CBOR.Encoding (Encoding) import Control.Monad (unless, void, when) import Control.Monad.Except (runExcept) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Int (Int64) import Data.List (intercalate) @@ -73,7 +74,6 @@ import Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..), import Ouroboros.Consensus.Storage.Serialisation (SizeInBytes, encodeDisk) import qualified Ouroboros.Consensus.Util.IOLike as IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API (SomeHasFS (..)) import qualified System.IO as IO diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs index 357e02d5df..28a69a72c4 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBAnalyser/Run.hs @@ -12,6 +12,7 @@ import Cardano.Tools.DBAnalyser.HasAnalysis import Cardano.Tools.DBAnalyser.Types import Codec.Serialise (Serialise (decode)) import Control.Monad.Except (runExceptT) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer) import Data.Singletons (Sing, SingI (..)) import qualified Debug.Trace as Debug @@ -32,7 +33,6 @@ import Ouroboros.Consensus.Storage.LedgerDB (DiskSnapshot (..), readSnapshot) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import System.IO diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs index 3d28fc12c6..f015a6bf3e 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBImmutaliser/Run.hs @@ -19,6 +19,7 @@ module Cardano.Tools.DBImmutaliser.Run ( import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo) +import Control.ResourceRegistry import Control.Tracer (Tracer, stdoutTracer, traceWith) import Data.Foldable (for_) import Data.Functor.Contravariant ((>$<)) @@ -44,7 +45,6 @@ import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (MaxSlotNo) import System.FS.API (SomeHasFS (..)) import System.FS.API.Types (MountPoint (..)) diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs index 9aa866c0d0..c1fff3bd7d 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBSynthesizer/Run.hs @@ -15,6 +15,7 @@ import Cardano.Tools.DBSynthesizer.Types import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Except.Extra (firstExceptT, handleIOExceptT, hoistEither, runExceptT) +import Control.ResourceRegistry import Control.Tracer (nullTracer) import Data.Aeson as Aeson (FromJSON, Result (..), Value, eitherDecodeFileStrict', eitherDecodeStrict', fromJSON) @@ -34,7 +35,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB (getTipPoint) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB (withDB) import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.IOLike (atomically) -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block import Ouroboros.Network.Point (WithOrigin (..)) import System.Directory diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs index 1cc583e14b..ad2f7ea410 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/DBTruncater/Run.hs @@ -11,6 +11,7 @@ import Cardano.Slotting.Slot (WithOrigin (..)) import Cardano.Tools.DBAnalyser.HasAnalysis import Cardano.Tools.DBTruncater.Types import Control.Monad +import Control.ResourceRegistry (runWithTempRegistry, withRegistry) import Control.Tracer import Data.Functor.Identity import Data.Traversable (for) @@ -24,8 +25,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDB, Iterator, import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.ImmutableDB.Impl import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (runWithTempRegistry, - withRegistry) import Prelude hiding (truncate) import System.IO diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs index bca7081789..05f3c01208 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/Diffusion.hs @@ -6,6 +6,7 @@ module Cardano.Tools.ImmDBServer.Diffusion (run) where import Cardano.Tools.ImmDBServer.MiniProtocols (immDBServer) +import Control.ResourceRegistry import Control.Tracer import qualified Data.ByteString.Lazy as BL import Data.Functor.Contravariant ((>$<)) @@ -22,7 +23,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB (ImmutableDbArgs (..)) import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.ErrorPolicy (nullErrorPolicies) import Ouroboros.Network.IOManager (withIOManager) import Ouroboros.Network.Mux diff --git a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/MiniProtocols.hs b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/MiniProtocols.hs index 33cbed13ad..0a47224c32 100644 --- a/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/MiniProtocols.hs +++ b/ouroboros-consensus-cardano/src/unstable-cardano-tools/Cardano/Tools/ImmDBServer/MiniProtocols.hs @@ -16,6 +16,7 @@ module Cardano.Tools.ImmDBServer.MiniProtocols (immDBServer) where import qualified Codec.CBOR.Decoding as CBOR import qualified Codec.CBOR.Encoding as CBOR import Control.Monad (forever) +import Control.ResourceRegistry import Control.Tracer import Data.Bifunctor (bimap) import qualified Data.ByteString.Lazy as BL @@ -40,7 +41,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDB) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (ChainUpdate (..), Tip (..)) import Ouroboros.Network.Driver (runPeer) import Ouroboros.Network.KeepAlive (keepAliveServer) diff --git a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal index 7a6f24fc37..1c8af4d8d7 100644 --- a/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal +++ b/ouroboros-consensus-diffusion/ouroboros-consensus-diffusion.cabal @@ -86,15 +86,16 @@ library filepath, fs-api ^>=0.2.0.1, hashable, - nf-vars, io-classes ^>=1.5, mtl, + nf-vars ^>=0.1, ouroboros-consensus ^>=0.19, ouroboros-network ^>=0.16, ouroboros-network-api ^>=0.7.3, ouroboros-network-framework ^>=0.13.2, ouroboros-network-protocols ^>=0.9, random, + resource-registry ^>=0.1, safe-wild-cards ^>=1.0, serialise ^>=0.2, si-timers ^>=1.5, @@ -148,6 +149,7 @@ library unstable-diffusion-testlib ouroboros-network-protocols, quiet ^>=0.2, random, + resource-registry, si-timers, sop-core ^>=0.5, sop-extras ^>=0.2, @@ -297,6 +299,7 @@ test-suite consensus-test quickcheck-state-machine:no-vendored-treediff, quiet, random, + resource-registry, serialise, si-timers, sop-extras, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs index 231d589a10..a9311a984b 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToClient.hs @@ -30,6 +30,7 @@ import Codec.CBOR.Decoding (Decoder) import Codec.CBOR.Encoding (Encoding) import Codec.CBOR.Read (DeserialiseFailure) import Codec.Serialise (Serialise) +import Control.ResourceRegistry import Control.Tracer import Data.ByteString.Lazy (ByteString) import Data.Void (Void) @@ -52,7 +53,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (Serialised, decodePoint, decodeTip, encodePoint, encodeTip) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs index 4dbf6a9361..b377089c21 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Network/NodeToNode.hs @@ -44,6 +44,7 @@ import Codec.CBOR.Read (DeserialiseFailure) import Control.Concurrent.Class.MonadSTM.Strict.TVar as TVar.Unchecked import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.ResourceRegistry import Control.Tracer import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as BSL @@ -71,7 +72,6 @@ import Ouroboros.Consensus.Storage.Serialisation (SerialisedHeader) import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (Serialised (..), decodePoint, decodeTip, encodePoint, encodeTip) import Ouroboros.Network.BlockFetch diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs index b2e0609579..66cf8fdb4f 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node.hs @@ -63,6 +63,7 @@ import Control.DeepSeq (NFData) import Control.Monad (when) import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.ResourceRegistry import Control.Tracer (Tracer, contramap, traceWith) import Data.ByteString.Lazy (ByteString) import Data.Functor.Contravariant (Predicate (..)) @@ -107,7 +108,6 @@ import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) import Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..)) import qualified Ouroboros.Network.Diffusion as Diffusion diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs index be961f3e56..4d59c2c423 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/ErrorPolicy.hs @@ -3,6 +3,8 @@ module Ouroboros.Consensus.Node.ErrorPolicy (consensusErrorPolicy) where import Control.Monad.Class.MonadAsync (ExceptionInLinkedThread (..)) +import Control.ResourceRegistry (RegistryClosedException, + ResourceRegistryThreadException, TempRegistryException) import Data.Proxy (Proxy) import Data.Time.Clock (DiffTime) import Data.Typeable (Typeable) @@ -20,9 +22,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDBError) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB -import Ouroboros.Consensus.Util.ResourceRegistry - (RegistryClosedException, ResourceRegistryThreadException, - TempRegistryException) import Ouroboros.Network.ErrorPolicy import System.FS.API.Types (FsError) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs index 20ad35c1f3..46dd0adfa0 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/GSM.hs @@ -27,6 +27,8 @@ module Ouroboros.Consensus.Node.GSM ( ) where import qualified Cardano.Slotting.Slot as Slot +import Control.Concurrent.Class.MonadSTM.NormalForm (StrictTVar) +import qualified Control.Concurrent.Class.MonadSTM.NormalForm as StrictSTM import qualified Control.Concurrent.Class.MonadSTM.TVar as LazySTM import Control.Monad (forever, join, unless) import Control.Monad.Class.MonadSTM (MonadSTM, STM, atomically, check, @@ -44,8 +46,6 @@ import qualified Ouroboros.Consensus.HardFork.History as HardFork import qualified Ouroboros.Consensus.HardFork.History.Qry as Qry import qualified Ouroboros.Consensus.Ledger.Basics as L import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB) -import Control.Concurrent.Class.MonadSTM.NormalForm (StrictTVar) -import qualified Control.Concurrent.Class.MonadSTM.NormalForm as StrictSTM import Ouroboros.Network.PeerSelection.LedgerPeers.Type (LedgerStateJudgement (..)) import System.FS.API (HasFS, createDirectoryIfMissing, doesFileExist, diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs index 21a296cb2a..767833fb35 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/Node/RethrowPolicy.hs @@ -3,6 +3,8 @@ module Ouroboros.Consensus.Node.RethrowPolicy (consensusRethrowPolicy) where import Control.Monad.Class.MonadAsync (ExceptionInLinkedThread (..)) +import Control.ResourceRegistry (RegistryClosedException, + ResourceRegistryThreadException, TempRegistryException) import Data.Proxy (Proxy) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block (StandardHash) @@ -19,9 +21,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.API (ImmutableDBError) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB import Ouroboros.Consensus.Storage.VolatileDB.API (VolatileDBError) import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB -import Ouroboros.Consensus.Util.ResourceRegistry - (RegistryClosedException, ResourceRegistryThreadException, - TempRegistryException) import Ouroboros.Network.RethrowPolicy import System.FS.API.Types (FsError) diff --git a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs index 94d42910a3..6ae7495ddb 100644 --- a/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs +++ b/ouroboros-consensus-diffusion/src/ouroboros-consensus-diffusion/Ouroboros/Consensus/NodeKernel.hs @@ -34,6 +34,7 @@ import Control.DeepSeq (force) import Control.Monad import qualified Control.Monad.Class.MonadTimer.SI as SI import Control.Monad.Except +import Control.ResourceRegistry import Control.Tracer import Data.Bifunctor (second) import Data.Data (Typeable) @@ -81,7 +82,6 @@ import Ouroboros.Consensus.Util.AnchoredFragment import Ouroboros.Consensus.Util.EarlyExit import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM import Ouroboros.Network.AnchoredFragment (AnchoredFragment, AnchoredSeq (..)) diff --git a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs index 90dffaa070..0fbdaafca5 100644 --- a/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs +++ b/ouroboros-consensus-diffusion/src/unstable-diffusion-testlib/Test/ThreadNet/Network.hs @@ -43,6 +43,7 @@ import Control.Monad import Control.Monad.Class.MonadTime.SI (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) import qualified Control.Monad.Except as Exc +import Control.ResourceRegistry import Control.Tracer import qualified Data.ByteString.Lazy as Lazy import Data.Either (isRight) @@ -96,7 +97,6 @@ import Ouroboros.Consensus.Util.Enclose (pattern FallingEdge) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.Orphans () import Ouroboros.Consensus.Util.RedundantConstraints -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM import Ouroboros.Consensus.Util.Time import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs index ae89d2ff62..a6f3e61169 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Setup/GenChains.hs @@ -28,18 +28,17 @@ import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..)) import Ouroboros.Network.Protocol.Limits (shortWait) import qualified Test.Consensus.BlockTree as BT -import Test.Consensus.PointSchedule import qualified Test.Consensus.ChainGenerator.Adversarial as A -import Test.Consensus.ChainGenerator.Adversarial - (genPrefixBlockCount) -import Test.Consensus.ChainGenerator.Counting - (Count (Count), getVector) +import Test.Consensus.ChainGenerator.Adversarial (genPrefixBlockCount) +import Test.Consensus.ChainGenerator.Counting (Count (Count), + getVector) import qualified Test.Consensus.ChainGenerator.Honest as H import Test.Consensus.ChainGenerator.Honest (ChainSchema (ChainSchema), HonestRecipe (..)) import Test.Consensus.ChainGenerator.Params import qualified Test.Consensus.ChainGenerator.Slot as S import Test.Consensus.ChainGenerator.Slot (S) +import Test.Consensus.PointSchedule import qualified Test.QuickCheck as QC import Test.QuickCheck.Extras (unsafeMapSuchThatJust) import Test.QuickCheck.Random (QCGen) diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs index a11e9fc4e7..f6e2f0dac8 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/Genesis/Tests/Uniform.hs @@ -33,6 +33,7 @@ import Ouroboros.Network.Protocol.ChainSync.Codec (ChainSyncTimeout (..)) import Ouroboros.Network.Protocol.Limits (shortWait) import Test.Consensus.BlockTree (BlockTree (..), btbSuffix) +import Test.Consensus.ChainGenerator.Params (Delta (Delta)) import Test.Consensus.Genesis.Setup import Test.Consensus.Genesis.Setup.Classifiers import Test.Consensus.PeerSimulator.ChainSync (chainSyncNoTimeouts) @@ -46,7 +47,6 @@ import Test.Consensus.PointSchedule.Shrinking (shrinkByRemovingAdversaries, shrinkPeerSchedules) import Test.Consensus.PointSchedule.SinglePeer (SchedulePoint (ScheduleBlockPoint, ScheduleTipPoint)) -import Test.Consensus.ChainGenerator.Params (Delta (Delta)) import qualified Test.QuickCheck as QC import Test.QuickCheck import Test.Tasty diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs index 536a49f2fc..63eae25ba7 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/BlockFetch.hs @@ -21,6 +21,7 @@ import Control.Exception (SomeException) import Control.Monad (void) import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.ResourceRegistry import Control.Tracer (Tracer, nullTracer, traceWith) import Data.Functor.Contravariant ((>$<)) import Data.Map.Strict (Map) @@ -36,7 +37,6 @@ import Ouroboros.Consensus.Util (ShowProxy) import Ouroboros.Consensus.Util.IOLike (DiffTime, Exception (fromException), IOLike, STM, atomically, retry, try) -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.BlockFetch (BlockFetchConfiguration (..), FetchClientRegistry, FetchMode (..), blockFetchLogic, diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs index f83d1c32b5..e16967d212 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/NodeLifecycle.hs @@ -13,6 +13,7 @@ module Test.Consensus.PeerSimulator.NodeLifecycle ( , restoreNode ) where +import Control.ResourceRegistry import Control.Tracer (Tracer (..), traceWith) import Data.Functor (void) import Data.Set (Set) @@ -25,7 +26,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDB import Ouroboros.Consensus.Storage.ChainDB.Impl.Args (cdbsLoE, updateTracer) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import qualified System.FS.Sim.MockFS as MockFS diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs index b7c04a17d3..a7c4f9f8f6 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PeerSimulator/Run.hs @@ -13,6 +13,7 @@ module Test.Consensus.PeerSimulator.Run ( import Control.Monad (foldM, forM) import Control.Monad.Class.MonadTime (MonadTime) import Control.Monad.Class.MonadTimer.SI (MonadTimer) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Foldable (for_) import Data.Functor (void) @@ -34,7 +35,6 @@ import Ouroboros.Consensus.Storage.ChainDB.API import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.BlockFetch (FetchClientRegistry, diff --git a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs index d124341892..de80d58019 100644 --- a/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs +++ b/ouroboros-consensus-diffusion/test/consensus-test/Test/Consensus/PointSchedule.hs @@ -72,6 +72,7 @@ import qualified System.Random.Stateful as Random import System.Random.Stateful (STGenM, StatefulGen, runSTGen_) import Test.Consensus.BlockTree (BlockTree (..), BlockTreeBranch (..), allFragments, prettyBlockTree) +import Test.Consensus.ChainGenerator.Params (Delta (Delta)) import Test.Consensus.PeerSimulator.StateView (StateView) import Test.Consensus.PointSchedule.NodeState (NodeState (..), genesisNodeState) @@ -83,7 +84,6 @@ import Test.Consensus.PointSchedule.SinglePeer peerScheduleFromTipPoints, schedulePointToBlock) import Test.Consensus.PointSchedule.SinglePeer.Indices (uniformRMDiffTime) -import Test.Consensus.ChainGenerator.Params (Delta (Delta)) import Test.QuickCheck (Gen, arbitrary) import Test.QuickCheck.Random (QCGen) import Test.Util.TersePrinting (terseFragment) diff --git a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs index e1e69b3da1..55413ac381 100644 --- a/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs +++ b/ouroboros-consensus/bench/ChainSync-client-bench/Main.hs @@ -6,6 +6,7 @@ module Main (main) where import Bench.Consensus.ChainSyncClient.Driver (mainWith) import Cardano.Crypto.DSIGN.Mock import Control.Monad (void) +import Control.ResourceRegistry import Control.Tracer (contramap, debugTracer, nullTracer) import Data.IORef (newIORef, readIORef, writeIORef) import qualified Data.List.NonEmpty as NE @@ -32,7 +33,6 @@ import Ouroboros.Consensus.NodeId import Ouroboros.Consensus.Protocol.BFT import qualified Ouroboros.Consensus.Storage.ChainDB.API as ChainDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (Fingerprint (..), WithFingerprint (..)) import Ouroboros.Consensus.Util.Time (secondsToNominalDiffTime) diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index 6d8625acb1..4fea7152d4 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -61,7 +61,7 @@ common common-bench -- We use this option to avoid skewed results due to changes in cache-line -- alignment. See -- https://github.com/Bodigrim/tasty-bench#comparison-against-baseline - if impl(ghc >= 8.6) + if impl(ghc >=8.6) ghc-options: -fproc-alignment=64 library @@ -257,7 +257,6 @@ library Ouroboros.Consensus.Util.MonadSTM.RAWLock Ouroboros.Consensus.Util.Orphans Ouroboros.Consensus.Util.RedundantConstraints - Ouroboros.Consensus.Util.ResourceRegistry Ouroboros.Consensus.Util.STM Ouroboros.Consensus.Util.Time Ouroboros.Consensus.Util.Versioned @@ -283,6 +282,7 @@ library io-classes ^>=1.5, measures, mtl, + nf-vars ^>=0.1, nothunks ^>=0.1.5, ouroboros-network-api ^>=0.7.3, ouroboros-network-mock ^>=0.1, @@ -291,6 +291,7 @@ library psqueues ^>=0.2.3, quiet ^>=0.2, reflection, + resource-registry ^>=0.1, semialign >=1.1, serialise ^>=0.2, si-timers ^>=1.5, @@ -298,7 +299,6 @@ library sop-extras ^>=0.2, streaming, strict-sop-core ^>=0.1, - nf-vars, text, these ^>=1.2, time, @@ -392,17 +392,18 @@ library unstable-consensus-testlib io-classes, io-sim, mtl, + nf-vars, nothunks, optparse-applicative, ouroboros-consensus, ouroboros-network-api, ouroboros-network-mock, - nf-vars, pretty-simple, quickcheck-instances, quickcheck-state-machine:no-vendored-treediff ^>=0.9, quiet, random, + resource-registry, serialise, si-timers, sop-core, @@ -515,7 +516,6 @@ test-suite consensus-test Test.Consensus.MiniProtocol.BlockFetch.Client Test.Consensus.MiniProtocol.ChainSync.Client Test.Consensus.MiniProtocol.LocalStateQuery.Server - Test.Consensus.ResourceRegistry Test.Consensus.Util.MonadSTM.RAWLock Test.Consensus.Util.Versioned @@ -532,7 +532,6 @@ test-suite consensus-test contra-tracer, deepseq, fs-api ^>=0.2.0.1, - generics-sop, hashable, io-classes, io-sim, @@ -543,9 +542,9 @@ test-suite consensus-test ouroboros-network-api, ouroboros-network-mock, ouroboros-network-protocols:{ouroboros-network-protocols, testlib}, - quickcheck-state-machine:no-vendored-treediff, quiet, random, + resource-registry, serialise, si-timers, sop-core, @@ -555,7 +554,6 @@ test-suite consensus-test tasty-hunit, tasty-quickcheck, time, - tree-diff, typed-protocols ^>=0.1.1, typed-protocols-examples, unstable-consensus-testlib, @@ -648,6 +646,7 @@ test-suite storage-test ouroboros-network-api, ouroboros-network-mock, quickcheck-state-machine:no-vendored-treediff ^>=0.9, + resource-registry, serialise, tasty, tasty-hunit, @@ -705,6 +704,7 @@ benchmark ChainSync-client-bench ouroboros-consensus, ouroboros-network-api, ouroboros-network-protocols, + resource-registry, time, typed-protocols-examples, unstable-consensus-testlib, @@ -716,7 +716,6 @@ test-suite doctest type: exitcode-stdio-1.0 hs-source-dirs: test default-language: Haskell2010 - ghc-options: -Wno-unused-packages build-depends: base, latex-svg-image, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs index fa8d5cbb31..dfe8f45a05 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/HardFork.hs @@ -8,6 +8,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.HardFork ( ) where import Control.Monad +import Control.ResourceRegistry import Control.Tracer import Data.Time (NominalDiffTime) import Data.Void @@ -19,7 +20,6 @@ import Ouroboros.Consensus.HardFork.Abstract import qualified Ouroboros.Consensus.HardFork.History as HF import Ouroboros.Consensus.Ledger.Abstract import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.Time -- | A backoff delay diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs index 941d32dd05..237f36f672 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/BlockchainTime/WallClock/Simple.hs @@ -10,6 +10,7 @@ module Ouroboros.Consensus.BlockchainTime.WallClock.Simple ( ) where import Control.Monad +import Control.ResourceRegistry import Data.Bifunctor import Data.Fixed (divMod') import Data.Time (NominalDiffTime) @@ -19,7 +20,6 @@ import Ouroboros.Consensus.BlockchainTime.API import Ouroboros.Consensus.BlockchainTime.WallClock.Types import Ouroboros.Consensus.BlockchainTime.WallClock.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.Time -- | Real blockchain time diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs index 73b2d7880f..556ce193fc 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/HardFork/Combinator/Protocol.hs @@ -5,13 +5,13 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NamedFieldPuns #-} {-# OPTIONS_GHC -Wno-orphans #-} diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs index a7eb7601b8..ef9ed28602 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool.hs @@ -44,7 +44,7 @@ module Ouroboros.Consensus.Mempool ( import Ouroboros.Consensus.Mempool.API (ForgeLedgerState (..), Mempool (..), MempoolAddTxResult (..), MempoolSnapshot (..), TicketNo, TxSizeInBytes, addLocalTxs, - addTxs, mempoolTxAddedToMaybe, zeroTicketNo) + addTxs, mempoolTxAddedToMaybe, zeroTicketNo) import Ouroboros.Consensus.Mempool.Capacity (ByteSize (..), MempoolCapacityBytes (..), MempoolCapacityBytesOverride (..), MempoolSize (..), diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs index f2aa648eb8..e558d7b788 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Mempool/Init.hs @@ -8,6 +8,7 @@ module Ouroboros.Consensus.Mempool.Init ( ) where import Control.Monad (void) +import Control.ResourceRegistry import Control.Tracer import Ouroboros.Consensus.Block import Ouroboros.Consensus.HeaderValidation @@ -19,7 +20,6 @@ import Ouroboros.Consensus.Mempool.Impl.Common import Ouroboros.Consensus.Mempool.Query import Ouroboros.Consensus.Mempool.Update import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (Watcher (..), forkLinkedWatcher) {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/Server.hs index f0d8f17e42..7af215bb8b 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/BlockFetch/Server.hs @@ -18,6 +18,7 @@ module Ouroboros.Consensus.MiniProtocol.BlockFetch.Server ( , blockFetchServer' ) where +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (Tracer, traceWith) import Data.Typeable (Typeable) import Ouroboros.Consensus.Block @@ -26,7 +27,6 @@ import Ouroboros.Consensus.Storage.ChainDB (ChainDB, Iterator, getSerialisedBlockWithPoint) import qualified Ouroboros.Consensus.Storage.ChainDB as ChainDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Network.Block (Serialised (..)) import Ouroboros.Network.NodeToNode.Version (NodeToNodeVersion) import Ouroboros.Network.Protocol.BlockFetch.Server diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs index 5d9804f733..9f867c913a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/MiniProtocol/ChainSync/Server.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.MiniProtocol.ChainSync.Server ( , chainSyncServerForFollower ) where +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.ChainDB.API (ChainDB, Follower, @@ -27,7 +28,6 @@ import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.Enclose (Enclosing, Enclosing' (..), pattern FallingEdge) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Network.Block (ChainUpdate (..), Serialised, Tip (..)) import Ouroboros.Network.Protocol.ChainSync.Server diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs index 0e0474135f..5e35a243d4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/API.hs @@ -64,6 +64,7 @@ module Ouroboros.Consensus.Storage.ChainDB.API ( ) where import Control.Monad (void) +import Control.ResourceRegistry import Data.Typeable (Typeable) import Data.Word (Word64) import GHC.Generics (Generic) @@ -82,7 +83,6 @@ import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util ((..:)) import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (WithFingerprint) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs index 143aad7375..b7d4d54674 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl.hs @@ -36,6 +36,8 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl ( import Control.Monad (when) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (WithTempRegistry, allocate, + runInnerWithTempRegistry, runWithTempRegistry) import Control.Tracer import Data.Functor ((<&>)) import Data.Functor.Identity (Identity) @@ -63,8 +65,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util (newFuse, whenJust, withFuse) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (WithTempRegistry, - allocate, runInnerWithTempRegistry, runWithTempRegistry) import Ouroboros.Consensus.Util.STM (Fingerprint (..), WithFingerprint (..)) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs index 55ef2bd425..febe7e7d6e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Args.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Args ( , updateTracer ) where +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (Tracer, nullTracer) import Data.Functor.Contravariant ((>$<)) import Data.Kind @@ -37,7 +38,6 @@ import Ouroboros.Consensus.Storage.LedgerDB.DiskPolicy import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import System.FS.API {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs index 9a6fdcb374..eaad3dc22f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Background.hs @@ -39,6 +39,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Background ( import Control.Exception (assert) import Control.Monad (forM_, forever, void) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry import Control.Tracer import Data.Foldable (toList) import qualified Data.Map.Strict as Map @@ -71,7 +72,6 @@ import Ouroboros.Consensus.Util import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.Enclose (Enclosing' (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredSeq (..)) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs index aa428072f6..7b2edc0188 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Follower.hs @@ -17,6 +17,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Follower ( import Codec.CBOR.Write (toLazyByteString) import Control.Exception (assert) import Control.Monad (join) +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (contramap, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.Functor ((<&>)) @@ -35,7 +36,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import Ouroboros.Consensus.Util.STM (blockUntilJust) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs index a7eeab2c53..68b34633ab 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Iterator.hs @@ -21,6 +21,7 @@ import Control.Monad (unless, when) import Control.Monad.Except (ExceptT (..), catchError, runExceptT, throwError, withExceptT) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer import Data.Functor (($>)) import Data.List.NonEmpty (NonEmpty) @@ -44,7 +45,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) -- | Stream blocks -- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs index 477db81dfc..1eecf30af0 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ChainDB/Impl/Types.hs @@ -62,6 +62,7 @@ module Ouroboros.Consensus.Storage.ChainDB.Impl.Types ( , TraceValidationEvent (..) ) where +import Control.ResourceRegistry import Control.Tracer import Data.Foldable (traverse_) import Data.Map.Strict (Map) @@ -102,7 +103,6 @@ import Ouroboros.Consensus.Util (Fuse) import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.Enclose (Enclosing, Enclosing' (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (WithFingerprint) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import Ouroboros.Network.Block (MaxSlotNo) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs index 168747a12a..e4aa6592f1 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/API.hs @@ -54,6 +54,7 @@ module Ouroboros.Consensus.Storage.ImmutableDB.API ( import qualified Codec.CBOR.Read as CBOR import Control.Monad.Except (ExceptT (..), runExceptT, throwError) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (ResourceRegistry) import qualified Data.ByteString.Lazy as Lazy import Data.Either (isRight) import Data.Function (on) @@ -65,7 +66,6 @@ import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import qualified Ouroboros.Network.AnchoredFragment as AF import System.FS.API.Types (FsError, FsPath) import System.FS.CRC (CRC) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs index 44941178cb..c32e15ad8a 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl.hs @@ -105,6 +105,7 @@ import qualified Codec.CBOR.Write as CBOR import Control.Monad (replicateM_, unless, when) import Control.Monad.Except (runExceptT) import Control.Monad.State.Strict (get, modify, put) +import Control.ResourceRegistry import Control.Tracer (Tracer, nullTracer, traceWith) import qualified Data.ByteString.Lazy as Lazy import GHC.Stack (HasCallStack) @@ -129,7 +130,6 @@ import Ouroboros.Consensus.Util (SomePair (..)) import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.EarlyExit import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API.Lazy hiding (allowExisting) import System.FS.CRC diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs index ecabfca239..4d68416ff5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index.hs @@ -13,6 +13,7 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index ( , cachedIndex ) where +import Control.ResourceRegistry import Control.Tracer (Tracer) import Data.Functor.Identity (Identity (..)) import Data.Typeable (Typeable) @@ -32,7 +33,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index.Secondary as import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types (TraceCacheEvent, WithBlockSize (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API (HasFS) import System.FS.API.Types (AllowExisting, Handle) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs index a65ae5e61b..9c27e6c4b2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Index/Cache.hs @@ -38,6 +38,7 @@ import Cardano.Prelude (forceElemsToWHNF) import Control.Exception (assert) import Control.Monad (forM, forM_, forever, unless, void, when) import Control.Monad.Except (throwError) +import Control.ResourceRegistry import Control.Tracer (Tracer, traceWith) import Data.Foldable (toList) import Data.Functor ((<&>)) @@ -73,7 +74,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util import Ouroboros.Consensus.Util (takeUntil, whenJust) import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API (HasFS (..), withFile) import System.FS.API.Types (AllowExisting (..), Handle, OpenMode (ReadMode)) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs index dedd389bb5..522c622092 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Iterator.hs @@ -1,12 +1,14 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Ouroboros.Consensus.Storage.ImmutableDB.Impl.Iterator ( CurrentChunkInfo (..) @@ -20,6 +22,8 @@ import qualified Codec.CBOR.Read as CBOR import Control.Monad (unless, void, when) import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (ResourceKey, ResourceRegistry, + allocate, release, unsafeRelease) import qualified Data.ByteString.Lazy as Lazy import qualified Data.ByteString.Short as Short import Data.Foldable (find) @@ -45,8 +49,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util import Ouroboros.Consensus.Storage.Serialisation import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceKey, - ResourceRegistry, allocate, release, unsafeRelease) import Ouroboros.Network.SizeInBytes import System.FS.API.Lazy import System.FS.CRC @@ -75,7 +77,9 @@ data IteratorHandle m blk h = IteratorHandle { data IteratorStateOrExhausted m hash h = IteratorStateOpen !(IteratorState m hash h) | IteratorStateExhausted - deriving (Generic, NoThunks) + deriving (Generic) + +deriving instance (StandardHash blk, forall a. NoThunks a => NoThunks (StrictTVar m a)) => NoThunks (IteratorStateOrExhausted m blk h) data IteratorState m blk h = IteratorState { itsChunk :: !ChunkNo @@ -98,7 +102,7 @@ data IteratorState m blk h = IteratorState { } deriving (Generic) -deriving instance (StandardHash blk, IOLike m) => NoThunks (IteratorState m blk h) +deriving instance (StandardHash blk, forall a. NoThunks a => NoThunks (StrictTVar m a)) => NoThunks (IteratorState m blk h) -- | Auxiliary data type that combines the 'currentChunk' and -- 'currentChunkOffset' fields from 'OpenState'. This is used to avoid passing diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/State.hs index 3c5a4b36f3..7b8e8689d2 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/State.hs @@ -27,6 +27,7 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Impl.State ( import Control.Monad (unless) import Control.Monad.State.Strict (StateT, lift) +import Control.ResourceRegistry import Control.Tracer (Tracer) import Data.Typeable (Typeable) import GHC.Generics (Generic) @@ -44,7 +45,6 @@ import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Types import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util import Ouroboros.Consensus.Util (SomePair (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import System.FS.API {------------------------------------------------------------------------------ diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Validation.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Validation.hs index a19d76507d..1eaf29cbd5 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Validation.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Impl/Validation.hs @@ -20,6 +20,7 @@ import Control.Exception (assert) import Control.Monad (forM_, unless, when) import Control.Monad.Except (ExceptT, runExceptT, throwError) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry import Control.Tracer (Tracer, contramap, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.Functor (($>)) @@ -47,7 +48,6 @@ import Ouroboros.Consensus.Storage.Serialisation (DecodeDisk (..), HasBinaryBlockInfo (..)) import Ouroboros.Consensus.Util (lastMaybe, whenJust) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Streaming (Of (..)) import qualified Streaming.Prelude as S import System.FS.API diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs index f290033acb..8aa3ebaa87 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/ImmutableDB/Stream.hs @@ -12,13 +12,13 @@ module Ouroboros.Consensus.Storage.ImmutableDB.Stream ( ) where import Control.Monad.Except +import Control.ResourceRegistry import GHC.Stack import Ouroboros.Consensus.Block import Ouroboros.Consensus.Storage.Common import Ouroboros.Consensus.Storage.ImmutableDB hiding (streamAll) import qualified Ouroboros.Consensus.Storage.ImmutableDB.API as ImmutableDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry {------------------------------------------------------------------------------- Abstraction over the streaming API provided by the Chain DB diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs index c67de33861..c21a33fddf 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/LedgerDB.hs @@ -182,5 +182,5 @@ import Ouroboros.Consensus.Storage.LedgerDB.Update ThrowsLedgerError (..), UpdateLedgerDbTraceEvent (..), defaultResolveBlocks, defaultResolveWithErrors, defaultThrowLedgerErrors, ledgerDbBimap, ledgerDbPrune, - ledgerDbPush, ledgerDbPushMany', - ledgerDbSwitch, ledgerDbSwitch', ledgerDbWithAnchor) + ledgerDbPush, ledgerDbPushMany', ledgerDbSwitch, + ledgerDbSwitch', ledgerDbWithAnchor) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs index 28958fb835..d2b42a3a1f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl.hs @@ -119,6 +119,7 @@ import qualified Codec.CBOR.Write as CBOR import Control.Monad (unless, when) import Control.Monad.State.Strict (get, gets, lift, modify, put, state) +import Control.ResourceRegistry import Control.Tracer (Tracer, nullTracer, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.List (foldl') @@ -142,7 +143,6 @@ import Ouroboros.Consensus.Storage.VolatileDB.Impl.Util import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAWLock -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (MaxSlotNo (..)) import System.FS.API.Lazy diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs index 4dba157974..26fc3aade4 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Storage/VolatileDB/Impl/State.hs @@ -32,6 +32,8 @@ module Ouroboros.Consensus.Storage.VolatileDB.Impl.State ( import Control.Monad import Control.Monad.State.Strict hiding (withState) +import Control.ResourceRegistry (WithTempRegistry, allocateTemp, + modifyWithTempRegistry) import Control.Tracer (Tracer, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.List (foldl') @@ -55,8 +57,6 @@ import Ouroboros.Consensus.Util (whenJust, (.:)) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.MonadSTM.RAWLock (RAWLock) import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAWLock -import Ouroboros.Consensus.Util.ResourceRegistry (WithTempRegistry, - allocateTemp, modifyWithTempRegistry) import Ouroboros.Network.Block (MaxSlotNo (..)) import System.FS.API diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs index ac78eb9475..45eaf597fe 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util.hs @@ -66,8 +66,7 @@ module Ouroboros.Consensus.Util ( , withFuse ) where -import Cardano.Crypto.Hash (Hash, HashAlgorithm, - hashFromBytesShort) +import Cardano.Crypto.Hash (Hash, HashAlgorithm, hashFromBytesShort) import Control.Monad (unless) import Control.Monad.Class.MonadThrow import Control.Monad.Trans.Class diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs index c6d11c0c84..54f101a91e 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/EarlyExit.hs @@ -21,6 +21,7 @@ module Ouroboros.Consensus.Util.EarlyExit ( import Control.Applicative import Control.Concurrent.Class.MonadMVar +import Control.Concurrent.Class.MonadMVar.NormalForm (StrictMVar) import Control.Monad import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadEventlog @@ -40,7 +41,6 @@ import NoThunks.Class (NoThunks (..)) import Ouroboros.Consensus.Util ((.:)) import Ouroboros.Consensus.Util.IOLike (IOLike (..), PrimMonad (..), StrictSVar, StrictTVar, castStrictSVar, castStrictTVar) -import Control.Concurrent.Class.MonadMVar.NormalForm (StrictMVar) {------------------------------------------------------------------------------- Basic definitions diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs index dbaaad3b28..7eb1e13695 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/IOLike.hs @@ -13,8 +13,8 @@ module Ouroboros.Consensus.Util.IOLike ( , MonadThrow (..) , SomeException -- *** Variables with NoThunks invariants - , module Control.Concurrent.Class.MonadSTM.NormalForm , module Control.Concurrent.Class.MonadMVar.NormalForm + , module Control.Concurrent.Class.MonadSTM.NormalForm -- *** MonadFork, TODO: Should we hide this in favour of MonadAsync? , MonadFork (..) , MonadThread (..) @@ -27,9 +27,9 @@ module Ouroboros.Consensus.Util.IOLike ( , MonadST (..) , PrimMonad (..) -- *** MonadSTM - , MonadSTM (..) , MonadInspectSTM (..) , MonadLabelledSTM + , MonadSTM (..) , throwSTM -- *** MonadTime , DiffTime @@ -51,6 +51,8 @@ import Cardano.Crypto.KES (KESAlgorithm, SignKeyKES) import qualified Cardano.Crypto.KES as KES import Control.Applicative (Alternative) import Control.Concurrent.Class.MonadMVar +import Control.Concurrent.Class.MonadMVar.NormalForm +import Control.Concurrent.Class.MonadSTM.NormalForm import Control.Monad.Class.MonadAsync import Control.Monad.Class.MonadEventlog import Control.Monad.Class.MonadFork @@ -61,8 +63,6 @@ import Control.Monad.Class.MonadTime.SI import Control.Monad.Class.MonadTimer.SI import Control.Monad.Primitive import NoThunks.Class (NoThunks (..)) -import Control.Concurrent.Class.MonadSTM.NormalForm -import Control.Concurrent.Class.MonadMVar.NormalForm import Ouroboros.Consensus.Util.Orphans () {------------------------------------------------------------------------------- diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs index b7d9e04fff..081434ed0f 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs +++ b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/STM.hs @@ -19,12 +19,12 @@ module Ouroboros.Consensus.Util.STM ( , blockUntilJust ) where +import Control.ResourceRegistry import Data.Void import Data.Word (Word64) import GHC.Generics (Generic) import GHC.Stack import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry {------------------------------------------------------------------------------- Misc diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Adversarial.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Adversarial.hs index 2087bca1d5..c7b61ac1fd 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Adversarial.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Adversarial.hs @@ -39,8 +39,8 @@ import qualified Test.Consensus.ChainGenerator.BitVector as BV import qualified Test.Consensus.ChainGenerator.Counting as C import Test.Consensus.ChainGenerator.Honest (ChainSchema (ChainSchema), HonestRecipe (HonestRecipe)) -import Test.Consensus.ChainGenerator.Params (Asc, - Delta (Delta), Kcp (Kcp), Scg (Scg)) +import Test.Consensus.ChainGenerator.Params (Asc, Delta (Delta), + Kcp (Kcp), Scg (Scg)) import qualified Test.Consensus.ChainGenerator.RaceIterator as RI import qualified Test.Consensus.ChainGenerator.Slot as S import Test.Consensus.ChainGenerator.Slot diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Honest.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Honest.hs index 6cef10189e..aa02ec3a3d 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Honest.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/Honest.hs @@ -39,11 +39,10 @@ import Prelude hiding (words) import qualified System.Random.Stateful as R import qualified Test.Consensus.ChainGenerator.BitVector as BV import qualified Test.Consensus.ChainGenerator.Counting as C -import Test.Consensus.ChainGenerator.Params (Asc, - Delta (Delta), Kcp (Kcp), Len (Len), Scg (Scg), genKSD) +import Test.Consensus.ChainGenerator.Params (Asc, Delta (Delta), + Kcp (Kcp), Len (Len), Scg (Scg), genKSD) import qualified Test.Consensus.ChainGenerator.Slot as S -import Test.Consensus.ChainGenerator.Slot - (E (ActiveSlotE, SlotE), S) +import Test.Consensus.ChainGenerator.Slot (E (ActiveSlotE, SlotE), S) import qualified Test.Consensus.ChainGenerator.Some as Some import qualified Test.QuickCheck as QC import Test.QuickCheck.Extras (sized1) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/RaceIterator.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/RaceIterator.hs index 836cc48994..8b1c35572e 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/RaceIterator.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Consensus/ChainGenerator/RaceIterator.hs @@ -34,8 +34,7 @@ import Prelude hiding (init) import qualified Test.Consensus.ChainGenerator.BitVector as BV import qualified Test.Consensus.ChainGenerator.Counting as C import Test.Consensus.ChainGenerator.Params (Kcp (Kcp)) -import Test.Consensus.ChainGenerator.Slot - (E (ActiveSlotE, SlotE), S) +import Test.Consensus.ChainGenerator.Slot (E (ActiveSlotE, SlotE), S) ----- diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs index 3bb24cf4f0..fff18ec066 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/ChainDB.hs @@ -12,6 +12,7 @@ module Test.Util.ChainDB ( ) where +import Control.ResourceRegistry (ResourceRegistry) import Control.Tracer (nullTracer) import Ouroboros.Consensus.Block.Abstract import Ouroboros.Consensus.Config @@ -33,7 +34,6 @@ import Ouroboros.Consensus.Storage.VolatileDB import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Args import Ouroboros.Consensus.Util.IOLike hiding (invariant) -import Ouroboros.Consensus.Util.ResourceRegistry (ResourceRegistry) import System.FS.API (SomeHasFS (..)) import qualified System.FS.Sim.MockFS as Mock import System.FS.Sim.MockFS diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs index c9c858a786..734f76316c 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/HardFork/OracularClock.hs @@ -14,6 +14,7 @@ module Test.Util.HardFork.OracularClock ( ) where import Control.Monad (void, when) +import Control.ResourceRegistry import Data.Foldable (toList) import Data.Function (fix) import Data.Time @@ -21,7 +22,6 @@ import GHC.Stack import Ouroboros.Consensus.Block import qualified Ouroboros.Consensus.BlockchainTime as BTime import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.Time (nominalDelay) import Test.Util.HardFork.Future (Future, futureSlotLengths, futureSlotToTime, futureTimeToSlot) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs index 0dc4909280..90f19311d7 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/LogicalClock.hs @@ -23,13 +23,13 @@ module Test.Util.LogicalClock ( ) where import Control.Monad +import Control.ResourceRegistry import Control.Tracer (Tracer, contramapM) import Data.Time (NominalDiffTime) import Data.Word import GHC.Stack import qualified Ouroboros.Consensus.BlockchainTime as BTime import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM import Ouroboros.Consensus.Util.Time import System.Random (Random) diff --git a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs index 486bfb4eaf..a832b2b671 100644 --- a/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs +++ b/ouroboros-consensus/src/unstable-consensus-testlib/Test/Util/Orphans/NoThunks.hs @@ -8,14 +8,14 @@ module Test.Util.Orphans.NoThunks () where import Control.Concurrent.Class.MonadMVar +import Control.Concurrent.Class.MonadMVar.NormalForm +import Control.Concurrent.Class.MonadSTM +import Control.Concurrent.Class.MonadSTM.NormalForm import Control.Monad.IOSim import Control.Monad.ST.Lazy import Control.Monad.ST.Unsafe (unsafeSTToIO) import Data.Proxy import NoThunks.Class (NoThunks (..)) -import Control.Concurrent.Class.MonadSTM.NormalForm -import Control.Concurrent.Class.MonadMVar.NormalForm -import Control.Concurrent.Class.MonadSTM import System.FS.API.Types import System.FS.Sim.FsTree import System.FS.Sim.MockFS diff --git a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs index e62c12f8dd..13776a1d4d 100644 --- a/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs +++ b/ouroboros-consensus/src/unstable-mock-block/Ouroboros/Consensus/Mock/Protocol/LeaderSchedule.hs @@ -1,8 +1,8 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NamedFieldPuns #-} module Ouroboros.Consensus.Mock.Protocol.LeaderSchedule ( ConsensusConfig (..) diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index f47eed223f..a8fc0ed3a2 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -10,7 +10,6 @@ import qualified Test.Consensus.Mempool.Fairness (tests) import qualified Test.Consensus.MiniProtocol.BlockFetch.Client (tests) import qualified Test.Consensus.MiniProtocol.ChainSync.Client (tests) import qualified Test.Consensus.MiniProtocol.LocalStateQuery.Server (tests) -import qualified Test.Consensus.ResourceRegistry (tests) import qualified Test.Consensus.Util.MonadSTM.RAWLock (tests) import qualified Test.Consensus.Util.Versioned (tests) import Test.Tasty @@ -30,7 +29,6 @@ tests = , Test.Consensus.MiniProtocol.LocalStateQuery.Server.tests , Test.Consensus.Mempool.tests , Test.Consensus.Mempool.Fairness.tests - , Test.Consensus.ResourceRegistry.tests , Test.Consensus.Util.MonadSTM.RAWLock.tests , Test.Consensus.Util.Versioned.tests , testGroup "HardFork" [ diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs index 4fc780abc3..b7cd2ccaf9 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/BlockchainTime/Simple.hs @@ -46,6 +46,7 @@ import Control.Monad.Class.MonadTimer.SI import Control.Monad.Except (Except, runExcept, throwError) import Control.Monad.IOSim import Control.Monad.Reader (ReaderT (..), lift) +import Control.ResourceRegistry import Control.Tracer import Data.Fixed import qualified Data.Time.Clock as Time @@ -53,7 +54,6 @@ import NoThunks.Class (AllowThunk (..)) import Ouroboros.Consensus.Block import Ouroboros.Consensus.BlockchainTime import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (withWatcher) import Ouroboros.Consensus.Util.Time import Test.QuickCheck hiding (Fixed) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs index b3aa0efe1e..eff61371f3 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/BlockFetch/Client.hs @@ -26,6 +26,7 @@ import Control.Monad (replicateM) import Control.Monad.Class.MonadTime import Control.Monad.Class.MonadTimer.SI (MonadTimer) import Control.Monad.IOSim (runSimOrThrow) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), nullTracer, traceWith) import Data.Bifunctor (first) import Data.Hashable (Hashable) @@ -45,7 +46,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl as ChainDBImpl import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (blockUntilJust, forkLinkedWatcher) import Ouroboros.Network.AnchoredFragment (AnchoredFragment) diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs index ff05b517fb..5eea8d473e 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/MiniProtocol/ChainSync/Client.hs @@ -55,6 +55,7 @@ import Control.Monad (forM_, unless, void, when) import Control.Monad.Class.MonadThrow (Handler (..), catches) import Control.Monad.Class.MonadTime (MonadTime, getCurrentTime) import Control.Monad.IOSim (runSimOrThrow) +import Control.ResourceRegistry import Control.Tracer (contramap, contramapM, nullTracer) import Data.DerivingVia (InstantiatedAt (InstantiatedAt)) import Data.List (intercalate) @@ -98,7 +99,6 @@ import Ouroboros.Consensus.Storage.ChainDB.API import Ouroboros.Consensus.Util (whenJust) import Ouroboros.Consensus.Util.Condense import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Consensus.Util.STM (Fingerprint (..), WithFingerprint (..)) import Ouroboros.Consensus.Util.Time (multipleNominalDelay, diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs index 884515d164..73399a83d0 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs +++ b/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs @@ -29,11 +29,11 @@ import Control.Exception (throw) import Control.Monad.Except import Control.Monad.IOSim (IOSim, SimEventType (..), SimTrace, runSimTrace, selectTraceEvents, traceResult) +import Control.ResourceRegistry import Data.Time.Clock (picosecondsToDiffTime) import Ouroboros.Consensus.Util.IOLike import Ouroboros.Consensus.Util.MonadSTM.RAWLock (RAWLock) import qualified Ouroboros.Consensus.Util.MonadSTM.RAWLock as RAWLock -import Ouroboros.Consensus.Util.ResourceRegistry import Test.QuickCheck import Test.QuickCheck.Gen.Unsafe (Capture (..), capture) import Test.QuickCheck.Monadic diff --git a/ouroboros-consensus/test/doctest.hs b/ouroboros-consensus/test/doctest.hs index 159947adb3..222b4efbc2 100644 --- a/ouroboros-consensus/test/doctest.hs +++ b/ouroboros-consensus/test/doctest.hs @@ -1,5 +1,7 @@ module Main (main) where +import Image.LaTeX.Render () + main :: IO () main = do putStrLn "This test-suite exists only to add dependencies" diff --git a/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Adversarial.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Adversarial.hs index 64b96d8a2a..21bd12fb45 100644 --- a/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Adversarial.hs +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Adversarial.hs @@ -24,13 +24,12 @@ import Data.Proxy (Proxy (Proxy)) import qualified System.Random as R import qualified System.Timeout as IO (timeout) import qualified Test.Consensus.ChainGenerator.Adversarial as A -import Test.Consensus.ChainGenerator.Adversarial - (genPrefixBlockCount) +import Test.Consensus.ChainGenerator.Adversarial (genPrefixBlockCount) import qualified Test.Consensus.ChainGenerator.BitVector as BV import qualified Test.Consensus.ChainGenerator.Counting as C import qualified Test.Consensus.ChainGenerator.Honest as H -import Test.Consensus.ChainGenerator.Params (Asc, - Delta (Delta), Kcp (Kcp), Len (Len), Scg (Scg), genAsc) +import Test.Consensus.ChainGenerator.Params (Asc, Delta (Delta), + Kcp (Kcp), Len (Len), Scg (Scg), genAsc) import qualified Test.Consensus.ChainGenerator.RaceIterator as RI import qualified Test.Consensus.ChainGenerator.Slot as S import Test.Consensus.ChainGenerator.Slot (E (SlotE)) diff --git a/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/BitVector.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/BitVector.hs index a3343270d1..17d0b842f5 100644 --- a/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/BitVector.hs +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/BitVector.hs @@ -16,8 +16,8 @@ import qualified System.Random.Stateful as R import qualified Test.Consensus.ChainGenerator.BitVector as BV import qualified Test.Consensus.ChainGenerator.Counting as C import qualified Test.Consensus.ChainGenerator.Slot as S -import Test.Consensus.ChainGenerator.Slot - (E (EmptySlotE, SlotE), POL, PreImage, S) +import Test.Consensus.ChainGenerator.Slot (E (EmptySlotE, SlotE), POL, + PreImage, S) import qualified Test.Consensus.ChainGenerator.Some as Some import qualified Test.QuickCheck as QC import Test.QuickCheck.Random (QCGen) diff --git a/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Honest.hs b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Honest.hs index 903b87eb98..1773e2d068 100644 --- a/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Honest.hs +++ b/ouroboros-consensus/test/infra-test/Test/Consensus/ChainGenerator/Tests/Honest.hs @@ -18,9 +18,8 @@ import Data.Proxy (Proxy (Proxy)) import qualified System.Random as R import qualified System.Timeout as IO (timeout) import qualified Test.Consensus.ChainGenerator.Honest as H -import Test.Consensus.ChainGenerator.Params (Asc, - Delta (Delta), Kcp (Kcp), Len (Len), Scg (Scg), genAsc, - genKSD) +import Test.Consensus.ChainGenerator.Params (Asc, Delta (Delta), + Kcp (Kcp), Len (Len), Scg (Scg), genAsc, genKSD) import qualified Test.QuickCheck as QC import Test.QuickCheck.Extras (sized1, unsafeMapSuchThatJust) import Test.QuickCheck.Random (QCGen) diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/FollowerPromptness.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/FollowerPromptness.hs index 045d9962dd..b616eea62d 100644 --- a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/FollowerPromptness.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/FollowerPromptness.hs @@ -21,6 +21,7 @@ module Test.Consensus.Storage.ChainDB.FollowerPromptness (tests) where import Control.Monad (forever) import Control.Monad.IOSim (runSimOrThrow) +import Control.ResourceRegistry import Control.Tracer (Tracer (..), contramapM, traceWith) import Data.Foldable (for_) import Data.Map.Strict (Map) @@ -38,7 +39,6 @@ import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Args as ChainDB import Ouroboros.Consensus.Util.Condense (Condense (..)) import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import qualified Ouroboros.Network.Mock.Chain as Chain import Test.QuickCheck import Test.Tasty diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/GcSchedule.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/GcSchedule.hs index 9b8f2c4a00..82874deb62 100644 --- a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/GcSchedule.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/GcSchedule.hs @@ -16,9 +16,7 @@ -- We then test that the real implementation behaves exactly as the model -- predicts. -- -module Test.Consensus.Storage.ChainDB.GcSchedule ( - tests - ) where +module Test.Consensus.Storage.ChainDB.GcSchedule (tests) where import Control.Monad (forM) import Control.Monad.IOSim (runSimOrThrow) diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Iterator.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Iterator.hs index 357a4071e2..010464b122 100644 --- a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Iterator.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Iterator.hs @@ -16,6 +16,7 @@ import Control.Monad (forM_) import Control.Monad.Except (ExceptT (..), runExceptT) import Control.Monad.IOSim (runSimOrThrow) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry import Control.Tracer import Data.List (intercalate) import qualified Data.Map.Strict as Map @@ -33,7 +34,6 @@ import Ouroboros.Consensus.Storage.VolatileDB (VolatileDB) import qualified Ouroboros.Consensus.Storage.VolatileDB as VolatileDB import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Mock.Chain (Chain) import qualified Ouroboros.Network.Mock.Chain as Chain import qualified Test.Consensus.Storage.ImmutableDB.Mock as ImmutableDB diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine.hs index b270e5b00d..fdb7b07b67 100644 --- a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/StateMachine.hs @@ -81,6 +81,7 @@ module Test.Consensus.Storage.ChainDB.StateMachine ( import Codec.Serialise (Serialise) import Control.Monad (replicateM, void) +import Control.ResourceRegistry import Control.Tracer as CT import Data.Bifoldable import Data.Bifunctor @@ -129,7 +130,6 @@ import Ouroboros.Consensus.Util.CallStack import Ouroboros.Consensus.Util.Condense (condense) import Ouroboros.Consensus.Util.Enclose import Ouroboros.Consensus.Util.IOLike hiding (invariant) -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.AnchoredFragment (AnchoredFragment) import qualified Ouroboros.Network.AnchoredFragment as AF import Ouroboros.Network.Block (ChainUpdate, MaxSlotNo) diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Unit.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Unit.hs index 33c9ed148d..c2b15a89d7 100644 --- a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Unit.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ChainDB/Unit.hs @@ -22,6 +22,7 @@ import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) import Control.Monad.State (MonadState, StateT, evalStateT, get, modify, put) import Control.Monad.Trans.Class (lift) +import Control.ResourceRegistry (closeRegistry, unsafeNewRegistry) import Data.Maybe (isJust) import Ouroboros.Consensus.Block.Abstract (blockSlot) import Ouroboros.Consensus.Block.RealPoint @@ -40,8 +41,6 @@ import Ouroboros.Consensus.Storage.Common (StreamFrom (..), StreamTo (..)) import Ouroboros.Consensus.Storage.ImmutableDB.Chunks as ImmutableDB import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry (closeRegistry, - unsafeNewRegistry) import Ouroboros.Network.Block (ChainUpdate (..), Point, blockPoint) import qualified Ouroboros.Network.Mock.Chain as Mock import qualified Test.Consensus.Storage.ChainDB.Model as Model diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/StateMachine.hs index 13349e16cd..002b29be81 100644 --- a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/ImmutableDB/StateMachine.hs @@ -40,11 +40,10 @@ -- more state than that, in order to deal with stateful API components such as -- database cursors, but that's basically it. -- -module Test.Consensus.Storage.ImmutableDB.StateMachine ( - tests - ) where +module Test.Consensus.Storage.ImmutableDB.StateMachine (tests) where import Control.Monad (forM_, void) +import Control.ResourceRegistry import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import Data.Coerce (Coercible, coerce) @@ -74,7 +73,6 @@ import qualified Ouroboros.Consensus.Storage.ImmutableDB.Impl.Index as Index (CacheConfig (..)) import Ouroboros.Consensus.Storage.ImmutableDB.Impl.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Prelude hiding (elem, notElem) import System.FS.API (HasFS (..), SomeHasFS (..)) import System.FS.API.Types (FsPath, mkFsPath) diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OnDisk.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OnDisk.hs index c6fc4a1888..8b1105f975 100644 --- a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OnDisk.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/LedgerDB/OnDisk.hs @@ -36,9 +36,7 @@ -- The model here is satisfyingly simple: just a map from blocks to their -- corresponding ledger state. -- -module Test.Consensus.Storage.LedgerDB.OnDisk ( - tests - ) where +module Test.Consensus.Storage.LedgerDB.OnDisk (tests) where import Codec.Serialise (Serialise) import qualified Codec.Serialise as S diff --git a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/StateMachine.hs b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/StateMachine.hs index a563ca9b6d..184a2b2500 100644 --- a/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/StateMachine.hs +++ b/ouroboros-consensus/test/storage-test/Test/Consensus/Storage/VolatileDB/StateMachine.hs @@ -27,11 +27,10 @@ -- hope (just a set of blocks) is that we need the additional detail to be able -- to predict the effects of disk corruption. -- -module Test.Consensus.Storage.VolatileDB.StateMachine ( - tests - ) where +module Test.Consensus.Storage.VolatileDB.StateMachine (tests) where import Control.Monad (forM_, void) +import Control.ResourceRegistry import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import Data.Functor.Classes @@ -53,7 +52,6 @@ import Ouroboros.Consensus.Storage.VolatileDB import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types (FileId) import Ouroboros.Consensus.Storage.VolatileDB.Impl.Util import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry import Ouroboros.Network.Block (MaxSlotNo) import Prelude hiding (elem) import System.FS.API.Lazy diff --git a/resource-registry/CHANGELOG.md b/resource-registry/CHANGELOG.md new file mode 100644 index 0000000000..aeeb7edf4b --- /dev/null +++ b/resource-registry/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for resource-registry + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/resource-registry/LICENSE b/resource-registry/LICENSE new file mode 100644 index 0000000000..d645695673 --- /dev/null +++ b/resource-registry/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/resource-registry/resource-registry.cabal b/resource-registry/resource-registry.cabal new file mode 100644 index 0000000000..7b8b993767 --- /dev/null +++ b/resource-registry/resource-registry.cabal @@ -0,0 +1,85 @@ +cabal-version: 3.0 +name: resource-registry +version: 0.1.0.0 +synopsis: Track allocated resources +description: + When the scope of a @bracket@ doesn't enclose all uses of the resource, a + 'ResourceRegistry' can be used instead to capture the lifetime of those + resources. + +homepage: https://github.com/input-output-hk/resource-registry +license: Apache-2.0 +license-file: LICENSE +author: IOG Engineering Team +maintainer: hackage@iohk.io +copyright: + 2019-2023 Input Output Global Inc (IOG) + 2023-2024 INTERSECT + 2024 Input Output Global Inc (IOG) + +category: Control +build-type: Simple +extra-doc-files: + CHANGELOG.md + +tested-with: + ghc ==8.10 || ==9.6 || ==9.8 + +source-repository head + type: git + location: https://github.com/input-output-hk/resource-registry + +common warnings + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wunused-packages + -Wno-unticked-promoted-constructors + +library + import: warnings + exposed-modules: Control.ResourceRegistry + build-depends: + base >=4.14 && <4.20, + bimap, + containers, + io-classes ^>=1.5, + mtl, + nf-vars ^>=0.1, + nothunks ^>=0.1.5, + + hs-source-dirs: src + default-language: Haskell2010 + +test-suite resource-registry-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Test.Util.QSM + Test.Util.SOP + Test.Util.ToExpr + + build-depends: + QuickCheck, + base, + containers, + generics-sop, + io-classes, + mtl, + quickcheck-state-machine:no-vendored-treediff, + resource-registry, + si-timers, + strict-mvar, + strict-stm, + tasty, + tasty-quickcheck, + tree-diff, diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs b/resource-registry/src/Control/ResourceRegistry.hs similarity index 82% rename from ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs rename to resource-registry/src/Control/ResourceRegistry.hs index ef4e3ebec7..6cd1235494 100644 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/ResourceRegistry.hs +++ b/resource-registry/src/Control/ResourceRegistry.hs @@ -3,85 +3,22 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -module Ouroboros.Consensus.Util.ResourceRegistry ( - RegistryClosedException (..) - , ResourceRegistryThreadException - -- * Creating and releasing the registry itself - , bracketWithPrivateRegistry - , registryThread - , withRegistry - -- * Allocating and releasing regular resources - , ResourceKey - , allocate - , allocateEither - , release - , releaseAll - , unsafeRelease - , unsafeReleaseAll - -- * Threads - , cancelThread - , forkLinkedThread - , forkThread - , linkToRegistry - , threadId - , waitAnyThread - , waitThread - , withThread - -- ** opaque - , Thread - -- * Temporary registry - , TempRegistryException (..) - , allocateTemp - , modifyWithTempRegistry - , runInnerWithTempRegistry - , runWithTempRegistry - -- ** opaque - , WithTempRegistry - -- * Combinators primarily for testing - , closeRegistry - , countResources - , unsafeNewRegistry - -- * opaque - , ResourceRegistry - ) where +{-# OPTIONS_GHC -Wno-orphans #-} -import Control.Applicative ((<|>)) -import Control.Exception (asyncExceptionFromException) -import Control.Monad -import Control.Monad.Reader -import Control.Monad.State.Strict -import Data.Bifunctor -import Data.Bimap (Bimap) -import qualified Data.Bimap as Bimap -import Data.Either (partitionEithers) -import Data.Map.Strict (Map) -import qualified Data.Map.Strict as Map -import Data.Maybe (catMaybes, listToMaybe) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Word (Word64) -import GHC.Generics (Generic) -import NoThunks.Class (InspectHeapNamed (..), OnlyCheckWhnfNamed (..), - allNoThunks) -import Ouroboros.Consensus.Util (mustBeRight, whenJust) -import Ouroboros.Consensus.Util.CallStack -import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.Orphans () - --- | Resource registry --- --- Note on terminology: when thread A forks thread B, we will say that thread A --- is the " parent " and thread B is the " child ". No further relationship +-- | Note on terminology: when thread A forks thread B, we will say that thread A +-- is the \"parent\" and thread B is the \"child\". No further relationship -- between the two threads is implied by this terminology. In particular, note --- that the child may outlive the parent. We will use "fork" and "spawn" +-- that the child may outlive the parent. We will use \"fork\" and \"spawn\" -- interchangeably. -- -- = Motivation @@ -189,13 +126,14 @@ import Ouroboros.Consensus.Util.Orphans () -- = Spawning threads -- -- We already observed in the introduction that insisting on lexical scoping --- for threads is often inconvenient, and that simply using 'fork' is no --- solution as it means we might leak resources. There is however another --- problem with 'fork'. Consider this snippet: +-- for threads is often inconvenient, and that simply using +-- 'Control.Monad.Class.MonadFork.forkIO' is no solution as it means we might +-- leak resources. There is however another problem with +-- 'Control.Monad.Class.MonadFork.forkIO'. Consider this snippet: -- -- > withRegistry $ \registry -> -- > r <- allocate registry allocateResource releaseResource --- > fork $ .. use r .. +-- > forkIO $ .. use r .. -- -- It is easy to see that this code is problematic: we allocate a resource @r@, -- then spawn a thread that uses @r@, and finally leave the scope of @@ -284,6 +222,77 @@ import Ouroboros.Consensus.Util.Orphans () -- registries, but even if we do have easy access to a parent regisry, creating -- a local one where possibly is useful as it limits the scope of the resources -- created within, and hence their maximum lifetimes. + +module Control.ResourceRegistry ( + -- * The resource registry proper + Context + , ResourceId + , ResourceRegistry + -- * Exceptions + , RegistryClosedException (..) + , ResourceRegistryThreadException + -- * Creating and releasing the registry itself + , bracketWithPrivateRegistry + , registryThread + , withRegistry + -- * Allocating and releasing regular resources + , ResourceKey + , allocate + , allocateEither + , release + , releaseAll + , unsafeRelease + , unsafeReleaseAll + -- * Threads + , Thread + , cancelThread + , forkLinkedThread + , forkThread + , linkToRegistry + , threadId + , waitAnyThread + , waitThread + , withThread + -- * Temporary registry + , TempRegistryException (..) + , WithTempRegistry + , allocateTemp + , modifyWithTempRegistry + , runInnerWithTempRegistry + , runWithTempRegistry + -- * Unsafe combinators primarily for testing + , closeRegistry + , countResources + , unsafeNewRegistry + ) where + +import Control.Applicative ((<|>)) +import Control.Concurrent.Class.MonadSTM (MonadSTM (atomically)) +import Control.Concurrent.Class.MonadSTM.NormalForm +import Control.Exception (asyncExceptionFromException) +import Control.Monad +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadThrow +import Control.Monad.Reader +import Control.Monad.State.Strict +import Data.Bifunctor +import Data.Bimap (Bimap) +import qualified Data.Bimap as Bimap +import Data.Either (partitionEithers) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Maybe (catMaybes, listToMaybe) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Void +import Data.Word (Word64) +import GHC.Generics (Generic) +import GHC.Stack (CallStack, HasCallStack) +import qualified GHC.Stack as GHC +import NoThunks.Class hiding (Context) + +-- | Tracks resources during their lifetime. data ResourceRegistry m = ResourceRegistry { -- | Context in which the registry was created registryContext :: !(Context m) @@ -293,7 +302,8 @@ data ResourceRegistry m = ResourceRegistry { } deriving (Generic) -deriving instance IOLike m => NoThunks (ResourceRegistry m) +deriving instance (forall a. NoThunks a => NoThunks (StrictTVar m a)) + => NoThunks (ResourceRegistry m) {------------------------------------------------------------------------------- Internal: registry state @@ -326,14 +336,14 @@ nextYoungerAge :: Age -> Age nextYoungerAge (Age n) = Age (n - 1) -- | Internal registry state --- --- INVARIANT: We record exactly the ages of currently allocated resources, --- @'Bimap.keys' . 'registryAges' = 'Map.keys' . 'registryResources'@. data RegistryState m = RegistryState { -- | Forked threads registryThreads :: !(KnownThreads m) -- | Currently allocated resources + -- + -- INVARIANT: We record exactly the ages of currently allocated resources, + -- @'Bimap.keys' . 'registryAges' = 'Map.keys' . 'registryResources'@. , registryResources :: !(Map ResourceId (Resource m)) -- | Next available resource key @@ -387,7 +397,10 @@ data RegistryStatus = -- -- Resource keys are tied to a particular registry. data ResourceKey m = ResourceKey !(ResourceRegistry m) !ResourceId - deriving (Generic, NoThunks) + deriving Generic + +deriving instance NoThunks (ResourceRegistry m) + => NoThunks (ResourceKey m) -- | Return the 'ResourceId' of a 'ResourceKey'. resourceKeyId :: ResourceKey m -> ResourceId @@ -427,13 +440,16 @@ instance Show (Release m) where Internal: pure functions on the registry state -------------------------------------------------------------------------------} -modifyKnownThreads :: (Set (ThreadId m) -> Set (ThreadId m)) - -> KnownThreads m -> KnownThreads m +modifyKnownThreads :: + (Set (ThreadId m) -> Set (ThreadId m)) + -> KnownThreads m + -> KnownThreads m modifyKnownThreads f (KnownThreads ts) = KnownThreads (f ts) -- | Auxiliary for functions that should be disallowed when registry is closed -unlessClosed :: State (RegistryState m) a - -> State (RegistryState m) (Either PrettyCallStack a) +unlessClosed :: + State (RegistryState m) a + -> State (RegistryState m) (Either PrettyCallStack a) unlessClosed f = do status <- gets registryStatus case status of @@ -448,9 +464,10 @@ allocKey = unlessClosed $ do return nextKey -- | Insert new resource -insertResource :: ResourceId - -> Resource m - -> State (RegistryState m) (Either PrettyCallStack ()) +insertResource :: + ResourceId + -> Resource m + -> State (RegistryState m) (Either PrettyCallStack ()) insertResource key r = unlessClosed $ do modify $ \st -> st { registryResources = Map.insert key r (registryResources st) @@ -476,7 +493,7 @@ removeResource key = state $ \st -> in (mbResource, st') -- | Insert thread into the set of known threads -insertThread :: IOLike m => ThreadId m -> State (RegistryState m) () +insertThread :: MonadThread m => ThreadId m -> State (RegistryState m) () insertThread tid = modify $ \st -> st { registryThreads = modifyKnownThreads (Set.insert tid) $ @@ -484,7 +501,7 @@ insertThread tid = } -- | Remove thread from set of known threads -removeThread :: IOLike m => ThreadId m -> State (RegistryState m) () +removeThread :: MonadThread m => ThreadId m -> State (RegistryState m) () removeThread tid = modify $ \st -> st { registryThreads = modifyKnownThreads (Set.delete tid) $ @@ -496,17 +513,20 @@ removeThread tid = -- Returns the keys currently allocated if the registry is not already closed. -- -- POSTCONDITION: They are returned in youngest-to-oldest order. -close :: PrettyCallStack - -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) +close :: + PrettyCallStack + -> State (RegistryState m) (Either PrettyCallStack [ResourceId]) close closeCallStack = unlessClosed $ do modify $ \st -> st {registryStatus = RegistryClosed closeCallStack} gets getYoungestToOldest -- | Convenience function for updating the registry state -updateState :: forall m a. IOLike m - => ResourceRegistry m - -> State (RegistryState m) a - -> m a +updateState :: + forall m a. + MonadSTM m + => ResourceRegistry m + -> State (RegistryState m) a + -> m a updateState rr f = atomically $ stateTVar (registryState rr) (runState f) @@ -522,16 +542,17 @@ updateState rr f = -- -- It is probably not particularly useful for threads to try and catch this -- exception (apart from in a generic handler that does local resource cleanup). --- The thread will anyway soon receive a 'ThreadKilled' exception. +-- The thread will anyway soon receive a 'Control.Exception.ThreadKilled' +-- exception. data RegistryClosedException = - forall m. IOLike m => RegistryClosedException { + forall m. MonadThread m => RegistryClosedException { -- | The context in which the registry was created registryClosedRegistryContext :: !(Context m) - -- | Callstack to the call to 'close' + -- | Callstack to the call to 'closeRegistry' -- - -- Note that 'close' can only be called from the same thread that - -- created the registry. + -- Note that 'closeRegistry' can only be called from the same thread + -- that created the registry. , registryClosedCloseCallStack :: !PrettyCallStack -- | Context of the call resulting in the exception @@ -549,7 +570,9 @@ instance Exception RegistryClosedException -- -- You are strongly encouraged to use 'withRegistry' instead. -- Exported primarily for the benefit of tests. -unsafeNewRegistry :: (IOLike m, HasCallStack) => m (ResourceRegistry m) +unsafeNewRegistry :: + (MonadSTM m, MonadThread m, HasCallStack) + => m (ResourceRegistry m) unsafeNewRegistry = do context <- captureContext stateVar <- newTVarIO initState @@ -587,7 +610,10 @@ unsafeNewRegistry = do -- will prioritize asynchronous exceptions over other exceptions. This may be -- important for exception handlers that catch all-except-asynchronous -- exceptions. -closeRegistry :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () +closeRegistry :: + (MonadMask m, MonadThread m, MonadSTM m, HasCallStack) + => ResourceRegistry m + -> m () closeRegistry rr = mask_ $ do context <- captureContext unless (contextThreadId context == contextThreadId (registryContext rr)) $ @@ -616,15 +642,16 @@ closeRegistry rr = mask_ $ do -- the resources allocated with the given 'ResourceId's. -- -- Returns the contexts of the resources that were actually released. -releaseResources :: IOLike m - => ResourceRegistry m - -> [ResourceId] - -- ^ PRECONDITION: The currently allocated keys, - -- youngest-to-oldest - -> (ResourceKey m -> m (Maybe (Context m))) - -- ^ How to release the resource, e.g., 'release' or - -- 'unsafeRelease'. - -> m [Context m] +releaseResources :: + MonadCatch m + => ResourceRegistry m + -> [ResourceId] + -- ^ PRECONDITION: The currently allocated keys, + -- youngest-to-oldest + -> (ResourceKey m -> m (Maybe (Context m))) + -- ^ How to release the resource, e.g., 'release' or + -- 'unsafeRelease'. + -> m [Context m] releaseResources rr sortedKeys releaser = do (exs, mbContexts) <- fmap partitionEithers $ forM sortedKeys $ try . releaser . ResourceKey rr @@ -643,7 +670,10 @@ releaseResources rr sortedKeys releaser = do -- | Create a new registry -- -- See documentation of 'ResourceRegistry' for a detailed discussion. -withRegistry :: (IOLike m, HasCallStack) => (ResourceRegistry m -> m a) -> m a +withRegistry :: + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) + => (ResourceRegistry m -> m a) + -> m a withRegistry = bracket unsafeNewRegistry closeRegistry -- | Create a new private registry for use by a bracketed resource @@ -681,11 +711,12 @@ withRegistry = bracket unsafeNewRegistry closeRegistry -- private to the bracketed resource. -- -- See documentation of 'ResourceRegistry' for a more general discussion. -bracketWithPrivateRegistry :: (IOLike m, HasCallStack) - => (ResourceRegistry m -> m a) - -> (a -> m ()) -- ^ Release the resource - -> (a -> m r) - -> m r +bracketWithPrivateRegistry :: + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) + => (ResourceRegistry m -> m a) + -> (a -> m ()) -- ^ Release the resource + -> (a -> m r) + -> m r bracketWithPrivateRegistry newA closeA body = withRegistry $ \registry -> do (_key, a) <- allocate registry (\_key -> newA registry) closeA @@ -698,10 +729,11 @@ bracketWithPrivateRegistry newA closeA body = -- | Run an action with a temporary resource registry. -- -- When allocating resources that are meant to end up in some final state, --- e.g., stored in a 'TVar', after which they are guaranteed to be released --- correctly, it is possible that an exception is thrown after allocating such --- a resource, but before it was stored in the final state. In that case, the --- resource would be leaked. 'runWithTempRegistry' solves that problem. +-- e.g., stored in a 'Control.Monad.Class.MonadSTM.TVar', after which they are +-- guaranteed to be released correctly, it is possible that an exception is +-- thrown after allocating such a resource, but before it was stored in the +-- final state. In that case, the resource would be leaked. +-- 'runWithTempRegistry' solves that problem. -- -- When no exception is thrown before the end of 'runWithTempRegistry', the -- user must have transferred all the resources it allocated to their final @@ -734,7 +766,7 @@ bracketWithPrivateRegistry newA closeA body = -- because the state /must/ have been stored somewhere safely, transferring -- the resources, before the temporary registry is closed. runWithTempRegistry :: - (IOLike m, HasCallStack) + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) => WithTempRegistry st m (a, st) -> m a runWithTempRegistry m = withRegistry $ \rr -> do @@ -749,7 +781,7 @@ runWithTempRegistry m = withRegistry $ \rr -> do -- -- No need to mask here, whether we throw the async exception or -- 'TempRegistryRemainingResource' doesn't matter. - transferredTo <- atomically $ readTVar varTransferredTo + transferredTo <- readTVarIO varTransferredTo untrackTransferredTo rr transferredTo st context <- captureContext @@ -762,6 +794,10 @@ runWithTempRegistry m = withRegistry $ \rr -> do } return a + where + whenJust (Just x) f = f x + whenJust Nothing _ = pure () + -- | Embed a self-contained 'WithTempRegistry' computation into a larger one. -- -- The internal 'WithTempRegistry' is effectively passed to @@ -786,7 +822,8 @@ runWithTempRegistry m = withRegistry $ \rr -> do -- closed and then the composite resource will be closed. This means there's a -- risk of /double freeing/, which can be harmless if anticipated. runInnerWithTempRegistry :: - forall innerSt st m res a. IOLike m + forall innerSt st m res a. + (MonadSTM m, MonadMask m, MonadThread m) => WithTempRegistry innerSt m (a, innerSt, res) -- ^ The embedded computation; see ASSUMPTION above -> (res -> m Bool) @@ -811,13 +848,13 @@ runInnerWithTempRegistry inner free isTransferred = do -- 'runWithTempRegistry' that lets us perform some action with async -- exceptions masked "at the same time" it closes its registry. - -- Note that everything in `inner` allocated via `allocateTemp` must either be - -- closed or else present in `innerSt` by this point -- `runWithTempRegistry` - -- would have thrown if not. + -- Note that everything in `inner` allocated via `allocateTemp` must + -- either be closed or else present in `innerSt` by this point -- + -- `runWithTempRegistry` would have thrown if not. pure (a, innerSt) where - withFixedTempRegistry - :: TempRegistry st m + withFixedTempRegistry :: + TempRegistry st m -> WithTempRegistry st m res -> WithTempRegistry innerSt m res withFixedTempRegistry env (WithTempRegistry (ReaderT f)) = @@ -827,7 +864,7 @@ runInnerWithTempRegistry inner free isTransferred = do -- resources remaining in the temporary registry that haven't been transferred -- to the final state. data TempRegistryException = - forall m. IOLike m => TempRegistryRemainingResource { + forall m. MonadThread m => TempRegistryRemainingResource { -- | The context in which the temporary registry was created. tempRegistryContext :: !(Context m) @@ -861,7 +898,13 @@ data TempRegistry st m = TempRegistry { newtype WithTempRegistry st m a = WithTempRegistry { unWithTempRegistry :: ReaderT (TempRegistry st m) m a } - deriving newtype (Functor, Applicative, Monad, MonadThrow, MonadCatch, MonadMask) + deriving newtype ( Functor + , Applicative + , Monad + , MonadThrow + , MonadCatch + , MonadMask + ) instance MonadTrans (WithTempRegistry st) where lift = WithTempRegistry . lift @@ -878,7 +921,7 @@ instance MonadState s m => MonadState s (WithTempRegistry st m) where -- NOTE: does not check that it's called by the same thread that allocated the -- resources, as it's an internal function only used in 'runWithTempRegistry'. untrackTransferredTo :: - IOLike m + MonadSTM m => ResourceRegistry m -> TransferredTo st -> st @@ -891,7 +934,7 @@ untrackTransferredTo rr transferredTo st = -- | Allocate a resource in a temporary registry until it has been transferred -- to the final state @st@. See 'runWithTempRegistry' for more details. allocateTemp :: - (IOLike m, HasCallStack) + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) => m a -- ^ Allocate the resource -> (a -> m Bool) @@ -904,8 +947,8 @@ allocateTemp :: -> WithTempRegistry st m a allocateTemp alloc free isTransferred = WithTempRegistry $ do TempRegistry rr varTransferredTo <- ask - (key, a) <- lift $ fmap mustBeRight $ - allocateEither rr (fmap Right . const alloc) free + (key, a) <- lift (mustBeRight <$> + allocateEither rr (fmap Right . const alloc) free) lift $ atomically $ modifyTVar varTransferredTo $ mappend $ TransferredTo $ \st -> if isTransferred st a @@ -917,7 +960,8 @@ allocateTemp alloc free isTransferred = WithTempRegistry $ do -- allocating resources in the process that will be transferred to the -- returned @st@. modifyWithTempRegistry :: - forall m st a. IOLike m + forall m st a. + (MonadSTM m, MonadMask m, MonadThread m) => m st -- ^ Get the state -> (st -> ExitCase st -> m ()) -- ^ Store the new state -> StateT st (WithTempRegistry st m) a -- ^ Modify the state @@ -942,7 +986,7 @@ registryThread = contextThreadId . registryContext -- | Number of currently allocated resources -- -- Primarily for the benefit of testing. -countResources :: IOLike m => ResourceRegistry m -> m Int +countResources :: MonadSTM m => ResourceRegistry m -> m Int countResources rr = atomically $ aux <$> readTVar (registryState rr) where aux :: RegistryState m -> Int @@ -958,28 +1002,32 @@ countResources rr = atomically $ aux <$> readTVar (registryState rr) -- means that the resource allocation must either be fast or else interruptible; -- see "Dealing with Asynchronous Exceptions during Resource Acquisition" -- for details. -allocate :: forall m a. (IOLike m, HasCallStack) - => ResourceRegistry m - -> (ResourceId -> m a) - -> (a -> m ()) -- ^ Release the resource - -> m (ResourceKey m, a) +allocate :: + forall m a. + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) + => ResourceRegistry m + -> (ResourceId -> m a) + -> (a -> m ()) -- ^ Release the resource + -> m (ResourceKey m, a) allocate rr alloc free = mustBeRight <$> allocateEither rr (fmap Right . alloc) (\a -> free a >> return True) -- | Generalization of 'allocate' for allocation functions that may fail -allocateEither :: forall m e a. (IOLike m, HasCallStack) - => ResourceRegistry m - -> (ResourceId -> m (Either e a)) - -> (a -> m Bool) - -- ^ Release the resource, return 'True' when the resource - -- hasn't been released or closed before. - -> m (Either e (ResourceKey m, a)) +allocateEither :: + forall m e a. + (MonadSTM m, MonadMask m, MonadThread m, HasCallStack) + => ResourceRegistry m + -> (ResourceId -> m (Either e a)) + -> (a -> m Bool) + -- ^ Release the resource, return 'True' when the resource + -- hasn't been released or closed before. + -> m (Either e (ResourceKey m, a)) allocateEither rr alloc free = do context <- captureContext ensureKnownThread rr context -- We check if the registry has been closed when we allocate the key, so -- that we can avoid needlessly allocating the resource. - mKey <- updateState rr $ allocKey + mKey <- updateState rr allocKey case mKey of Left closed -> throwRegistryClosed rr context closed @@ -990,7 +1038,8 @@ allocateEither rr alloc free = do Right a -> do -- TODO: Might want to have an exception handler around this call to -- 'updateState' just in case /that/ throws an exception. - inserted <- updateState rr $ insertResource key (mkResource context a) + inserted <- updateState rr $ + insertResource key (mkResource context a) case inserted of Left closed -> do -- Despite the earlier check, it's possible that the registry @@ -1008,11 +1057,12 @@ allocateEither rr alloc free = do , resourceRelease = Release $ free a } -throwRegistryClosed :: IOLike m - => ResourceRegistry m - -> Context m - -> PrettyCallStack - -> m x +throwRegistryClosed :: + (MonadThrow m, MonadThread m) + => ResourceRegistry m + -> Context m + -> PrettyCallStack + -> m x throwRegistryClosed rr context closed = throwIO RegistryClosedException { registryClosedRegistryContext = registryContext rr , registryClosedCloseCallStack = closed @@ -1031,7 +1081,10 @@ throwRegistryClosed rr context closed = throwIO RegistryClosedException { -- Releasing an already released resource is a no-op. -- -- When the resource has not been released before, its context is returned. -release :: (IOLike m, HasCallStack) => ResourceKey m -> m (Maybe (Context m)) +release :: + (MonadMask m, MonadSTM m, MonadThread m, HasCallStack) + => ResourceKey m + -> m (Maybe (Context m)) release key@(ResourceKey rr _) = do context <- captureContext ensureKnownThread rr context @@ -1049,7 +1102,10 @@ release key@(ResourceKey rr _) = do -- -- This function should only be used if the above situation can be ruled out -- or handled by other means. -unsafeRelease :: IOLike m => ResourceKey m -> m (Maybe (Context m)) +unsafeRelease :: + (MonadMask m, MonadSTM m) + => ResourceKey m + -> m (Maybe (Context m)) unsafeRelease (ResourceKey rr rid) = do mask_ $ do mResource <- updateState rr $ removeResource rid @@ -1065,7 +1121,10 @@ unsafeRelease (ResourceKey rr rid) = do -- | Release all resources in the 'ResourceRegistry' without closing. -- -- See 'closeRegistry' for more details. -releaseAll :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () +releaseAll :: + (MonadMask m, MonadSTM m, MonadThread m, HasCallStack) + => ResourceRegistry m + -> m () releaseAll rr = do context <- captureContext unless (contextThreadId context == contextThreadId (registryContext rr)) $ @@ -1078,18 +1137,22 @@ releaseAll rr = do -- | This is to 'releaseAll' what 'unsafeRelease' is to 'release': we do not -- insist that this funciton is called from a thread that is known to the -- registry. See 'unsafeRelease' for why this is dangerous. -unsafeReleaseAll :: (IOLike m, HasCallStack) => ResourceRegistry m -> m () +unsafeReleaseAll :: + (MonadMask m, MonadSTM m, MonadThread m, HasCallStack) + => ResourceRegistry m + -> m () unsafeReleaseAll rr = do context <- captureContext void $ releaseAllHelper rr context unsafeRelease -- | Internal helper used by 'releaseAll' and 'unsafeReleaseAll'. -releaseAllHelper :: IOLike m - => ResourceRegistry m - -> Context m - -> (ResourceKey m -> m (Maybe (Context m))) - -- ^ How to release a resource - -> m [Context m] +releaseAllHelper :: + (MonadMask m, MonadSTM m, MonadThread m) + => ResourceRegistry m + -> Context m + -> (ResourceKey m -> m (Maybe (Context m))) + -- ^ How to release a resource + -> m [Context m] releaseAllHelper rr context releaser = mask_ $ do mKeys <- updateState rr $ unlessClosed $ gets getYoungestToOldest case mKeys of @@ -1103,7 +1166,8 @@ releaseAllHelper rr context releaser = mask_ $ do -- | Thread -- -- The internals of this type are not exported. -data Thread m a = IOLike m => Thread { +data Thread m a = MonadThread m => Thread { + -- | The underlying @async@ thread id threadId :: !(ThreadId m) , threadResourceId :: !ResourceId , threadAsync :: !(Async m a) @@ -1112,7 +1176,7 @@ data Thread m a = IOLike m => Thread { deriving NoThunks via OnlyCheckWhnfNamed "Thread" (Thread m a) -- | 'Eq' instance for 'Thread' compares 'threadId' only. -instance Eq (Thread m a) where +instance MonadThread m => Eq (Thread m a) where Thread{threadId = a} == Thread{threadId = b} = a == b -- | Cancel a thread @@ -1121,7 +1185,7 @@ instance Eq (Thread m a) where -- function returns. -- -- Uses 'uninterruptibleCancel' because that's what 'withAsync' does. -cancelThread :: IOLike m => Thread m a -> m () +cancelThread :: MonadAsync m => Thread m a -> m () cancelThread = uninterruptibleCancel . threadAsync -- | Wait for thread to terminate and return its result. @@ -1130,20 +1194,22 @@ cancelThread = uninterruptibleCancel . threadAsync -- -- NOTE: If A waits on B, and B is linked to the registry, and B throws an -- exception, then A might /either/ receive the exception thrown by B /or/ --- the 'ThreadKilled' exception thrown by the registry. -waitThread :: IOLike m => Thread m a -> m a +-- the 'Control.Exception.ThreadKilled' exception thrown by the registry. +waitThread :: MonadAsync m => Thread m a -> m a waitThread = wait . threadAsync -- | Lift 'waitAny' to 'Thread' -waitAnyThread :: forall m a. IOLike m => [Thread m a] -> m a +waitAnyThread :: forall m a. MonadAsync m => [Thread m a] -> m a waitAnyThread ts = snd <$> waitAny (map threadAsync ts) -- | Fork a new thread -forkThread :: forall m a. (IOLike m, HasCallStack) - => ResourceRegistry m - -> String -- ^ Label for the thread - -> m a - -> m (Thread m a) +forkThread :: + forall m a. + (MonadMask m, MonadAsync m, HasCallStack) + => ResourceRegistry m + -> String -- ^ Label for the thread + -> m a + -> m (Thread m a) forkThread rr label body = snd <$> allocate rr (\key -> mkThread key <$> async (body' key)) cancelThread where @@ -1208,7 +1274,7 @@ forkThread rr label body = snd <$> -- the parent, the child should probably be linked to the registry instead and -- the thread that spawned the registry should handle any exceptions. -- --- Note that in /principle/ there is no problem in using 'withAync' alongside a +-- Note that in /principle/ there is no problem in using 'withAsync' alongside a -- registry. After all, in a pattern like -- -- > withRegistry $ \registry -> @@ -1236,26 +1302,28 @@ forkThread rr label body = snd <$> -- NOTE: Threads that are spawned out of the user's control but that must still -- make use of the registry can use the unsafe API. This should be used with -- caution, however. -withThread :: IOLike m - => ResourceRegistry m - -> String -- ^ Label for the thread - -> m a - -> (Thread m a -> m b) - -> m b +withThread :: + (MonadMask m, MonadAsync m) + => ResourceRegistry m + -> String -- ^ Label for the thread + -> m a + -> (Thread m a -> m b) + -> m b withThread rr label body = bracket (forkThread rr label body) cancelThread -- | Link specified 'Thread' to the (thread that created) the registry -linkToRegistry :: IOLike m => Thread m a -> m () +linkToRegistry :: (MonadAsync m, MonadFork m, MonadMask m) => Thread m a -> m () linkToRegistry t = linkTo (registryThread $ threadRegistry t) (threadAsync t) -- | Fork a thread and link to it to the registry. -- -- This function is just a convenience. -forkLinkedThread :: (IOLike m, HasCallStack) - => ResourceRegistry m - -> String -- ^ Label for the thread - -> m a - -> m (Thread m a) +forkLinkedThread :: + (MonadAsync m, MonadFork m, MonadMask m, HasCallStack) + => ResourceRegistry m + -> String -- ^ Label for the thread + -> m a + -> m (Thread m a) forkLinkedThread rr label body = do t <- forkThread rr label body -- There is no race condition here between the new thread throwing an @@ -1269,8 +1337,12 @@ forkLinkedThread rr label body = do Check that registry is used from known thread -------------------------------------------------------------------------------} -ensureKnownThread :: forall m. IOLike m - => ResourceRegistry m -> Context m -> m () +ensureKnownThread :: + forall m. + (MonadThrow m, MonadThread m, MonadSTM m) + => ResourceRegistry m + -> Context m + -> m () ensureKnownThread rr context = do isKnown <- checkIsKnown unless isKnown $ @@ -1294,7 +1366,7 @@ data ResourceRegistryThreadException = -- | If the registry is used from an untracked thread, we cannot do proper -- reference counting. The following threads are /tracked/: the thread -- that spawned the registry and all threads spawned by the registry. - forall m. IOLike m => ResourceRegistryUsedFromUntrackedThread { + forall m. MonadThread m => ResourceRegistryUsedFromUntrackedThread { -- | Information about the context in which the registry was created resourceRegistryCreatedIn :: !(Context m) @@ -1303,7 +1375,7 @@ data ResourceRegistryThreadException = } -- | Registry closed from different threat than that created it - | forall m. IOLike m => ResourceRegistryClosedFromWrongThread { + | forall m. MonadThread m => ResourceRegistryClosedFromWrongThread { -- | Information about the context in which the registry was created resourceRegistryCreatedIn :: !(Context m) @@ -1318,7 +1390,9 @@ instance Exception ResourceRegistryThreadException Auxiliary: context -------------------------------------------------------------------------------} -data Context m = IOLike m => Context { +-- | The internal context of a resource registry, recording a 'PrettyCallStack' +-- of its creation and the creator's 'ThreadId' +data Context m = MonadThread m => Context { -- | CallStack in which it was created contextCallStack :: !PrettyCallStack @@ -1336,5 +1410,89 @@ instance NoThunks (Context m) where deriving instance Show (Context m) -captureContext :: IOLike m => HasCallStack => m (Context m) +captureContext :: MonadThread m => HasCallStack => m (Context m) captureContext = Context prettyCallStack <$> myThreadId + +{------------------------------------------------------------------------------- + Misc utilities +-------------------------------------------------------------------------------} + +-- | Generalization of 'link' that links an async to an arbitrary thread. +-- +-- Non standard (not in 'async' library) +-- +linkTo :: + (MonadAsync m, MonadFork m, MonadMask m) + => ThreadId m + -> Async m a + -> m () +linkTo tid = linkToOnly tid (not . isCancel) + +-- | Generalization of 'linkOnly' that links an async to an arbitrary thread. +-- +-- Non standard (not in 'async' library). +-- +linkToOnly :: + forall m a. + (MonadAsync m, MonadFork m, MonadMask m) + => ThreadId m + -> (SomeException -> Bool) + -> Async m a + -> m () +linkToOnly tid shouldThrow a = do + void $ forkRepeat ("linkToOnly " <> show linkedThreadId) $ do + r <- waitCatch a + case r of + Left e | shouldThrow e -> throwTo tid (exceptionInLinkedThread e) + _otherwise -> return () + where + linkedThreadId :: ThreadId m + linkedThreadId = asyncThreadId a + + exceptionInLinkedThread :: SomeException -> ExceptionInLinkedThread + exceptionInLinkedThread = + ExceptionInLinkedThread (show linkedThreadId) + +isCancel :: SomeException -> Bool +isCancel e + | Just AsyncCancelled <- fromException e = True + | otherwise = False + +forkRepeat :: (MonadFork m, MonadMask m) => String -> m a -> m (ThreadId m) +forkRepeat label action = + mask $ \restore -> + let go = do r <- tryAll (restore action) + case r of + Left _ -> go + _ -> return () + in forkIO (labelThisThread label >> go) + +tryAll :: MonadCatch m => m a -> m (Either SomeException a) +tryAll = try + +mustBeRight :: Either Void a -> a +mustBeRight (Left v) = absurd v +mustBeRight (Right a) = a + +{------------------------------------------------------------------------------- + Auxiliary: CallStack with different Show instance +-------------------------------------------------------------------------------} + +-- | CallStack with 'Show' instance using 'prettyCallStack' +newtype PrettyCallStack = PrettyCallStack CallStack + deriving newtype (NoThunks) + +instance Show PrettyCallStack where + show (PrettyCallStack cs) = GHC.prettyCallStack cs + +-- | Capture a 'PrettyCallStack' +prettyCallStack :: HasCallStack => PrettyCallStack +prettyCallStack = PrettyCallStack GHC.callStack + +{------------------------------------------------------------------------------- + Orphan instance +-------------------------------------------------------------------------------} + +instance (NoThunks k, NoThunks v) + => NoThunks (Bimap k v) where + wNoThunks ctxt = noThunksInKeysAndValues ctxt . Bimap.toList diff --git a/ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs b/resource-registry/test/Main.hs similarity index 87% rename from ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs rename to resource-registry/test/Main.hs index eb49b51904..4fc7304ef4 100644 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/ResourceRegistry.hs +++ b/resource-registry/test/Main.hs @@ -1,22 +1,17 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} -- | Tests for the resource registry -- --- The resource registry is a component throughout the consensus layer that --- helps us keep track of resources and makes sure that all resources that we --- allocate are eventually also deallocated in the right order. --- -- The tests for the registry are model based. The model records which resources -- we expect to be alive and which we expect to have been deallocated. The only -- resources we are modelling here are threads; the commands we then execute are @@ -28,18 +23,22 @@ -- -- We then verify that the resource registry behaves like the model, cleaning -- up resources as threads terminate or crash. --- -module Test.Consensus.ResourceRegistry (tests) where - -import Control.Monad ((>=>)) +module Main (main) where + +import Control.Concurrent.Class.MonadMVar.Strict +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.MonadTimer.SI -import Control.Monad.Except (Except, MonadError, runExcept, - throwError) -import Control.Monad.IO.Class (liftIO) -import Data.Foldable (toList) -import Data.Function (on) +import Control.Monad.Except +import Control.Monad.IO.Class +import Control.ResourceRegistry +import Data.Foldable +import Data.Function import Data.Functor.Classes -import Data.Kind (Type) +import Data.Kind import Data.List (delete, sort) import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map @@ -47,23 +46,21 @@ import Data.TreeDiff import Data.Typeable import qualified Generics.SOP as SOP import GHC.Generics (Generic, Generic1) -import Ouroboros.Consensus.Util.IOLike -import Ouroboros.Consensus.Util.ResourceRegistry -import Prelude hiding (elem) -import qualified Test.QuickCheck as QC -import Test.QuickCheck (Gen) -import qualified Test.QuickCheck.Monadic as QC +import Prelude +import Test.QuickCheck +import Test.QuickCheck.Monadic hiding (run) import Test.StateMachine import qualified Test.StateMachine.Types as QSM import qualified Test.StateMachine.Types.Rank2 as Rank2 import Test.Tasty hiding (after) -import Test.Tasty.QuickCheck (testProperty) +import Test.Tasty.QuickCheck import Test.Util.QSM import Test.Util.SOP import Test.Util.ToExpr () -tests :: TestTree -tests = testGroup "ResourceRegistry" [ +main :: IO () +main = defaultMain + $ testGroup "ResourceRegistry" [ testProperty "sequential" prop_sequential ] @@ -293,16 +290,16 @@ data ThreadInstr m :: Type -> Type where -- | Instruction along with an MVar for the result data QueuedInstr m = forall a. QueuedInstr (ThreadInstr m a) (StrictMVar m a) -runInThread :: IOLike m => TestThread m -> ThreadInstr m a -> m a +runInThread :: (MonadMVar m, MonadSTM m) => TestThread m -> ThreadInstr m a -> m a runInThread TestThread{..} instr = do - result <- uncheckedNewEmptyMVar + result <- newEmptyMVar atomically $ writeTQueue threadComms (QueuedInstr instr result) takeMVar result -instance (IOLike m) => Show (TestThread m) where +instance (MonadThread m) => Show (TestThread m) where show TestThread{..} = "" -instance (IOLike m) => Eq (TestThread m) where +instance (MonadThread m) => Eq (TestThread m) where (==) = (==) `on` (threadId . testThread) -- | Create a new thread in the given registry @@ -310,14 +307,14 @@ instance (IOLike m) => Eq (TestThread m) where -- In order to be able to see which threads are alive, we have threads -- register and unregister themselves. We do not reuse the registry for this, -- to avoid circular reasoning in the tests. -newThread :: forall m. IOLike m +newThread :: forall m. (MonadMVar m, MonadMask m, MonadAsync m, MonadFork m) => StrictTVar m [TestThread m] -> ResourceRegistry m -> Link (TestThread m) -> m (TestThread m) newThread alive parentReg = \shouldLink -> do comms <- atomically $ newTQueue - spawned <- uncheckedNewEmptyMVar + spawned <- newEmptyMVar thread <- forkThread parentReg "newThread" $ withRegistry $ \childReg -> @@ -360,7 +357,7 @@ newThread alive parentReg = \shouldLink -> do putMVar result () error "crashing" -runIO :: forall m. (IOLike m, MonadTimer m) +runIO :: forall m. (MonadMVar m, MonadTimer m, MonadMask m, MonadAsync m, MonadFork m) => StrictTVar m [TestThread m] -> ResourceRegistry m -> Cmd (TestThread m) -> m (Resp (TestThread m)) @@ -398,8 +395,8 @@ runIO alive reg cmd = catchEx $ timeout 1 $ newtype At m f r = At (f (Reference (TestThread m) r)) -deriving instance (Show1 r, IOLike m) => Show (At m Cmd r) -deriving instance (Show1 r, IOLike m) => Show (At m Resp r) +deriving instance (MonadThread m, Show1 r) => Show (At m Cmd r) +deriving instance (MonadThread m, Show1 r) => Show (At m Resp r) {------------------------------------------------------------------------------- Relate model to IO @@ -423,11 +420,11 @@ initModel = Model emptyMock [] Events -------------------------------------------------------------------------------} -toMock :: forall m f r. (Functor f, Eq1 r, Show1 r, IOLike m) +toMock :: forall m f r. (Functor f, Eq1 r, Show1 r, MonadThread m) => Model m r -> At m f r -> f MockThread toMock (Model _ hs) (At fr) = (hs !) <$> fr -step :: (Eq1 r, Show1 r, IOLike m) +step :: (Eq1 r, Show1 r, MonadThread m) => Model m r -> At m Cmd r -> (Resp MockThread, Mock) step m@(Model mock _) c = runMock (toMock m c) mock @@ -438,7 +435,7 @@ data Event m r = Event { , mockResp :: Resp MockThread } -lockstep :: (Eq1 r, Show1 r, IOLike m) +lockstep :: (Eq1 r, Show1 r, MonadThread m) => Model m r -> At m Cmd r -> At m Resp r @@ -464,9 +461,9 @@ lockstep m@(Model _ hs) c (At resp) = Event { -------------------------------------------------------------------------------} generator :: forall m. Model m Symbolic -> Maybe (Gen (At m Cmd Symbolic)) -generator (Model _ hs) = Just $ QC.oneof $ concat [ +generator (Model _ hs) = Just $ oneof $ concat [ withoutHandle - , if null hs then [] else withHandle (QC.elements (map fst hs)) + , if null hs then [] else withHandle (elements (map fst hs)) ] where withoutHandle :: [Gen (At m Cmd Symbolic)] @@ -484,7 +481,7 @@ generator (Model _ hs) = Just $ QC.oneof $ concat [ ] genLink :: Gen (Link ()) - genLink = aux <$> QC.arbitrary + genLink = aux <$> arbitrary where aux :: Bool -> Link () aux True = LinkFromParent () @@ -519,14 +516,14 @@ instance ToExpr Mock instance ToExpr (Link MockThread) instance ToExpr (Model IO Concrete) -instance (IOLike m) => ToExpr (TestThread m) where +instance (MonadThread m) => ToExpr (TestThread m) where toExpr = defaultExprViaShow {------------------------------------------------------------------------------- QSM toplevel -------------------------------------------------------------------------------} -semantics :: (IOLike m, MonadTimer m, Typeable m) +semantics :: (MonadMVar m, MonadMask m, MonadAsync m, MonadFork m, MonadTimer m, Typeable m) => StrictTVar m [TestThread m] -> ResourceRegistry m -> At m Cmd Concrete -> m (At m Resp Concrete) @@ -534,11 +531,11 @@ semantics alive reg (At c) = (At . fmap reference) <$> runIO alive reg (concrete <$> c) -transition :: (Eq1 r, Show1 r, IOLike m) +transition :: (Eq1 r, Show1 r, MonadThread m) => Model m r -> At m Cmd r -> At m Resp r -> Model m r transition m c = after . lockstep m c -precondition :: forall m. (IOLike m) +precondition :: forall m. (MonadThread m) => Model m Symbolic -> At m Cmd Symbolic -> Logic precondition (Model mock hs) (At c) = forall (toList c) checkRef @@ -549,7 +546,7 @@ precondition (Model mock hs) (At c) = Nothing -> Bot Just r' -> r' `member` mockLiveThreads (threads mock) -postcondition :: (IOLike m) +postcondition :: (MonadThread m) => Model m Concrete -> At m Cmd Concrete -> At m Resp Concrete @@ -559,7 +556,7 @@ postcondition m c r = where e = lockstep m c r -symbolicResp :: (IOLike m, Typeable m) +symbolicResp :: (MonadThread m, Typeable m) => Model m Symbolic -> At m Cmd Symbolic -> GenSym (At m Resp Symbolic) @@ -567,7 +564,7 @@ symbolicResp m c = At <$> traverse (const genSym) resp where (resp, _mock') = step m c -sm :: (IOLike m, MonadTimer m, Typeable m) +sm :: (MonadMVar m, MonadMask m, MonadAsync m, MonadFork m, MonadTimer m, Typeable m) => StrictTVar m [TestThread m] -> ResourceRegistry m -> StateMachine (Model m) (At m Cmd) m (At m Resp) @@ -584,18 +581,18 @@ sm alive reg = StateMachine { , cleanup = noCleanup } -prop_sequential :: QC.Property +prop_sequential :: Property prop_sequential = forAllCommands (sm unused unused) Nothing prop_sequential' -prop_sequential' :: QSM.Commands (At IO Cmd) (At IO Resp) -> QC.Property -prop_sequential' cmds = QC.monadicIO $ do - alive <- liftIO $ uncheckedNewTVarM [] +prop_sequential' :: QSM.Commands (At IO Cmd) (At IO Resp) -> Property +prop_sequential' cmds = monadicIO $ do + alive <- liftIO $ newTVarIO [] reg <- liftIO $ unsafeNewRegistry let sm' = sm alive reg (hist, _model, res) <- runCommands sm' cmds prettyCommands sm' hist $ checkCommandNames cmds - $ res QC.=== Ok + $ res === Ok unused :: a unused = error "not used during command generation" diff --git a/resource-registry/test/Test/Util/QSM.hs b/resource-registry/test/Test/Util/QSM.hs new file mode 100644 index 0000000000..ccf984be1c --- /dev/null +++ b/resource-registry/test/Test/Util/QSM.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Test.Util.QSM ( + Example + -- opaque + , example + , run + , run' + ) where + +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Data.Typeable +import qualified Test.StateMachine.Logic as Logic +import Test.StateMachine.Sequential +import Test.StateMachine.Types +import qualified Test.StateMachine.Types.Rank2 as Rank2 + +data Example cmd a = + Done a + | Run (cmd Symbolic) ([Var] -> Example cmd a) + | Fail String + +instance Functor (Example cmd) where + fmap = liftM + +instance Applicative (Example cmd) where + pure = Done + (<*>) = ap + +instance Monad (Example cmd) where + return = pure + Done a >>= f = f a + Run c k >>= f = Run c (k >=> f) + Fail err >>= _ = Fail err + +instance Fail.MonadFail (Example cmd) where + fail = Fail + +-- | Run a command, and capture its references +run :: Typeable a => cmd Symbolic -> Example cmd [Reference a Symbolic] +run cmd = Run cmd (Done . map (Reference . Symbolic)) + +-- | Run a command, ignoring its references +run' :: cmd Symbolic -> Example cmd () +run' cmd = Run cmd (\_vars -> Done ()) + +example :: forall model cmd m resp. (Rank2.Foldable resp, Show (cmd Symbolic)) + => StateMachine model cmd m resp + -> Example cmd () + -> Commands cmd resp +example sm = + Commands . fst . flip runGenSym newCounter . go (initModel sm) + where + go :: model Symbolic -> Example cmd () -> GenSym [Command cmd resp] + go _ (Done ()) = return [] + go _ (Fail err) = error $ "example: " ++ err + go m (Run cmd k) = do + case Logic.logic (precondition sm m cmd) of + Logic.VFalse counterexample -> + error $ "Invalid command " ++ show cmd ++ ": " ++ show counterexample + Logic.VTrue -> do + resp <- mock sm m cmd + + let m' :: model Symbolic + m' = transition sm m cmd resp + + vars :: [Var] + vars = getUsedVars resp + + cmd' :: Command cmd resp + cmd' = Command cmd resp vars + + (cmd' :) <$> go m' (k vars) diff --git a/resource-registry/test/Test/Util/SOP.hs b/resource-registry/test/Test/Util/SOP.hs new file mode 100644 index 0000000000..cf05a42b31 --- /dev/null +++ b/resource-registry/test/Test/Util/SOP.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +module Test.Util.SOP ( + constrName + , constrNames + ) where + +import Data.Proxy +import qualified Generics.SOP as SOP + +constrInfo :: SOP.HasDatatypeInfo a + => proxy a + -> SOP.NP SOP.ConstructorInfo (SOP.Code a) +constrInfo = SOP.constructorInfo . SOP.datatypeInfo + +constrName :: forall a. SOP.HasDatatypeInfo a => a -> String +constrName a = + SOP.hcollapse $ SOP.hliftA2 go (constrInfo p) (SOP.unSOP (SOP.from a)) + where + go :: SOP.ConstructorInfo b -> SOP.NP SOP.I b -> SOP.K String b + go nfo _ = SOP.K $ SOP.constructorName nfo + + p = Proxy @a + +constrNames :: SOP.HasDatatypeInfo a => proxy a -> [String] +constrNames p = + SOP.hcollapse $ SOP.hmap go (constrInfo p) + where + go :: SOP.ConstructorInfo a -> SOP.K String a + go nfo = SOP.K $ SOP.constructorName nfo diff --git a/resource-registry/test/Test/Util/ToExpr.hs b/resource-registry/test/Test/Util/ToExpr.hs new file mode 100644 index 0000000000..704b66befc --- /dev/null +++ b/resource-registry/test/Test/Util/ToExpr.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | This module implements QSM's @CanDiff@ typeclass using @tree-diff@'s +-- @ToExpr@. +module Test.Util.ToExpr () where + +import Data.TreeDiff as T +import qualified Test.StateMachine as QSM +import Test.StateMachine.Diffing (CanDiff (..)) +import qualified Test.StateMachine.Types.References as QSM + +instance ToExpr x => CanDiff x where + type ADiff x = Edit EditExpr + type AnExpr x = Expr + + toDiff = toExpr + exprDiff _ = T.exprDiff + diffToDocCompact _ = ansiWlBgEditExprCompact + diffToDoc _ = ansiWlBgEditExpr + exprToDoc _ = ansiWlBgExpr + +{------------------------------------------------------------------------------- + QSM's References instances +-------------------------------------------------------------------------------} + +instance ToExpr (r k) => ToExpr (QSM.Reference k r) + +instance ToExpr a => ToExpr (QSM.Concrete a) where + toExpr (QSM.Concrete x) = toExpr x + +instance ToExpr (QSM.Opaque a) where + toExpr _ = App "Opaque" [] diff --git a/scripts/ci/run-cabal-gild.sh b/scripts/ci/run-cabal-gild.sh index 9f08e799f0..d3907bc6d3 100755 --- a/scripts/ci/run-cabal-gild.sh +++ b/scripts/ci/run-cabal-gild.sh @@ -14,4 +14,4 @@ if ! command -v "$fdcmd" &> /dev/null; then fi fi -$fdcmd --full-path "$(pwd)/(ouroboros-consensus|sop-extras|strict-sop-core)" -e cabal -x cabal-gild -i {} -o {} +$fdcmd --full-path "$(pwd)/(ouroboros-consensus|sop-extras|strict-sop-core|resource-registry|nf-vars)" -e cabal -x cabal-gild -i {} -o {} diff --git a/scripts/ci/run-stylish.sh b/scripts/ci/run-stylish.sh index 5ebbe2911d..2bf836b18e 100755 --- a/scripts/ci/run-stylish.sh +++ b/scripts/ci/run-stylish.sh @@ -18,9 +18,8 @@ if ! command -v "$fdcmd" &> /dev/null; then exit 1 fi fi -$fdcmd --full-path "$(pwd)/(ouroboros-consensus|scripts|sop-extras|strict-sop-core)" \ +$fdcmd --full-path "$(pwd)/(ouroboros-consensus|scripts|sop-extras|strict-sop-core|resource-registry|nf-vars)" \ --extension hs \ - --exclude Setup.hs \ --exclude ouroboros-consensus-cardano/app/DBAnalyser/Parsers.hs \ --exec-batch stylish-haskell -c .stylish-haskell.yaml -i diff --git a/scripts/docs/prologue.haddock b/scripts/docs/prologue.haddock index 46d247ad91..747afd2897 100644 --- a/scripts/docs/prologue.haddock +++ b/scripts/docs/prologue.haddock @@ -56,7 +56,7 @@ implementation of consensus. * Utilities: - * "Ouroboros.Consensus.Util.ResourceRegistry" + * "Control.ResourceRegistry" == Consensus Components