diff --git a/cabal.project b/cabal.project index be4d540df6..5eaa20d15e 100644 --- a/cabal.project +++ b/cabal.project @@ -14,7 +14,7 @@ repository cardano-haskell-packages -- update either of these. index-state: -- Bump this if you need newer packages from Hackage - , hackage.haskell.org 2024-09-16T12:20:25Z + , hackage.haskell.org 2024-10-22T14:26:27Z -- Bump this if you need newer packages from CHaP , cardano-haskell-packages 2024-10-21T06:28:35Z @@ -44,3 +44,6 @@ package ouroboros-network if(os(windows)) constraints: bitvec -simd + +-- https://github.com/ulidtko/cabal-doctest/issues/85 +constraints: Cabal < 3.13 diff --git a/flake.lock b/flake.lock index b95df39180..935bef76ea 100644 --- a/flake.lock +++ b/flake.lock @@ -237,11 +237,11 @@ "hackageNix": { "flake": false, "locked": { - "lastModified": 1726636349, - "narHash": "sha256-Fh+GjlpDnWtUpc02zvjULcgHZQEHuHrfKviweM7U6UY=", + "lastModified": 1729643285, + "narHash": "sha256-2ukEfnphbVMpa6qJQ/h0O12e6wS9j+/w2mwE1YZQskI=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "1d222a41735184d1fb52fa6959516cb9bf7ea319", + "rev": "e07df92046b89b0359d426c02848d96196ad60ec", "type": "github" }, "original": { diff --git a/ouroboros-consensus/changelog.d/js-rawlock.md b/ouroboros-consensus/changelog.d/js-rawlock.md new file mode 100644 index 0000000000..f23cd8b779 --- /dev/null +++ b/ouroboros-consensus/changelog.d/js-rawlock.md @@ -0,0 +1,3 @@ +## Breaking + +* Use [`rawlock`](https://hackage.haskell.org/package/rawlock) instead of the in-tree implementation. diff --git a/ouroboros-consensus/ouroboros-consensus.cabal b/ouroboros-consensus/ouroboros-consensus.cabal index a782f3e6ff..3b46d7be74 100644 --- a/ouroboros-consensus/ouroboros-consensus.cabal +++ b/ouroboros-consensus/ouroboros-consensus.cabal @@ -261,7 +261,6 @@ library Ouroboros.Consensus.Util.IOLike Ouroboros.Consensus.Util.LeakyBucket Ouroboros.Consensus.Util.MonadSTM.NormalForm - Ouroboros.Consensus.Util.MonadSTM.RAWLock Ouroboros.Consensus.Util.MonadSTM.StrictSVar Ouroboros.Consensus.Util.NormalForm.StrictMVar Ouroboros.Consensus.Util.NormalForm.StrictTVar @@ -302,6 +301,7 @@ library primitive, psqueues ^>=0.2.3, quiet ^>=0.2, + rawlock ^>=0.1, reflection, semialign >=1.1, serialise ^>=0.2, @@ -534,7 +534,6 @@ test-suite consensus-test Test.Consensus.MiniProtocol.LocalStateQuery.Server Test.Consensus.ResourceRegistry Test.Consensus.Util.MonadSTM.NormalForm - Test.Consensus.Util.MonadSTM.RAWLock Test.Consensus.Util.Versioned build-depends: 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 641cfb84a2..cbe5ee3b53 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 qualified Control.RAWLock as RAWLock import Control.Tracer (Tracer, nullTracer, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.List as List (foldl') @@ -141,7 +142,6 @@ import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types 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 @@ -233,7 +233,7 @@ closeDBImpl :: -> m () closeDBImpl VolatileDBEnv { varInternalState, tracer, hasFS } = do mbInternalState <- - RAWLock.withWriteAccess varInternalState $ \st -> return (DbClosed, st) + RAWLock.withWriteAccess varInternalState $ \st -> return (st, DbClosed) case mbInternalState of DbClosed -> traceWith tracer DBAlreadyClosed DbOpen ost -> do 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 f4e4fa80e4..e23440e33e 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 @@ -33,6 +33,8 @@ module Ouroboros.Consensus.Storage.VolatileDB.Impl.State ( import Control.Monad import Control.Monad.State.Strict hiding (withState) +import Control.RAWLock (RAWLock) +import qualified Control.RAWLock as RAWLock import Control.Tracer (Tracer, traceWith) import qualified Data.ByteString.Lazy as Lazy import Data.List as List (foldl') @@ -52,10 +54,8 @@ import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl.Index as Index import Ouroboros.Consensus.Storage.VolatileDB.Impl.Parser import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types import Ouroboros.Consensus.Storage.VolatileDB.Impl.Util -import Ouroboros.Consensus.Util (whenJust, (.:)) +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 (..)) @@ -135,8 +135,7 @@ modifyOpenState appendOrWrite -- temporary registry. (acquire, release) = case appendOrWrite of Append -> - (atomically . RAWLock.unsafeAcquireAppendAccess, - atomically .: RAWLock.unsafeReleaseAppendAccess) + (RAWLock.unsafeAcquireAppendAccess, RAWLock.unsafeReleaseAppendAccess) Write -> (RAWLock.unsafeAcquireWriteAccess, RAWLock.unsafeReleaseWriteAccess) diff --git a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/RAWLock.hs b/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/RAWLock.hs deleted file mode 100644 index 61cf6ed20c..0000000000 --- a/ouroboros-consensus/src/ouroboros-consensus/Ouroboros/Consensus/Util/MonadSTM/RAWLock.hs +++ /dev/null @@ -1,495 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} - --- | A writer-biased Read-Append-Write (RAW) lock --- --- Intended for qualified import -module Ouroboros.Consensus.Util.MonadSTM.RAWLock ( - -- * Public API - RAWLock - , new - , poison - , read - , withAppendAccess - , withReadAccess - , withWriteAccess - -- * Exposed internals: non-bracketed acquire & release - , unsafeAcquireAppendAccess - , unsafeAcquireReadAccess - , unsafeAcquireWriteAccess - , unsafeReleaseAppendAccess - , unsafeReleaseReadAccess - , unsafeReleaseWriteAccess - ) where - -import Control.Monad (join) -import Control.Monad.Except (Except, runExcept, throwError) -import Data.Functor (($>)) -import GHC.Generics (Generic) -import GHC.Stack (CallStack, HasCallStack, callStack) -import NoThunks.Class (AllowThunk (..)) -import Ouroboros.Consensus.Util.IOLike -import Prelude hiding (read) - -{------------------------------------------------------------------------------- - Public API --------------------------------------------------------------------------------} - --- | A Read-Append-Write (RAW) lock --- --- A RAW lock allows multiple concurrent readers, at most one appender, which --- is allowed to run concurrently with the readers, and at most one writer, --- which has exclusive access to the lock. --- --- The following table summarises which roles are allowed to concurrently --- access the RAW lock: --- --- > │ Reader │ Appender │ Writer │ --- > ─────────┼────────┼──────────┼────────┤ --- > Reader │ V │ V │ X │ --- > Appender │░░░░░░░░│ X │ X │ --- > Writer │░░░░░░░░│░░░░░░░░░░│ X │ --- --- It is important to realise that a RAW lock is intended to control access to --- a piece of in-memory state that should remain in sync with some other state --- that can only be modified using side-effects, e.g., the file system. If, --- for example, you're only maintaining a counter shared by threads, then --- simply use a 'TVar' or an 'MVar'. --- --- = Example use case: log files --- --- A RAW lock is useful, for example, to maintain an in-memory index of log --- files stored on disk. --- --- * To read data from a log file, you need \"read\" access to the index to --- find out the file and offset where the requested piece of data is stored. --- While holding the RAW lock as a reader, you can perform the IO operation --- to read the data from the right log file. This can safely happen --- concurrently with other read operations. --- --- * To append data to the current log file, you need \"append\" access to the --- index so you can append an entry to the index and even to add a new log --- file to the index when necessary. While holding the RAW lock as an --- appender, you can perform the IO operation to append the piece of data to --- the current log file and, if necessary start a new log file. Only one --- append can happen concurrently. However, reads can safely happen --- concurrently with appends. Note that the in-memory index is only updated --- /after/ writing to disk. --- --- * To remove the oldest log files, you need \"write\" access to the index, --- so you can remove files from the index. While holding the RAW lock as a --- writer, you can perform the IO operations to delete the oldest log files. --- No other operations can run concurrently with this operation: concurrent --- reads might try to read from deleted files and a concurrent append could --- try to append to a deleted file. --- --- = Analogy: Chicken coop --- --- Think of readers as chickens, the appender as the rooster, and the writer --- as the fox. All of them want access to the chicken coop, i.e., the state --- protected by the RAW lock. --- --- We can allow multiple chickens (readers) together in the chicken coop, they --- get along (reasonably) fine. We can also let one rooster (appender) in, but --- not more than one, otherwise he would start fighting with the other rooster --- (conflict with the other appender). We can only let the fox in when all --- chickens and the rooster (if present) have left the chicken coop, otherwise --- the fox would eat them (conflict with the appender and invalidate the --- results of readers, e.g, closing resources readers try to access). --- --- = Usage --- --- To use the lock, use any of the three following operations: --- --- * 'withReadAccess' --- * 'withAppendAccess' --- * 'withWriteAccess' --- --- If the standard bracketing the above three operations use doesn't suffice, --- use the following three acquire-release pairs: --- --- * 'unsafeAcquireReadAccess' & 'unsafeReleaseReadAccess' --- * 'unsafeAcquireAppendAccess' & 'unsafeReleaseAppendAccess' --- * 'unsafeAcquireWriteAccess' & 'unsafeReleaseWriteAccess' --- --- NOTE: an acquire __must__ be followed by the corresponding release, --- otherwise the correctness of the lock is not guaranteed and a dead-lock can --- happen. --- --- NOTE: nested locking of the same lock is not allowed, as you might be --- blocked on yourself. --- --- = Notes --- --- * Only use a RAW lock when it is safe to concurrently read and append. --- --- * We do not guarantee fairness for appenders and writers. They will race --- for access each time the RAW lock changes. --- --- * When you have many writers and/or very frequent writes, readers and --- appenders will starve. You could say we have \"unfairness\", as writers --- win over readers and appenders. A RAW lock will not be the best fit in --- such a scenario. --- --- * When you have no writers and you only need a read-append lock, consider --- using a @StrictSVar@ instead. The \"stale\" state can be used by the --- readers. --- --- * The state @st@ is always evaluated to WHNF and is subject to the --- 'NoThunks' check when enabled. --- --- * All public functions are exception-safe. --- -newtype RAWLock m st = RAWLock (StrictTVar m (RAWState st)) -deriving newtype instance (IOLike m, NoThunks st) - => NoThunks (RAWLock m st) - --- | Create a new 'RAWLock' -new :: (IOLike m, NoThunks st) => st -> m (RAWLock m st) -new st = RAWLock <$> newTVarIO (emptyRAWState st) - --- | Access the state stored in the 'RAWLock' as a reader. --- --- Will block when there is a writer or when a writer is waiting to take the --- lock. -withReadAccess :: forall m st a. IOLike m => RAWLock m st -> (st -> m a) -> m a -withReadAccess rawLock = - bracket - (atomically $ unsafeAcquireReadAccess rawLock) - (const (atomically $ unsafeReleaseReadAccess rawLock)) - --- | Access the state stored in the 'RAWLock' as an appender. --- --- NOTE: it must be safe to run the given append action concurrently with --- readers. --- --- Will block when there is another appender, a writer, or when a writer is --- waiting to take the lock. -withAppendAccess :: - forall m st a. IOLike m => RAWLock m st -> (st -> m (st, a)) -> m a -withAppendAccess rawLock k = snd . fst <$> - generalBracket - (atomically $ unsafeAcquireAppendAccess rawLock) - (\acquiredSt exitCase -> - atomically $ unsafeReleaseAppendAccess - rawLock - (stateToPutBack acquiredSt exitCase)) - k - --- | Access the state stored in the 'RAWLock' as a writer. --- --- Will block when there is another writer or while there are readers and/or --- an appender. -withWriteAccess :: - forall m st a. IOLike m => RAWLock m st -> (st -> m (st, a)) -> m a -withWriteAccess rawLock k = snd . fst <$> - generalBracket - (unsafeAcquireWriteAccess rawLock) - (\acquiredSt exitCase -> - unsafeReleaseWriteAccess - rawLock - (stateToPutBack acquiredSt exitCase)) - k - --- | Internal helper -stateToPutBack :: - st -- ^ Acquired state - -> ExitCase (st, a) - -- ^ Result of 'generalBracket', containing the modified state in case of - -- success - -> st -stateToPutBack acquiredSt = \case - ExitCaseSuccess (modifiedSt, _a) -> modifiedSt - ExitCaseException _ex -> acquiredSt - ExitCaseAbort -> acquiredSt - --- | Read the contents of the 'RAWLock' in an STM transaction. --- --- Will retry when there is a writer. --- --- In contrast to 'withReadAccess', this transaction will succeed when there --- is a writer waiting to write, as there is no IO-operation during which the --- lock must be held. -read :: IOLike m => RAWLock m st -> STM m st -read (RAWLock var) = readTVar var >>= \case - ReadAppend _readers _appender st -> return st - WaitingToWrite _readers _appender st -> return st - Writing -> retry - Poisoned (AllowThunk ex) -> throwSTM ex - --- | Poison the lock with the given exception. All subsequent access to the --- lock will result in the given exception being thrown. --- --- Unless the lock has already been poisoned, in which case the original --- exception with which the lock was poisoned will be thrown. -poison :: - (IOLike m, Exception e, HasCallStack) - => RAWLock m st -> (CallStack -> e) -> m (Maybe st) -poison (RAWLock var) mkEx = atomically $ do - rawSt <- readTVar var - (rawSt', mbSt) <- - withPoisoned (poisonPure (toException (mkEx callStack)) rawSt) - writeTVar var rawSt' - return mbSt - -{------------------------------------------------------------------------------- - Exposed internals: non-bracketed acquire & release --------------------------------------------------------------------------------} - -withPoisoned :: MonadThrow m => Except SomeException a -> m a -withPoisoned = either throwIO return . runExcept - --- | Acquire the 'RAWLock' as a reader. --- --- Will block when there is a writer or when a writer is waiting to take the --- lock. --- --- Composable with other 'STM' transactions. --- --- NOTE: __must__ be followed by a call to 'unsafeReleaseReadAccess'. -unsafeAcquireReadAccess :: IOLike m => RAWLock m st -> STM m st -unsafeAcquireReadAccess (RAWLock var) = do - rawSt <- readTVar var - withPoisoned (acquireReadAccessPure rawSt) >>= \case - Nothing -> retry - Just (rawSt', st) -> writeTVar var rawSt' $> st - --- | Release the 'RAWLock' as a reader. --- --- Doesn't block. --- --- Composable with other 'STM' transactions. --- --- NOTE: __must__ be preceded by a call to 'unsafeAcquireReadAccess'. -unsafeReleaseReadAccess :: IOLike m => RAWLock m st -> STM m () -unsafeReleaseReadAccess (RAWLock var) = do - rawSt <- readTVar var - withPoisoned (releaseReadAccessPure rawSt) >>= writeTVar var - --- | Access the state stored in the 'RAWLock' as an appender. --- --- Will block when there is another appender, a writer, or when a writer is --- waiting to take the lock. --- --- Composable with other 'STM' transactions. --- --- NOTE: __must__ be followed by a call to 'unsafeReleaseAppendAccess'. -unsafeAcquireAppendAccess :: IOLike m => RAWLock m st -> STM m st -unsafeAcquireAppendAccess (RAWLock var) = do - rawSt <- readTVar var - withPoisoned (acquireAppendAccessPure rawSt) >>= \case - Nothing -> retry - Just (rawSt', st) -> writeTVar var rawSt' $> st - --- | Release the 'RAWLock' as an appender. --- --- Doesn't block. --- --- Composable with other 'STM' transactions. --- --- NOTE: __must__ be preceded by a call to 'unsafeAcquireAppendAccess'. -unsafeReleaseAppendAccess :: - IOLike m - => RAWLock m st - -> st -- ^ State to store in the lock - -> STM m () -unsafeReleaseAppendAccess (RAWLock var) st = do - rawSt <- readTVar var - withPoisoned (releaseAppendAccessPure st rawSt) >>= writeTVar var - --- | Access the state stored in the 'RAWLock' as a writer. --- --- Will block when there is another writer or while there are readers and\/or --- an appender. --- --- Does /not/ compose with other 'STM' transactions. --- --- NOTE: __must__ be followed by a call to 'unsafeReleaseWriteAccess'. -unsafeAcquireWriteAccess :: IOLike m => RAWLock m st -> m st -unsafeAcquireWriteAccess rawLock@(RAWLock var) = join $ atomically $ do - rawSt <- readTVar var - withPoisoned (acquireWriteAccessPure rawSt) >>= \case - Nothing -> retry - Just (rawSt', mbSt) -> do - writeTVar var rawSt' - -- We must update the value in the var, but we may or may not have - -- obtained the @st@ in it. We must commit the write either way. - case mbSt of - Just st -> return $ return st - -- Return a continuation that tries to acquire again - Nothing -> return $ unsafeAcquireWriteAccess rawLock - --- | Release the 'RAWLock' as a writer. --- --- Doesn't block. --- --- Does /not/ compose with other 'STM' transactions. --- --- NOTE: __must__ be preceded by a call to 'unsafeAcquireWriteAccess'. -unsafeReleaseWriteAccess :: - IOLike m - => RAWLock m st - -> st -- ^ State to store in the lock - -> m () -unsafeReleaseWriteAccess (RAWLock var) st = atomically $ do - rawSt <- readTVar var - withPoisoned (releaseWriteAccessPure st rawSt) >>= writeTVar var - -{------------------------------------------------------------------------------- - Pure internals --------------------------------------------------------------------------------} - --- | Any non-negative number of readers -newtype Readers = Readers Word - deriving newtype (Eq, Ord, Enum, Num, NoThunks) - --- | At most one appender -data Appender = NoAppender | Appender - deriving (Generic, NoThunks) - --- | The lock is implemented by a single 'StrictTVar', which stores a --- 'RAWState'. -data RAWState st = - -- | Reading and/or appending is happening. - ReadAppend !Readers !Appender !st - - -- | A writer (or more than one) has arrived. No new readers or a new - -- appender are allowed, they can only release, not acquire. - -- - -- When the number of readers is 0 and there is no more appender, a writer - -- (multiple writers can race for this) will be able to get exclusive - -- access and will change the state to 'Writing'. - | WaitingToWrite !Readers !Appender !st - - -- | No (more) readers or appender, the writer has exclusive access. - | Writing - - -- | The lock has been poisoned: all subsequent acquires or releases will - -- throw the stored exception. - | Poisoned !(AllowThunk SomeException) - deriving (Generic, NoThunks) - --- | Create an initial, empty, unlocked 'RAWState': no readers, no appender, --- no writer (waiting). -emptyRAWState :: st -> RAWState st -emptyRAWState = ReadAppend (Readers 0) NoAppender - -{------------------------------------------------------------------------------- - Pure internals: transitions between the 'RAWState's --------------------------------------------------------------------------------} - -acquireReadAccessPure :: - RAWState st -> Except SomeException (Maybe (RAWState st, st)) -acquireReadAccessPure = \case - ReadAppend readers appender st - -> return $ Just (ReadAppend (succ readers) appender st, st) - WaitingToWrite {} - -> return Nothing - Writing - -> return Nothing - Poisoned (AllowThunk ex) - -> throwError ex - -releaseReadAccessPure :: - RAWState st -> Except SomeException (RAWState st) -releaseReadAccessPure = \case - ReadAppend readers appender st - | 0 <- readers - -> error "releasing a reader without outstanding readers in ReadAppend" - | otherwise - -> return $ ReadAppend (pred readers) appender st - WaitingToWrite readers appender st - | 0 <- readers - -> error "releasing a reader without outstanding readers in WaitingToWrite" - | otherwise - -> return $ WaitingToWrite (pred readers) appender st - Writing - -> error "releasing a reader without outstanding readers in Writing" - Poisoned (AllowThunk ex) - -> throwError ex - -acquireAppendAccessPure :: - RAWState st -> Except SomeException (Maybe (RAWState st, st)) -acquireAppendAccessPure = \case - ReadAppend readers appender st - | NoAppender <- appender - -> return $ Just (ReadAppend readers Appender st, st) - | otherwise - -> return Nothing - WaitingToWrite {} - -> return Nothing - Writing - -> return Nothing - Poisoned (AllowThunk ex) - -> throwError ex - -releaseAppendAccessPure :: - st -> RAWState st -> Except SomeException (RAWState st) -releaseAppendAccessPure st' = \case - ReadAppend readers appender _st - | NoAppender <- appender - -> error "releasing an appender without an outstanding appender in ReadAppend" - | otherwise - -> return $ ReadAppend readers NoAppender st' - WaitingToWrite readers appender _st - | NoAppender <- appender - -> error "releasing an appender without an outstanding appender in WaitingToWrite" - | otherwise - -> return $ WaitingToWrite readers NoAppender st' - Writing - -> error "releasing an appender without an outstanding appender in Writing" - Poisoned (AllowThunk ex) - -> throwError ex - -acquireWriteAccessPure :: - RAWState st -> Except SomeException (Maybe (RAWState st, Maybe st)) -acquireWriteAccessPure = \case - -- When there are no readers or appender in the 'ReadAppend' we can - -- directly go to the 'Writing' state, if not, we'll go to the - -- intermediary 'WaitingToWrite' state until they have all released. - ReadAppend readers appender st - | 0 <- readers - , NoAppender <- appender - -> return $ Just (Writing, Just st) - | otherwise - -> return $ Just (WaitingToWrite readers appender st, Nothing) - WaitingToWrite readers appender st - | 0 <- readers - , NoAppender <- appender - -> return $ Just (Writing, Just st) - | otherwise - -> return Nothing - Writing - -> return Nothing - Poisoned (AllowThunk ex) - -> throwError ex - -releaseWriteAccessPure :: - st -> RAWState st -> Except SomeException (RAWState st) -releaseWriteAccessPure st' = \case - ReadAppend _readers _appender _st - -> error "releasing a writer in ReadAppend" - WaitingToWrite _readers _appender _st - -> error "releasing a writer in WaitingToWrite" - Writing - -> return $ emptyRAWState st' - Poisoned (AllowThunk ex) - -> throwError ex - -poisonPure :: - SomeException -> RAWState st -> Except SomeException (RAWState st, Maybe st) -poisonPure ex = \case - ReadAppend _readers _appender st - -> return (Poisoned (AllowThunk ex), Just st) - WaitingToWrite _readers _appender st - -> return (Poisoned (AllowThunk ex), Just st) - Writing - -> return (Poisoned (AllowThunk ex), Nothing) - Poisoned (AllowThunk prevEx) - -> throwError prevEx diff --git a/ouroboros-consensus/test/consensus-test/Main.hs b/ouroboros-consensus/test/consensus-test/Main.hs index 3d044cec75..9e1b408935 100644 --- a/ouroboros-consensus/test/consensus-test/Main.hs +++ b/ouroboros-consensus/test/consensus-test/Main.hs @@ -12,7 +12,6 @@ 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.NormalForm (tests) -import qualified Test.Consensus.Util.MonadSTM.RAWLock (tests) import qualified Test.Consensus.Util.Versioned (tests) import Test.Tasty import Test.Util.TestEnv (defaultMainWithTestEnv, @@ -32,7 +31,6 @@ tests = , Test.Consensus.Mempool.tests , Test.Consensus.Mempool.Fairness.tests , Test.Consensus.ResourceRegistry.tests - , Test.Consensus.Util.MonadSTM.RAWLock.tests , Test.Consensus.Util.MonadSTM.NormalForm.tests , Test.Consensus.Util.Versioned.tests , testGroup "HardFork" [ 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 deleted file mode 100644 index f98d15d499..0000000000 --- a/ouroboros-consensus/test/consensus-test/Test/Consensus/Util/MonadSTM/RAWLock.hs +++ /dev/null @@ -1,268 +0,0 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NumericUnderscores #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Tests for the RAW lock mechanism. --- --- The volatile DB uses an abstraction we call a @RAWLock@, a lock that allows --- the following combinations of readers, appender and writer: --- --- --- > │ Reader │ Appender │ Writer │ --- > ─────────┼────────┼──────────┼────────┤ --- > Reader │ V │ V │ X │ --- > Appender │░░░░░░░░│ X │ X │ --- > Writer │░░░░░░░░│░░░░░░░░░░│ X │ --- --- It improves concurrent access. In the test we generate lots of threads, some --- readers, some appenders, some writers, each concurrently accessing some data --- protected by the lock. We then record the access pattern; the test would fail --- if at any point it would see a forbidden combination (for example, a writer --- and a reader both having access at the same time). --- -module Test.Consensus.Util.MonadSTM.RAWLock (tests) where - -import Control.Exception (throw) -import Control.Monad.Except -import Control.Monad.IOSim (IOSim, SimEventType (..), SimTrace, - runSimTrace, selectTraceEvents, traceResult) -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 -import Test.Tasty -import Test.Tasty.QuickCheck -import Test.Util.Orphans.IOLike () - -tests :: TestTree -tests = testProperty "RAWLock correctness" prop_RAWLock_correctness - --- | Test the correctness of the RAWLock --- --- For a generated number of readers, appenders, and writers: spawn a thread --- for each. Each thread will process a list of 'ThreadDelays'. For each --- 'ThreadDelays': wait the generated 'beforeLockTime', then lock the RAWLock --- with the respective @RAWLock.withXAccess@, increment a 'TVar' that stores --- the number of readers/appenders/writers that have access, hold the lock for --- a generated 'withLockTime', decrement the 'TVar', and release the lock. --- --- In a separate thread, we watch for any changes in the three 'TVar's and --- write each changed 'RAWState' to a trace (in a separate 'TVar'). --- Afterwards, we check the 'RAWState's in the trace for consistency (using --- 'isConsistent'), e.g., not more than one concurrent appender. -prop_RAWLock_correctness :: TestSetup -> Property -prop_RAWLock_correctness (TestSetup rawDelays) = - monadicSimWithTrace tabulateBlockeds test - where - RAW readerDelays appenderDelays writerDelays = rawDelays - - test :: forall m. IOLike m => PropertyM m () - test = do - rawVars@(RAW varReaders varAppenders varWriters) <- run newRAWVars - - trace <- run $ withRegistry $ \registry -> do - rawLock <- RAWLock.new () - varTrace <- uncheckedNewTVarM [] - - let traceState :: STM m () - traceState = do - rawState <- readRAWState rawVars - modifyTVar varTrace (rawState:) - - threads <- mapM (forkLinkedThread registry "testThread") $ - map (runReader rawLock traceState varReaders) readerDelays <> - map (runAppender rawLock traceState varAppenders) appenderDelays <> - map (runWriter rawLock traceState varWriters) writerDelays - - mapM_ waitThread threads - reverse <$> atomically (readTVar varTrace) - - checkRAWTrace trace - - runReader - :: IOLike m - => RAWLock m () - -> STM m () -- ^ Trace the 'RAWState' - -> StrictTVar m Int - -> [ThreadDelays] - -> m () - runReader rawLock traceState varReaders = - mapM_ $ \(ThreadDelays before with) -> do - threadDelay before - RAWLock.withReadAccess rawLock $ const $ do - atomically $ modifyTVar varReaders succ *> traceState - threadDelay with - atomically $ modifyTVar varReaders pred *> traceState - - runAppender - :: IOLike m - => RAWLock m () - -> STM m () -- ^ Trace the 'RAWState' - -> StrictTVar m Int - -> [ThreadDelays] - -> m () - runAppender rawLock traceState varAppenders = - mapM_ $ \(ThreadDelays before with) -> do - threadDelay before - RAWLock.withAppendAccess rawLock $ const $ do - atomically $ modifyTVar varAppenders succ *> traceState - threadDelay with - atomically $ modifyTVar varAppenders pred *> traceState - return ((), ()) - - runWriter - :: IOLike m - => RAWLock m () - -> STM m () -- ^ Trace the 'RAWState' - -> StrictTVar m Int - -> [ThreadDelays] - -> m () - runWriter rawLock traceState varWriters = - mapM_ $ \(ThreadDelays before with) -> do - threadDelay before - RAWLock.withWriteAccess rawLock $ const $ do - atomically $ modifyTVar varWriters succ *> traceState - threadDelay with - atomically $ modifyTVar varWriters pred *> traceState - return ((), ()) - --- | Like 'monadicSim' (which is like 'monadicIO' for the IO simulator), but --- allows inspecting the trace for labelling purposes. -monadicSimWithTrace :: - Testable a - => (forall x. SimTrace x -> Property -> Property) - -> (forall s. PropertyM (IOSim s) a) - -> Property -monadicSimWithTrace attachTrace m = property $ do - tr <- runSimGenWithTrace (monadic' m) - case traceResult False tr of - Left failure -> throw failure - Right prop -> return $ attachTrace tr prop - where - runSimGenWithTrace :: (forall s. Gen (IOSim s a)) -> Gen (SimTrace a) - runSimGenWithTrace f = do - Capture eval <- capture - return $ runSimTrace (eval f) - --- | Tabulate the number of times a thread is blocked. --- --- The higher this number, the higher the contention. If there's no --- contention, we're not testing the lock properly. -tabulateBlockeds :: SimTrace a -> Property -> Property -tabulateBlockeds tr = - tabulate "number of times blocked" [classifyBand (count isBlocked tr)] - where - isBlocked (EventTxBlocked {}) = Just () - isBlocked _ = Nothing - - count :: (SimEventType -> Maybe x) -> SimTrace a -> Int - count p = length . selectTraceEvents (const p) - - classifyBand :: Int -> String - classifyBand n - | n < 10 - = "n < 10" - | n < 100 - = "n < 100" - | n < 1000 - = "n < 1,000" - | n < 10_000 - = "1,000 < n < 10,000" - | n < 100_000 - = "10,000 < n < 100,000" - | n < 1000_000 - = "100,000 < n < 1,000,000" - | otherwise - = "1,000,000 < n" - -{------------------------------------------------------------------------------- - State checking --------------------------------------------------------------------------------} - --- | Data type reused whenever we need something for all three of them. -data RAW a = RAW - { readers :: a - , appenders :: a - , writers :: a - } - deriving (Show, Eq, Functor) - -type RAWVars m = RAW (StrictTVar m Int) - -newRAWVars :: IOLike m => m (RAWVars m) -newRAWVars = RAW <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 - -type RAWState = RAW Int - -readRAWState :: IOLike m => RAWVars m -> STM m RAWState -readRAWState RAW { readers, appenders, writers } = - RAW - <$> readTVar readers - <*> readTVar appenders - <*> readTVar writers - -isConsistent :: RAWState -> Except String () -isConsistent RAW { readers, appenders, writers } - | appenders > 1 - = throwError $ show appenders <> " appenders while at most 1 is allowed" - | writers > 1 - = throwError $ show writers <> " writers while at most 1 is allowed" - | writers == 1, readers > 0 - = throwError $ "writer concurrent with " <> show readers <> "reader(s)" - | writers == 1, appenders > 0 - = throwError $ "writer concurrent with an appender" - | otherwise - = return () - -type RAWTrace = [RAWState] - -checkRAWTrace :: Monad m => RAWTrace -> PropertyM m () -checkRAWTrace = mapM_ $ \rawState -> - case runExcept $ isConsistent rawState of - Left msg -> do - monitor (counterexample msg) - assert False - Right () -> - return () - -{------------------------------------------------------------------------------- - Generators --------------------------------------------------------------------------------} - -newtype TestSetup = TestSetup (RAW [[ThreadDelays]]) - deriving (Show) - -instance Arbitrary TestSetup where - arbitrary = do - nbReaders <- choose (0, 3) - nbAppenders <- choose (0, 3) - nbWriters <- choose (0, 3) - readers <- vectorOf nbReaders arbitrary - appenders <- vectorOf nbAppenders arbitrary - writers <- vectorOf nbWriters arbitrary - return $ TestSetup RAW { readers, appenders, writers } - shrink (TestSetup raw@RAW { readers, appenders, writers }) = - [TestSetup raw { readers = readers' } | readers' <- shrink readers ] <> - [TestSetup raw { appenders = appenders' } | appenders' <- shrink appenders] <> - [TestSetup raw { writers = writers' } | writers' <- shrink writers ] - -data ThreadDelays = ThreadDelays - { beforeLockTime :: DiffTime - -- ^ How long the thread should wait before it starts to take the lock - , withLockTime :: DiffTime - -- ^ How long the thread should wait while holding the lock - } - deriving (Eq, Show) - -instance Arbitrary ThreadDelays where - arbitrary = do - beforeLockTime <- picosecondsToDiffTime <$> choose (0, 1000) - withLockTime <- picosecondsToDiffTime <$> choose (0, 2000) - return ThreadDelays { beforeLockTime, withLockTime }