rawlock (empty) → 0.1.0.0

raw patch · 7 files changed

+1042/−0 lines, 7 filesdep +QuickCheckdep +basedep +io-classes

Dependencies added: QuickCheck, base, io-classes, io-sim, mtl, nothunks, rawlock, strict-mvar, strict-stm, tasty, tasty-quickcheck

Files

• CHANGELOG.md +7/−0
• LICENSE +177/−0
• NOTICE +13/−0
• README.md +22/−0
• rawlock.cabal +83/−0
• src/Control/RAWLock.hs +403/−0
• test/Main.hs +337/−0

@@ -0,0 +1,7 @@+# rawlock Changelog++# Changelog entries++## 0.1.0.0 -- 2024-10-22++* First version. Released on an unsuspecting world.

@@ -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

@@ -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.

@@ -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.

@@ -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,

@@ -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 ()

@@ -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 ()