Make the typeclass test suite easily reusable

PaymentServer.cabal

@@ -50,6 +50,7 @@ test-suite PaymentServer-test
                      , hspec
                      , hspec-wai
                      , hspec-wai-json
+                     , hspec-expectations
                      , aeson
                      , stripe-core
                      , time

test/SpecPersistence.hs

@@ -9,17 +9,31 @@ module SpecPersistence where
 
 import Test.QuickCheck
   ( Property
-  , (===)
+  , (==>)
   )
 import Control.Monad.IO.Class
   ( liftIO
   )
+import Test.Hspec
+  ( Spec
+  , describe
+  , it
+  )
+import Test.Hspec.Expectations
+  ( shouldReturn
+  )
+import Test.QuickCheck
+  ( property
+  )
 import Test.QuickCheck.Monadic
   ( monadicIO
   , run
   , assert
   , pre
   )
+import Test.QuickCheck.Instances.Text
+  (
+  )
 import PaymentServer.Persistence
   ( RedeemError(NotPaid, AlreadyRedeemed)
   , Voucher
@@ -29,51 +43,45 @@ import PaymentServer.Persistence
   )
 
 -- | 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
+unpaidVoucherNotRedeemable :: VoucherDatabase d => IO d -> Property
+unpaidVoucherNotRedeemable getDB = property $ \voucher fingerprint -> 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
+  redeemVoucher db voucher fingerprint `shouldReturn` Left NotPaid
 
 -- | 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
+paidVoucherRedeemable :: VoucherDatabase d => IO d -> Property
+paidVoucherRedeemable getDB = property $ \voucher fingerprint -> 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
+  () <- 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 -> Voucher -> Fingerprint -> Property
-paidVoucherMultiRedeemable getDB voucher fingerprint = monadicIO $ do
+paidVoucherMultiRedeemable :: VoucherDatabase d => IO d -> Property
+paidVoucherMultiRedeemable getDB = property $ \voucher fingerprint -> do
   db <- liftIO getDB
-  () <- run $ payForVoucher db voucher
+  () <- 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
+  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 -> Voucher -> Fingerprint -> Fingerprint -> Property
-paidVoucherMismatchFingerprint getDB voucher fingerprint fingerprint' = monadicIO $ do
-  pre (fingerprint /= fingerprint')
+paidVoucherMismatchFingerprint :: VoucherDatabase d => IO d -> Property
+paidVoucherMismatchFingerprint getDB = property $ \voucher fingerprint fingerprint' ->
+  fingerprint /= fingerprint' ==> do
   db <- liftIO getDB
-  () <- run $ payForVoucher db voucher
+  () <- payForVoucher db voucher
   let redeem = redeemVoucher db voucher
-  run $ redeem fingerprint
-  result <- run $ redeem fingerprint'
-  assert (result == Left AlreadyRedeemed)
+  redeem fingerprint
+  redeem fingerprint' `shouldReturn` Left AlreadyRedeemed
+
+makeSpec :: VoucherDatabase d => IO d -> Spec
+makeSpec getDB = do
+  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
 
--- | The in-memory implementation for paidVoucherMismatchFingerprint.
-prop_memory_paidVoucherMismatchFingerprint = paidVoucherMismatchFingerprint memory
+spec_memory = makeSpec memory