Skip to content
Snippets Groups Projects
Persistence.hs 5.31 KiB
Newer Older
  • Learn to ignore specific revisions
  • {-# LANGUAGE OverloadedStrings #-}
    
    -- | Tests related to PaymentServer.Persistence and the persistence system in
    -- general.
    
    module Persistence
      ( tests
      ) where
    
    import qualified Data.Text as Text
    
    import Control.Exception
      ( Exception
      , throwIO
    
    import Control.Concurrent.Async
      ( withAsync
      , waitBoth
      )
    
    
    import Test.Tasty
      ( TestTree
      , testGroup
      )
    import Test.Tasty.HUnit
      ( testCase
      , assertEqual
      )
    
    import System.IO
      ( openTempFile
      )
    import System.Directory
      ( getTemporaryDirectory
      )
    
    import PaymentServer.Persistence
      ( Voucher
      , Fingerprint
      , RedeemError(NotPaid, AlreadyRedeemed)
      , PaymentError(AlreadyPaid)
      , VoucherDatabase(payForVoucher, redeemVoucher)
      , memory
      , getDBConnection
      )
    
    data ArbitraryException = ArbitraryException
      deriving (Show, Eq)
    
    instance Exception ArbitraryException
    
    tests :: TestTree
    tests = testGroup "Persistence"
      [ memoryDatabaseVoucherPaymentTests
      , sqlite3DatabaseVoucherPaymentTests
      ]
    
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
    -- Some dummy values that should be replaced by the use of QuickCheck.
    
    voucher = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
    
    anotherVoucher = "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz"
    
    fingerprint = "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb"
    
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
    -- Mock a successful payment.
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
    -- Mock a failed payment.
    
    failPayment = throwIO ArbitraryException
    
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
    -- | Create a group of tests related to voucher payment and redemption.
    
    makeVoucherPaymentTests
      :: VoucherDatabase d
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
      => Text.Text           -- ^ A distinctive identifier for this group's label.
    
      -> IO (IO d)           -- ^ An operation that creates a new, empty voucher
                             -- database and results in an operation that creates
                             -- a new connection to that database.
    
      -> TestTree
    makeVoucherPaymentTests label makeDatabase =
      testGroup ("voucher payments (" ++ Text.unpack label ++ ")")
      [ testCase "not paid for" $ do
    
          connect <- makeDatabase
          conn <- connect
          result <- redeemVoucher conn voucher fingerprint
    
          assertEqual "redeeming unpaid voucher" (Left NotPaid) result
      , testCase "paid for" $ do
    
          connect <- makeDatabase
          conn <- connect
          () <- payForVoucher conn voucher paySuccessfully
          result <- redeemVoucher conn voucher fingerprint
    
          assertEqual "redeeming paid voucher" (Right ()) result
      , testCase "allowed double redemption" $ do
    
          connect <- makeDatabase
          conn <- connect
          () <- payForVoucher conn voucher paySuccessfully
          let redeem = redeemVoucher conn voucher fingerprint
    
          first <- redeem
          second <- redeem
          assertEqual "redeeming paid voucher" (Right ()) first
          assertEqual "re-redeeming paid voucher" (Right ()) second
      , testCase "disallowed double redemption" $ do
    
          connect <- makeDatabase
          conn <- connect
          () <- payForVoucher conn voucher paySuccessfully
          let redeem = redeemVoucher conn voucher
    
          first <- redeem fingerprint
          second <- redeem (Text.cons 'a' $ Text.tail fingerprint)
          assertEqual "redeeming paid voucher" (Right ()) first
          assertEqual "re-redeeming paid voucher" (Left AlreadyRedeemed) second
    
      , testCase "pay with exception" $ do
    
          connect <- makeDatabase
          conn <- connect
          payResult <- try $ payForVoucher conn voucher failPayment
    
          assertEqual "failing a payment for a voucher" (Left ArbitraryException) payResult
    
          result <- redeemVoucher conn voucher fingerprint
    
          assertEqual "redeeming voucher with failed payment" (Left NotPaid) result
      , testCase "disallowed double payment" $ do
    
          connect <- makeDatabase
          conn <- connect
          let pay = payForVoucher conn voucher paySuccessfully
    
          payResult <- try pay
          assertEqual "double-paying for a voucher" (Left AlreadyPaid) payResult
    
          redeemResult <- redeemVoucher conn voucher fingerprint
    
          assertEqual "redeeming double-paid voucher" (Right ()) redeemResult
    
      , testCase "concurrent redemption" $ do
    
          connect <- makeDatabase
          connA <- connect
          connB <- connect
          -- It doesn't matter which connection pays for the vouchers.  They
          -- payments are concurrent and the connections are to the same database.
          () <- payForVoucher connA voucher paySuccessfully
          () <- payForVoucher connA anotherVoucher paySuccessfully
    
          -- It does matter which connection is used to redeem the voucher.  A
          -- connection can only do one thing at a time.
          let redeem = redeemVoucher connA voucher fingerprint
          let anotherRedeem = redeemVoucher connB anotherVoucher fingerprint
    
    
          result <- withAsync redeem $ \r1 -> do
            withAsync anotherRedeem $ \r2 -> do
              waitBoth r1 r2
    
          assertEqual "Both redemptions should succeed" (Right (), Right ()) result
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
    -- | Instantiate the persistence tests for the memory backend.
    
    memoryDatabaseVoucherPaymentTests :: TestTree
    
    memoryDatabaseVoucherPaymentTests = makeVoucherPaymentTests "memory" $ do
      db <- memory
      return $ return db
    
    Jean-Paul Calderone's avatar
    Jean-Paul Calderone committed
    -- | Instantiate the persistence tests for the sqlite3 backend.
    
    sqlite3DatabaseVoucherPaymentTests :: TestTree
    sqlite3DatabaseVoucherPaymentTests =
      makeVoucherPaymentTests "sqlite3" $
      do
        tempdir <- getTemporaryDirectory
        (path, handle) <- openTempFile tempdir "voucher-.db"
    
        return . getDBConnection . Text.pack $ path