-
Notifications
You must be signed in to change notification settings - Fork 220
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Browse files
Browse the repository at this point in the history
…coin-selection-lock
- Loading branch information
Showing
6 changed files
with
210 additions
and
3 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,88 @@ | ||
| {-# LANGUAGE NamedFieldPuns #-} | ||
| {-# LANGUAGE RankNTypes #-} | ||
|
|
||
| {- HLINT ignore "Use newtype instead of data" -} | ||
|
|
||
| -- | | ||
| -- Copyright: © 2021 IOHK | ||
| -- License: Apache-2.0 | ||
| -- | ||
| -- This module provides a utility for ordering concurrent actions | ||
| -- via locks. | ||
| module Control.Concurrent.Concierge | ||
| ( Concierge | ||
| , newConcierge | ||
| , atomicallyWith | ||
| , atomicallyWithLifted | ||
| ) | ||
| where | ||
|
|
||
| import Prelude | ||
|
|
||
| import Control.Monad.Class.MonadFork | ||
| ( MonadThread, ThreadId, myThreadId ) | ||
| import Control.Monad.Class.MonadSTM | ||
| ( MonadSTM | ||
| , TVar | ||
| , atomically | ||
| , modifyTVar | ||
| , newTVarIO | ||
| , readTVar | ||
| , retry | ||
| , writeTVar | ||
| ) | ||
| import Control.Monad.Class.MonadThrow | ||
| ( MonadThrow, bracket ) | ||
| import Control.Monad.IO.Class | ||
| ( MonadIO, liftIO ) | ||
| import Data.Map.Strict | ||
| ( Map ) | ||
|
|
||
| import qualified Data.Map.Strict as Map | ||
|
|
||
| {------------------------------------------------------------------------------- | ||
| Concierge | ||
| -------------------------------------------------------------------------------} | ||
| -- | At a 'Concierge', you can obtain a lock and | ||
| -- enforce sequential execution of concurrent 'IO' actions. | ||
| -- | ||
| -- Back in the old days, hotel concierges used to give out keys. | ||
| -- But after the cryptocurrency revolution, they give out locks. :) | ||
| -- (The term /lock/ is standard terminology in concurrent programming.) | ||
| data Concierge m lock = Concierge | ||
| { locks :: TVar m (Map lock (ThreadId m)) | ||
| } | ||
|
|
||
| -- | Create a new 'Concierge' that keeps track of locks. | ||
| newConcierge :: MonadSTM m => m (Concierge m lock) | ||
| newConcierge = Concierge <$> newTVarIO Map.empty | ||
|
|
||
| -- | Obtain a lock from a 'Concierge' and run an 'IO' action. | ||
| -- | ||
| -- If the same (equal) lock is already taken at this 'Concierge', | ||
| -- the thread will be blocked until the lock becomes available. | ||
| -- | ||
| -- The action may throw a synchronous or asynchronous exception. | ||
| -- In both cases, the lock is returned to the concierge. | ||
| atomicallyWith | ||
| :: (Ord lock, MonadIO m, MonadThrow m) | ||
| => Concierge IO lock -> lock -> m a -> m a | ||
| atomicallyWith = atomicallyWithLifted liftIO | ||
|
|
||
| -- | More polymorphic version of 'atomicallyWith'. | ||
| atomicallyWithLifted | ||
| :: (Ord lock, MonadSTM m, MonadThread m, MonadThrow n) | ||
| => (forall b. m b -> n b) | ||
| -> Concierge m lock -> lock -> n a -> n a | ||
| atomicallyWithLifted lift Concierge{locks} lock action = | ||
| bracket acquire (const release) (const action) | ||
| where | ||
| acquire = lift $ do | ||
| tid <- myThreadId | ||
| atomically $ do | ||
| ls <- readTVar locks | ||
| case Map.lookup lock ls of | ||
| Just _ -> retry | ||
| Nothing -> writeTVar locks $ Map.insert lock tid ls | ||
| release = lift $ | ||
| atomically $ modifyTVar locks $ Map.delete lock |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| Original file line number | Diff line number | Diff line change |
|---|---|---|
| @@ -0,0 +1,83 @@ | ||
| {-# LANGUAGE RankNTypes #-} | ||
| module Control.Concurrent.ConciergeSpec | ||
| ( spec | ||
| ) where | ||
|
|
||
| import Prelude | ||
|
|
||
| import Control.Concurrent.Concierge | ||
| ( atomicallyWithLifted, newConcierge ) | ||
| import Control.Monad.Class.MonadFork | ||
| ( forkIO ) | ||
| import Control.Monad.Class.MonadSay | ||
| ( say ) | ||
| import Control.Monad.Class.MonadTimer | ||
| ( threadDelay ) | ||
| import Control.Monad.IOSim | ||
| ( IOSim, runSimTrace, selectTraceEventsSay ) | ||
| import Control.Monad.Trans.Class | ||
| ( lift ) | ||
| import Control.Monad.Trans.Except | ||
| ( ExceptT, catchE, runExceptT, throwE ) | ||
| import Test.Hspec | ||
| ( Spec, describe, it, parallel ) | ||
| import Test.QuickCheck | ||
| ( Property, (===) ) | ||
|
|
||
| spec :: Spec | ||
| spec = do | ||
| parallel $ describe "Control.Concurrent.Concierge" $ do | ||
| it "Atomic operations do not interleave" | ||
| unit_atomic | ||
|
|
||
| it "throwE in ExceptT releases lock" | ||
| unit_exceptT_release_lock | ||
|
|
||
| {------------------------------------------------------------------------------- | ||
| Properties | ||
| -------------------------------------------------------------------------------} | ||
| -- | Deterministic test for atomicity. | ||
| -- We have to compare a program run that interleaves | ||
| -- against one that is atomic. | ||
| unit_atomic :: Bool | ||
| unit_atomic = | ||
| ("ABAB" == sayings testInterleave) && ("AABB" == sayings testAtomic) | ||
| where | ||
| sayings :: (forall s. IOSim s a) -> String | ||
| sayings x = concat . selectTraceEventsSay $ runSimTrace x | ||
|
|
||
| testAtomic = do | ||
| concierge <- newConcierge | ||
| test $ atomicallyWithLifted id concierge () | ||
| testInterleave = test id | ||
|
|
||
| test :: (forall a. IOSim s a -> IOSim s a) -> IOSim s () | ||
| test atomically = do | ||
| _ <- forkIO $ atomically (delay 1 >> action "B") | ||
| atomically $ action "A" | ||
| delay 4 | ||
|
|
||
| action :: String -> IOSim s () | ||
| action s = say s >> delay 2 >> say s | ||
|
|
||
| delay :: Int -> IOSim s () | ||
| delay n = threadDelay (fromIntegral n*0.1) | ||
|
|
||
| -- | Check that using 'throwE' in the 'ExceptE' monad releases the lock | ||
| unit_exceptT_release_lock :: Property | ||
| unit_exceptT_release_lock = | ||
| ["A"] === selectTraceEventsSay (runSimTrace $ runExceptT test) | ||
| where | ||
| liftE :: IOSim s a -> ExceptT String (IOSim s) a | ||
| liftE = lift | ||
|
|
||
| test :: ExceptT String (IOSim s) () | ||
| test = do | ||
| concierge <- liftE newConcierge | ||
| let atomically = atomicallyWithLifted liftE concierge () | ||
| _ <- tryE $ atomically $ throwE "X" | ||
| atomically $ liftE $ say "A" | ||
|
|
||
| -- not exported in transformers <= 0.5.6 | ||
| tryE :: Monad m => ExceptT e m a -> ExceptT e m (Either e a) | ||
| tryE action = (Right <$> action) `catchE` (pure . Left) |
Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.
Oops, something went wrong.