Skip to content

Commit

Permalink
Add unit tests for Control.Concurrent.Concierge
Browse files Browse the repository at this point in the history
  • Loading branch information
HeinrichApfelmus authored and rvl committed Aug 19, 2021
1 parent 6c76721 commit ff7d311
Show file tree
Hide file tree
Showing 3 changed files with 86 additions and 0 deletions.
2 changes: 2 additions & 0 deletions lib/core/cardano-wallet-core.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -300,6 +300,7 @@ test-suite unit
, http-types
, iohk-monitoring
, io-classes
, io-sim
, lattices
, lens
, memory
Expand Down Expand Up @@ -408,6 +409,7 @@ test-suite unit
Cardano.Wallet.RegistrySpec
Cardano.Wallet.TransactionSpec
Cardano.WalletSpec
Control.Concurrent.ConciergeSpec
Data.Function.UtilsSpec
Data.QuantitySpec
Data.Time.TextSpec
Expand Down
83 changes: 83 additions & 0 deletions lib/core/test/unit/Control/Concurrent/ConciergeSpec.hs
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)
1 change: 1 addition & 0 deletions nix/.stack.nix/cardano-wallet-core.nix

Some generated files are not rendered by default. Learn more about how customized files appear on GitHub.

0 comments on commit ff7d311

Please sign in to comment.