write some more persistence tests (and check them in this time)

PaymentServer.cabal

@@ -41,6 +41,7 @@ test-suite PaymentServer-test
   hs-source-dirs:      test
   main-is:             Driver.hs
   other-modules:       SpecStripe
+                     , SpecPersistence
                      , Util.WAI
                      , Util.Gen
                      , Util.JSON

src/PaymentServer/Persistence.hs

 module PaymentServer.Persistence
   ( Voucher
+  , Fingerprint
+  , RedeemError(NotPaid, AlreadyRedeemed)
   , VoucherDatabase(payForVoucher, redeemVoucher)
   , memory
   ) where
 
+import Control.Monad
+  ( liftM
+  )
 import Data.Text
   ( Text
   )
@@ -13,6 +18,7 @@ import Data.IORef
   ( IORef
   , newIORef
   , modifyIORef
+  , readIORef
   )
 
 -- | A voucher is a unique identifier which can be associated with a payment.
@@ -27,6 +33,7 @@ data RedeemError =
   NotPaid
   -- | The voucher has already been redeemed.
   | AlreadyRedeemed
+  deriving (Show, Eq)
 
 -- | A fingerprint cryptographically identifies a redemption of a voucher.
 -- When a voucher is redeemed, a number of random tokens are received
@@ -70,6 +77,21 @@ instance VoucherDatabase MemoryVoucherDatabase where
     modifyIORef paid (Set.insert voucher)
     return ()
 
+  redeemVoucher Memory{ paid = paid, redeemed = redeemed } voucher fingerprint = do
+    unpaid <- (liftM $ Set.notMember voucher) . readIORef $ paid
+    existingFingerprint <- (liftM $ Map.lookup voucher) . readIORef $ redeemed
+    case (unpaid, existingFingerprint) of
+      (True, _) ->
+        return $ Left NotPaid
+      (False, Nothing) -> do
+        modifyIORef redeemed (Map.insert voucher fingerprint)
+        return $ Right ()
+      (False, Just fingerprint') ->
+        if fingerprint == fingerprint' then
+          return $ Right ()
+        else
+          return $ Left AlreadyRedeemed
+
 -- | Create a new, empty MemoryVoucherDatabase.
 memory :: IO MemoryVoucherDatabase
 memory = do

test/SpecPersistence.hs

+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+--
+-- Test suite related to the persistence system.
+--
+
+module SpecPersistence where
+
+import Test.QuickCheck
+  ( Property
+  , (===)
+  )
+import Control.Monad.IO.Class
+  ( liftIO
+  )
+import Test.QuickCheck.Monadic
+  ( monadicIO
+  , run
+  , assert
+  , pre
+  )
+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 -> Voucher -> Fingerprint -> Property
+unpaidVoucherNotRedeemable getDB voucher fingerprint = monadicIO $ do
+  db <- liftIO getDB
+  result <- run $ redeemVoucher db voucher fingerprint
+  assert (result == Left NotPaid)
+
+-- | The in-memory implementation for unpaidVoucherNotRedeemable.
+prop_memory_unpaidVoucherNotRedeemable = unpaidVoucherNotRedeemable memory
+
+-- | A voucher which is paid for can be redeemed with any fingerprint.
+paidVoucherRedeemable :: VoucherDatabase d => IO d -> Voucher -> Fingerprint -> Property
+paidVoucherRedeemable getDB voucher fingerprint = monadicIO $ do
+  db <- liftIO getDB
+  () <- run $ payForVoucher db voucher
+  result <- run $ redeemVoucher db voucher fingerprint
+  assert (result == Right ())
+
+-- | The in-memory implementation for paidVoucherRedeemable.
+prop_memory_paidVoucherRedeemable = paidVoucherRedeemable memory
+
+-- | 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 -> Voucher -> Fingerprint -> Property
+paidVoucherMultiRedeemable getDB voucher fingerprint = monadicIO $ do
+  db <- liftIO getDB
+  () <- run $ payForVoucher db voucher
+  let redeem = redeemVoucher db voucher fingerprint
+  run redeem
+  result <- run redeem
+  assert (result == Right ())
+
+-- | The in-memory implementation for paidVoucherMultiRedeemable.
+prop_memory_paidVoucherMultiRedeemable = paidVoucherMultiRedeemable memory
+
+-- | 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 -> Voucher -> Fingerprint -> Fingerprint -> Property
+paidVoucherMismatchFingerprint getDB voucher fingerprint fingerprint' = monadicIO $ do
+  pre (fingerprint /= fingerprint')
+  db <- liftIO getDB
+  () <- run $ payForVoucher db voucher
+  let redeem = redeemVoucher db voucher
+  run $ redeem fingerprint
+  result <- run $ redeem fingerprint'
+  assert (result == Left AlreadyRedeemed)
+
+-- | The in-memory implementation for paidVoucherMismatchFingerprint.
+prop_memory_paidVoucherMismatchFingerprint = paidVoucherMismatchFingerprint memory