SpecPersistence.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

--
-- Test suite related to the persistence system.
--

module SpecPersistence where

import Control.Monad.IO.Class
  ( liftIO
  )
import Test.Hspec
  ( Spec
  , describe
  , it
  )
import Test.Hspec.Expectations
  ( shouldReturn
  )
import Test.QuickCheck
  ( Property
  , property
  , (==>)
  )
import Test.QuickCheck.Monadic
  ( monadicIO
  , run
  , assert
  , pre
  )
import Test.QuickCheck.Instances.Text
  (
  )
import PaymentServer.Persistence
  ( RedeemError(NotPaid, AlreadyRedeemed)
  , Voucher
  , Fingerprint
  , VoucherDatabase(payForVoucher, redeemVoucher)
  , memory
  )

-- | A voucher which has not been paid for cannot be redeemed.
unpaidVoucherNotRedeemable :: VoucherDatabase d => IO d -> Property
unpaidVoucherNotRedeemable getDB = property $ \voucher fingerprint -> do
  db <- liftIO getDB
  redeemVoucher db voucher fingerprint `shouldReturn` Left NotPaid

-- | A voucher which is paid for can be redeemed with any fingerprint.
paidVoucherRedeemable :: VoucherDatabase d => IO d -> Property
paidVoucherRedeemable getDB = property $ \voucher fingerprint -> do
  db <- liftIO getDB
  () <- payForVoucher db voucher
  redeemVoucher db voucher fingerprint `shouldReturn` Right ()

-- | A voucher which is paid for can be redeemed more than once as long as the
-- same fingerprint is used each time.
paidVoucherMultiRedeemable :: VoucherDatabase d => IO d -> Property
paidVoucherMultiRedeemable getDB = property $ \voucher fingerprint -> do
  db <- liftIO getDB
  () <- payForVoucher db voucher
  let redeem = redeemVoucher db voucher fingerprint
  redeem
  redeem `shouldReturn` Right ()

-- | A voucher which is paid for can not be redeemed a second time with a
-- different fingerprint than was used on the first attempt.
paidVoucherMismatchFingerprint :: VoucherDatabase d => IO d -> Property
paidVoucherMismatchFingerprint getDB = property $ \voucher fingerprint fingerprint' ->
  fingerprint /= fingerprint' ==> do
  db <- liftIO getDB
  () <- payForVoucher db voucher
  let redeem = redeemVoucher db voucher
  redeem fingerprint
  redeem fingerprint' `shouldReturn` Left AlreadyRedeemed

makeSpec :: VoucherDatabase d => IO d -> Spec
makeSpec getDB =
  describe "voucher interactions" $
  do
    it "denies redemption of a not-paid-for voucher" $ unpaidVoucherNotRedeemable getDB
    it "allows redemption of paid-for vouchers" $ paidVoucherRedeemable getDB
    it "allows multiple redemption as long as the same fingerprint is used" $ paidVoucherMultiRedeemable getDB
    it "denies a subsequent redemption with a different fingerprint" $ paidVoucherMismatchFingerprint getDB

spec_memory = makeSpec memory