-
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.
2827: Remove race condition in `postTransactionOld` where pending (spent) UTxO could be selected as inputs r=rvl a=HeinrichApfelmus ### Issue Number ADP-780 ### Overview This pull request removes a race condition in `postTransactionOld` where concurrent calls to the `POST transactions` endpoint could result in UTxOs being selected twice as inputs, resulting in an attempted double-spend. To remove the race condition, for each wallet ID we enforce sequential execution of the critical section in `postTransactionOld`. Calls with different wallet IDs still run concurrently, and so do all other endpoints. The main idea of this pull request is to introduce a small utility `Control.Concurrent.Concierge` that keeps track of a collection of locks. It provides a function `atomicallyWith` that does what it names suggests. Being polymorphic, this utility can be tested with unit tests using the IO simulation monad `io-sim`. ### Progress - [x] Introduce `Concierge` utility for managing a collection of locks. - [x] Make critical section atomic. - [x] Unit tests for `Concierge` - [x] The `Concierge` actually makes things atomic - [x] The lock will be release upon an exception. ### Comments Co-authored-by: Heinrich Apfelmus <[email protected]>
- 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.