diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# rawlock Changelog + +# Changelog entries + +## 0.1.0.0 -- 2024-10-22 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,177 @@ + + 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 diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -0,0 +1,13 @@ +Copyright 2024 INTERSECT + + 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# RAWLock + +A writer-biased RAW lock. + +It allows for multiple readers to run concurrently with at most one appender, or +a single writer running on isolation. + +The code is safe in the presence of async exceptions, meaning that each actor +will cleanup after itself if an exception is received. + +## Contributing + +Contributions are welcome! Feel free to open issues or submit pull requests. + +Before contributing, please ensure that: + +- Code is well-documented +- Tests are written for new features or bug fixes + +## License + +This project is licensed under the terms of the [Apache 2.0](./LICENSE) license. diff --git a/rawlock.cabal b/rawlock.cabal new file mode 100644 --- /dev/null +++ b/rawlock.cabal @@ -0,0 +1,83 @@ +cabal-version: 3.0 +name: rawlock +version: 0.1.0.0 +synopsis: A writer-biased RAW lock. +description: + A writer-biased RAW lock. + + It allows for multiple readers to run concurrently with at most one + appender, or a single writer running on isolation. + + The code is safe in the presence of async exceptions, meaning that each + actor will cleanup after itself if an exception is received. + +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +copyright: 2024 INTERSECT +author: IOG Engineering Team +maintainer: operations@iohk.io +category: Concurrency +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +bug-reports: https://github.com/IntersectMBO/io-classes-extra/issues +tested-with: ghc ==8.10 || ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 + +source-repository head + type: git + location: https://github.com/IntersectMBO/io-classes-extra + subdir: rawlock + +source-repository this + type: git + location: https://github.com/IntersectMBO/io-classes-extra + subdir: rawlock + tag: rawlock-0.1.0.0 + +common warnings + ghc-options: + -Wall + -Wunused-packages + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + -Wno-unticked-promoted-constructors + +library + import: warnings + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Control.RAWLock + default-extensions: ImportQualifiedPost + build-depends: + base >=4.14 && <4.21, + io-classes ^>=1.5, + nothunks ^>=0.2, + strict-mvar ^>=1.5, + strict-stm ^>=1.5, + +test-suite rawlock-test + import: warnings + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + QuickCheck, + base, + io-classes, + io-sim, + mtl, + rawlock, + strict-stm, + tasty, + tasty-quickcheck, diff --git a/src/Control/RAWLock.hs b/src/Control/RAWLock.hs new file mode 100644 --- /dev/null +++ b/src/Control/RAWLock.hs @@ -0,0 +1,403 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | 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. Once the lock is released, all waiting +-- actors will race for the access. +-- +-- * The state @st@ is always evaluated to WHNF and is subject to the +-- 'NoThunks' check when enabled. +-- +-- * All public functions are exception-safe. +module Control.RAWLock ( + -- * API + RAWLock + , new + , poison + , read + , withAppendAccess + , withReadAccess + , withWriteAccess + -- * Unsafe API + -- $unsafe-api + , unsafeAcquireAppendAccess + , unsafeAcquireReadAccess + , unsafeAcquireWriteAccess + , unsafeReleaseAppendAccess + , unsafeReleaseReadAccess + , unsafeReleaseWriteAccess + ) where + +import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Monad.Class.MonadThrow +import GHC.Generics +import GHC.Stack (CallStack, HasCallStack, callStack) +import NoThunks.Class +import Prelude hiding (read) + +-- | Any non-negative number of readers +newtype Readers = Readers Word + deriving newtype (Eq, Ord, Enum, Num, NoThunks) + deriving stock (Show) + +-- | Any non-negative number of writers +newtype Writers = Writers Word + deriving newtype (Eq, Ord, Enum, Num, NoThunks) + deriving stock (Show) + +-- | Any non-negative number of appenders +newtype Appenders = Appenders Word + deriving newtype (Eq, Ord, Enum, Num, NoThunks) + deriving stock (Show) + +data RAWState = RAWState { + waitingReaders :: !Readers + , waitingAppenders :: !Appenders + , waitingWriters :: !Writers + } deriving Show + +noWriters :: Poisonable RAWState -> Bool +noWriters (Healthy (RAWState _ _ w)) = w == 0 +noWriters _ = True + +onlyWriters :: Poisonable RAWState -> Bool +onlyWriters (Healthy (RAWState r a _)) = r == 0 && a == 0 +onlyWriters _ = True + +pushReader :: Poisonable RAWState -> Poisonable RAWState +pushReader = fmap (\(RAWState r a w) -> RAWState (r + 1) a w) + +pushAppender :: Poisonable RAWState -> Poisonable RAWState +pushAppender = fmap (\(RAWState r a w) -> RAWState r (a + 1) w) + +pushWriter :: Poisonable RAWState -> Poisonable RAWState +pushWriter = fmap (\(RAWState r a w) -> RAWState r a (w + 1)) + +popReader :: Poisonable RAWState -> Poisonable RAWState +popReader = fmap (\(RAWState r a w) -> RAWState (r - 1) a w) + +popAppender :: Poisonable RAWState -> Poisonable RAWState +popAppender = fmap (\(RAWState r a w) -> RAWState r (a - 1) w) + +popWriter :: Poisonable RAWState -> Poisonable RAWState +popWriter = fmap (\(RAWState r a w) -> RAWState r a (w - 1)) + +-- | Data that can be replaced with an exception that should be thrown when +-- found. +data Poisonable st = + Healthy !st + | Poisoned !(AllowThunk SomeException) + deriving (Generic, NoThunks, Functor) + +data RAWLock m st = RAWLock { + resource :: !(StrictTMVar m (Poisonable st)) + , appender :: !(StrictMVar m ()) + , queues :: !(StrictTVar m (Poisonable RAWState)) + } deriving (Generic) + +deriving instance ( NoThunks (StrictTMVar m (Poisonable st)) + , NoThunks (StrictMVar m ()) + , NoThunks (StrictTVar m (Poisonable RAWState)) + ) => NoThunks (RAWLock m st) + +new :: + ( MonadMVar m + , MonadLabelledSTM m + ) + => st + -> m (RAWLock m st) +new !st = do + s <- newTMVarIO (Healthy st) + atomically $ labelTMVar s "state" + a <- newMVar () + q <- newTVarIO (Healthy emptyRAWState) + atomically $ labelTVar q "queues" + pure $ RAWLock s a q + +read :: (MonadSTM m, MonadThrow (STM m)) => RAWLock m st -> STM m st +read (RAWLock var _ _) = readTMVar var >>= throwPoisoned + +-- | When a lock is poisoned all subsequent access to it is overridden by the +-- poison. This means that the current actor that holds the lock will free it, +-- and any other concurrent actors will be able to release their access, +-- possibly rising the poison exception in the process. +-- +-- There is no need (although it is harmless) to release again the current +-- actor once it has poisoned the lock. +poison :: + (Exception e, MonadMVar m, MonadSTM m, MonadThrow (STM m), HasCallStack) + => RAWLock m st + -> (CallStack -> e) + -> m (Maybe st) +poison (RAWLock var apm q) mkExc = do + st <- atomically $ + tryReadTMVar var >>= \case + -- Keep original exception + Just (Poisoned (AllowThunk exc)) -> throwIO exc + Just (Healthy st) -> do + writeTMVar var (Poisoned (AllowThunk (toException (mkExc callStack)))) + writeTVar q (Poisoned (AllowThunk (toException (mkExc callStack)))) + pure (Just st) + Nothing -> do + writeTMVar var (Poisoned (AllowThunk (toException (mkExc callStack)))) + writeTVar q (Poisoned (AllowThunk (toException (mkExc callStack)))) + pure Nothing + _ <- tryPutMVar apm () + pure st + +-- | Create an initial, empty, unlocked 'RAWState': no readers, no appender, +-- no writer (waiting). +emptyRAWState :: RAWState +emptyRAWState = RAWState 0 0 0 + +-- | Acquire the 'RAWLock' as a reader. +-- +-- Will block when there is a writer or when a writer is waiting to take the +-- lock. +withReadAccess :: + (MonadSTM m, MonadCatch m, MonadThrow (STM m)) + => RAWLock m st + -> (st -> m a) + -> m a +withReadAccess lock = + bracket + (atomically (unsafeAcquireReadAccess lock)) + (const (atomically (unsafeReleaseReadAccess lock))) + +-- | Acquire the 'RAWLock' as a writer. +-- +-- Will block when there is another writer, readers or appenders. +withWriteAccess :: + (MonadSTM m, MonadCatch m, MonadThrow (STM m)) + => RAWLock m st + -> (st -> m (a, st)) + -> m a +withWriteAccess lock f = + fst . fst <$> generalBracket + (unsafeAcquireWriteAccess lock) + (\orig -> \case + ExitCaseSuccess (_, st) -> unsafeReleaseWriteAccess lock st + _ -> unsafeReleaseWriteAccess lock orig + ) + f + +-- | Acquire the 'RAWLock' as an appender. +-- +-- Will block when there is a writer or when there is another appender. +withAppendAccess :: + (MonadThrow (STM m), MonadSTM m, MonadCatch m, MonadMVar m) + => RAWLock m st + -> (st -> m (a, st)) + -> m a +withAppendAccess lock f = do + fst . fst <$> generalBracket + (unsafeAcquireAppendAccess lock) + (\orig -> \case + ExitCaseSuccess (_, st) -> unsafeReleaseAppendAccess lock st + _ -> unsafeReleaseAppendAccess lock orig + ) + f + +{------------------------------------------------------------------------------- + Unsafe API +-------------------------------------------------------------------------------} + +throwPoisoned :: MonadThrow m => Poisonable st -> m st +throwPoisoned (Healthy st) = pure st +throwPoisoned (Poisoned (AllowThunk exc)) = throwIO exc + +-- $unsafe-api +-- +-- These functions are unsafe in the sense that they do not guard against +-- exceptions, meaning that if you don't take care and ensure exception safety, +-- you might make the RAWLock unusable. +-- +-- To be safe, you should ensure that every @unsafeAcquireXAccess@ is paired with +-- @unsafeReleaseXAccess@, __even in the presence of exceptions__. +-- +-- Note that for writing and appending, you should restore the original value in +-- presence of an exception! + +unsafeAcquireReadAccess :: + (MonadThrow (STM m), MonadSTM m) + => RAWLock m st + -> STM m st +unsafeAcquireReadAccess (RAWLock var _ qs) = do + -- wait until there are no writers + readTVar qs >>= check . noWriters + -- queue myself + modifyTVar qs pushReader + -- read the state + throwPoisoned =<< readTMVar var + +unsafeReleaseReadAccess :: MonadSTM m => RAWLock m st -> STM m () +unsafeReleaseReadAccess (RAWLock _ _ qs) = + -- unqueue myself + modifyTVar qs popReader + +unsafeAcquireWriteAccess :: + (MonadThrow (STM m), MonadCatch m, MonadSTM m) + => RAWLock m st + -> m st +unsafeAcquireWriteAccess (RAWLock var _ qs) = do + -- queue myself if there are no other writers + atomically $ do + -- wait until there are no writers + readTVar qs >>= check . noWriters + -- queue myself + modifyTVar qs pushWriter + atomically (do + -- wait until there are no readers (and as I queued myself above, I'm the + -- only waiting writer) + readTVar qs >>= check . onlyWriters + -- acquire the state + throwPoisoned =<< takeTMVar var) `onException` atomically (modifyTVar qs popWriter) + +unsafeReleaseWriteAccess :: + (MonadThrow (STM m), MonadSTM m) + => RAWLock m st + -> st + -> m () +unsafeReleaseWriteAccess (RAWLock var _ qs) !st = + atomically $ do + -- write the new state + tryReadTMVar var >>= \case + Nothing -> putTMVar var (Healthy st) + Just (Poisoned (AllowThunk exc)) -> throwIO exc + Just Healthy{} -> error "Double put" + -- unqueue myself + modifyTVar qs popWriter + +unsafeAcquireAppendAccess :: + (MonadThrow (STM m), MonadCatch m, MonadMVar m, MonadSTM m) + => RAWLock m st + -> m st +unsafeAcquireAppendAccess (RAWLock var apm qs) = do + atomically $ do + -- wait until there are no writers + readTVar qs >>= check . noWriters + -- queue myself + modifyTVar qs pushAppender + (do + -- lock the append access + takeMVar apm + -- acquire the state + atomically (readTMVar var >>= throwPoisoned) `onException` putMVar apm () + ) `onException` atomically (modifyTVar qs popAppender) + +unsafeReleaseAppendAccess :: + (MonadThrow (STM m), MonadMVar m, MonadSTM m) + => RAWLock m st + -> st + -> m () +unsafeReleaseAppendAccess (RAWLock var apm qs) !st = do + atomically $ do + -- write the new state + tryReadTMVar var >>= \case + Just (Poisoned (AllowThunk exc)) -> throwIO exc + _ -> writeTMVar var (Healthy st) + -- unqueue myself + modifyTVar qs popAppender + -- release the append access + putMVar apm () diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,337 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Control.Concurrent.Class.MonadSTM.Strict +import Control.Exception (throw) +import Control.Monad.Class.MonadAsync +import Control.Monad.Class.MonadFork +import Control.Monad.Class.MonadSay +import Control.Monad.Class.MonadTest +import Control.Monad.Class.MonadThrow +import Control.Monad.Class.MonadTimer +import Control.Monad.Except +import Control.Monad.IOSim +import Control.RAWLock +import Data.Either +import Test.QuickCheck.Gen.Unsafe +import Test.QuickCheck.Monadic +import Test.Tasty +import Test.Tasty.QuickCheck + +main :: IO () +main = defaultMain $ testGroup "RAWLock" [ + testProperty "Exception safe" $ conjoin (map prop_exception_safe allCommandCombinations) + , testProperty "correctness" prop_correctness + , testProperty "unsafe functions do not deadlock" $ conjoin (map prop_unsafe_actions allCommandCombinations) + ] + +{------------------------------------------------------------------------------- + Exception safe +-------------------------------------------------------------------------------} + +data Action = Read | Incr | Append + deriving (Show) + +allCommandCombinations :: [(Action, Action, Action)] +allCommandCombinations = + [ (a, b, c) | let cmds = [Read, Incr, Append], a <- cmds, b <- cmds, c <- cmds ] + +prop_exception_safe :: (Action, Action, Action) -> Property +prop_exception_safe actions@(a1, a2, a3) = counterexample (show actions) $ + exploreSimTrace id action + (\_ tr -> counterexample (ppTrace tr) . property . isRight . traceResult False $ tr) + where + action :: IOSim s () + action = do + exploreRaces + l <- new (0 :: Int) + let c = \case + Read -> withReadAccess l $ \s -> say (show s) + Incr -> withWriteAccess l $ \s -> say (show s) >> pure ((), s + 1) + Append -> withAppendAccess l $ \s -> say (show s) >> pure ((), s + 1) + t1 <- async $ c a1 + t2 <- async $ c a2 + t3 <- async $ c a3 + async (cancel t1) >>= wait + (_ :: Either SomeException ()) <- waitCatch t1 + (_ :: Either SomeException ()) <- waitCatch t2 + (_ :: Either SomeException ()) <- waitCatch t3 + pure () + +{------------------------------------------------------------------------------- + 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_correctness :: TestSetup -> Property +prop_correctness (TestSetup rawDelays) = + monadicSimWithTrace tabulateBlockeds test + where + RAW readerDelays appenderDelays writerDelays = rawDelays + + test :: forall s. PropertyM (IOSim s) () + test = do + rawVars@(RAW varReaders varAppenders varWriters) <- run newRAWVars + + trace <- run $ do + rawLock <- new () + varTrace <- newTVarIO [] + + let traceState :: STM (IOSim s) () + traceState = do + rawState <- readRAWState rawVars + modifyTVar varTrace (rawState:) + + threads <- mapM (async . (labelThisThread "testThread" >>)) $ + map (runReader rawLock traceState varReaders) readerDelays <> + map (runAppender rawLock traceState varAppenders) appenderDelays <> + map (runWriter rawLock traceState varWriters) writerDelays + + mapM_ wait threads + reverse <$> atomically (readTVar varTrace) + + checkRAWTrace trace + + runReader + :: RAWLock (IOSim s) () + -> STM (IOSim s) () -- ^ Trace the 'RAWState' + -> StrictTVar (IOSim s) Int + -> [ThreadDelays] + -> IOSim s () + runReader rawLock traceState varReaders = + mapM_ $ \(ThreadDelays before with) -> do + threadDelay before + withReadAccess rawLock $ const $ do + atomically $ modifyTVar varReaders succ *> traceState + threadDelay with + atomically $ modifyTVar varReaders pred *> traceState + + runAppender + :: RAWLock (IOSim s) () + -> STM (IOSim s) () -- ^ Trace the 'RAWState' + -> StrictTVar (IOSim s) Int + -> [ThreadDelays] + -> IOSim s () + runAppender rawLock traceState varAppenders = + mapM_ $ \(ThreadDelays before with) -> do + threadDelay before + withAppendAccess rawLock $ const $ do + atomically $ modifyTVar varAppenders succ *> traceState + threadDelay with + atomically $ modifyTVar varAppenders pred *> traceState + return ((), ()) + + runWriter + :: RAWLock (IOSim s) () + -> STM (IOSim s) () -- ^ Trace the 'RAWState' + -> StrictTVar (IOSim s) Int + -> [ThreadDelays] + -> IOSim s () + runWriter rawLock traceState varWriters = + mapM_ $ \(ThreadDelays before with) -> do + threadDelay before + 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 :: IOSim s (RAWVars (IOSim s)) +newRAWVars = RAW <$> newTVarIO 0 <*> newTVarIO 0 <*> newTVarIO 0 + +type RAWState' = RAW Int + +readRAWState :: RAWVars (IOSim s) -> STM (IOSim s) 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) + Test.QuickCheck.Monadic.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 :: Int + -- ^ How long the thread should wait before it starts to take the lock + , withLockTime :: Int + -- ^ How long the thread should wait while holding the lock + } + deriving (Eq, Show) + +instance Arbitrary ThreadDelays where + arbitrary = do + beforeLockTime <- choose (0, 1000) + withLockTime <- choose (0, 2000) + return ThreadDelays { beforeLockTime, withLockTime } + +{------------------------------------------------------------------------------- + unsafe functions +-------------------------------------------------------------------------------} + +prop_unsafe_actions :: (Action, Action, Action) -> Property +prop_unsafe_actions actions@(a1, a2, a3) = counterexample (show actions) $ + exploreSimTrace id action + (\_ tr -> counterexample (ppTrace tr) . property . isRight . traceResult False $ tr) + where + action :: IOSim s () + action = do + exploreRaces + l <- new (0 :: Int) + let c = \case + Read -> bracket + (atomically (unsafeAcquireReadAccess l)) + (const $ atomically (unsafeReleaseReadAccess l)) + (say . ("Read: " <>) . show) + Incr -> generalBracket + (unsafeAcquireWriteAccess l) + (\orig -> \case + ExitCaseSuccess s' -> unsafeReleaseWriteAccess l s' + _ -> unsafeReleaseWriteAccess l orig + ) + (\s -> do + say ("Incr: " <> show s) + pure (s + 1) + ) >> pure () + Append -> generalBracket + (unsafeAcquireAppendAccess l) + (\orig -> \case + ExitCaseSuccess s' -> unsafeReleaseAppendAccess l s' + _ -> unsafeReleaseAppendAccess l orig + ) + (\s -> do + say ("Append: " <> show s) + pure (s + 1) + ) >> pure () + t1 <- async $ c a1 + t2 <- async $ c a2 + t3 <- async $ c a3 + async (cancel t1) >>= wait + (_ :: Either SomeException ()) <- waitCatch t1 + (_ :: Either SomeException ()) <- waitCatch t2 + (_ :: Either SomeException ()) <- waitCatch t3 + pure ()