diff --git a/PaymentServer.cabal b/PaymentServer.cabal index 0c5286c1282dc7f33ba50e06852314b5363a130f..dd51a39404009e27bf993c5eac9c2842374ef8e2 100644 --- a/PaymentServer.cabal +++ b/PaymentServer.cabal @@ -73,6 +73,7 @@ test-suite PaymentServer-tests , tasty , tasty-hunit , directory + , async , PaymentServer default-language: Haskell2010 diff --git a/test/Persistence.hs b/test/Persistence.hs index f425e2fd06738ca71739e91fbf8870038f8bd6b9..48b9dab6430e42628e1bb0211b42d0fdbda1cf40 100644 --- a/test/Persistence.hs +++ b/test/Persistence.hs @@ -15,6 +15,11 @@ import Control.Exception , try ) +import Control.Concurrent.Async + ( withAsync + , waitBoth + ) + import Test.Tasty ( TestTree , testGroup @@ -54,6 +59,7 @@ tests = testGroup "Persistence" -- Some dummy values that should be replaced by the use of QuickCheck. voucher = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +anotherVoucher = "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz" fingerprint = "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" -- Mock a successful payment. @@ -112,6 +118,19 @@ makeVoucherPaymentTests label makeDatabase = assertEqual "double-paying for a voucher" (Left AlreadyPaid) payResult redeemResult <- redeemVoucher db voucher fingerprint assertEqual "redeeming double-paid voucher" (Right ()) redeemResult + , testCase "concurrent redemption" $ do + db <- makeDatabase + () <- payForVoucher db voucher paySuccessfully + () <- payForVoucher db anotherVoucher paySuccessfully + + let redeem = redeemVoucher db voucher fingerprint + let anotherRedeem = redeemVoucher db anotherVoucher fingerprint + + result <- withAsync redeem $ \r1 -> do + withAsync anotherRedeem $ \r2 -> do + waitBoth r1 r2 + + assertEqual "Both redemptions should succeed" (Right (), Right ()) result ] -- | Instantiate the persistence tests for the memory backend.