Fix hanging test by paying for voucher

Also reduce duplication in the test implementation a bit
And add some more error case tests
And remove the old, no-longer used redemption parameter globals
Some Integers becomes Ints for intra-module consistency

src/PaymentServer/Redemption.hs

@@ -8,7 +8,12 @@
 module PaymentServer.Redemption
   ( RedemptionAPI
   , Redeem(Redeem)
-  , RedemptionConfig(RedemptionConfig)
+  , RedemptionConfig
+    ( RedemptionConfig
+    , redemptionConfigMaxCounter
+    , redemptionConfigTokensPerVoucher
+    , redemptionConfigIssue
+    )
   , redemptionServer
   ) where
 
@@ -98,7 +103,7 @@ data Result
   | DoubleSpend -- ^ A voucher has already been redeemed.
   | OtherFailure Text -- ^ Some other unrecognized failure mode.
   -- | Given counter was not in the expected range
-  | CounterOutOfBounds Integer Integer Integer
+  | CounterOutOfBounds Int Int Int
   | Succeeded PublicKey [Signature] Proof
   deriving (Show, Eq)
 
@@ -108,7 +113,7 @@ data Redeem
   = Redeem
   { redeemVoucher :: Voucher        -- ^ The voucher being redeemed.
   , redeemTokens :: [BlindedToken]  -- ^ Tokens to be signed as part of this redemption.
-  , redeemCounter :: Integer        -- ^ Counter tag on this redemption.
+  , redeemCounter :: Int            -- ^ Counter tag on this redemption.
   } deriving (Show, Eq, Generic)
 
 instance FromJSON Redeem where
@@ -164,13 +169,6 @@ instance FromJSON Result where
         then return DoubleSpend
         else return $ OtherFailure reason
 
--- | Limit the value for the counter value supplied during a voucher
--- redemption attempt.  A counter in the range [0..maxCounter) is allowed.
-maxCounter :: Integer
-maxCounter = 16
-
-tokensPerVoucher :: Integer
-tokensPerVoucher = 50000
 
 type RedemptionAPI = ReqBody '[JSON] Redeem :> Post '[JSON] Result
 
@@ -235,8 +233,8 @@ tokenCountForGroup numGroups totalTokens groupNumber =
 -- (eg because the voucher was already redeemed).
 redeem :: VoucherDatabase d => RedemptionConfig -> d -> Redeem -> Handler Result
 redeem (RedemptionConfig numGroups tokensPerVoucher issue) database (Redeem voucher tokens counter) =
-  if counter < 0 || counter >= maxCounter then
-    throwError $ jsonErr err400 (CounterOutOfBounds 0 maxCounter counter)
+  if counter < 0 || counter >= numGroups then
+    throwError $ jsonErr err400 (CounterOutOfBounds 0 numGroups counter)
   else
     case tokenCountForGroup numGroups tokensPerVoucher (fromIntegral counter) of
       Nothing ->
@@ -249,7 +247,8 @@ redeem (RedemptionConfig numGroups tokensPerVoucher issue) database (Redeem vouc
     fingerprint = fingerprintFromTokens tokens
 
     redeemOnce :: IO (Either RedeemError Bool)
-    redeemOnce = redeemVoucherWithCounter database voucher fingerprint counter
+    redeemOnce =
+      redeemVoucherWithCounter database voucher fingerprint (fromIntegral counter)
 
     redeem :: Handler Result
     redeem = do

test/FakeStripe.hs

@@ -2,7 +2,8 @@
 {-# LANGUAGE QuasiQuotes #-}
 
 module FakeStripe
-  ( withFakeStripe
+  ( ChargeId(ChargeId)
+  , withFakeStripe
   , chargeOkay
   , chargeFailed
   ) where
@@ -43,6 +44,10 @@ import Web.Stripe.Client
   , Endpoint(Endpoint)
   )
 
+import Web.Stripe.Types
+  ( ChargeId(ChargeId)
+  )
+
 anError :: ByteString
 anError = [r|
 {

test/Redemption.hs

@@ -43,22 +43,26 @@ import Network.Wai
 import PaymentServer.Issuer
   ( trivialIssue
   )
-
 import PaymentServer.Persistence
   ( memory
-  )
-
-import PaymentServer.Server
-  ( RedemptionConfig(RedemptionConfig)
-  , paymentServerApp
+  , payForVoucher
   )
 import PaymentServer.Redemption
   ( Redeem(Redeem)
+  , RedemptionConfig
+    ( RedemptionConfig
+    , redemptionConfigMaxCounter
+    , redemptionConfigTokensPerVoucher
+    , redemptionConfigIssue
+    )
+  )
+import PaymentServer.Server
+  ( paymentServerApp
   )
-
 import FakeStripe
   ( withFakeStripe
   , chargeOkay
+  , ChargeId(ChargeId)
   )
 
 tests :: TestTree
@@ -72,29 +76,45 @@ redemptionTests =
   [ testCase "success" $
     -- A redemption attempt with a valid group number and correct token count
     -- for that group receives a 200 HTTP response.
-    withFakeStripe (return chargeOkay) $
-    \stripeConfig -> do
-      db <- memory
-      let app = paymentServerApp origins stripeConfig redemptionConfig db
-
-      (flip runSession) app $ do
-        response <- request $ Redeem "abc" (replicate (1024 `div` 16) "a") 0
-        assertStatus 200 response
+    let redemption = Redeem aVoucher (replicate tokensPerGroup aToken) 0
+    in assertRedemptionStatus redemption 200
 
   , testCase "negative counter" $
     -- A redemption attempt with a negative counter value fails with an HTTP
     -- error.
-    withFakeStripe (return chargeOkay) $
-    \stripeConfig -> do
-      db <- memory
-      let app = paymentServerApp origins stripeConfig redemptionConfig db
-
-      (flip runSession) app $ do
-        response <- request $ Redeem "abc" (replicate (1024 `div` 16) "a") (-1)
-        assertStatus 400 response
+    let redemption = Redeem aVoucher (replicate tokensPerGroup aToken) (-1)
+    in assertRedemptionStatus redemption 400
+
+  , testCase "counter too large" $
+    -- A redemption attempt with a counter value greater than the maximum
+    -- allowed fails with an HTTP error.
+    let redemption = Redeem aVoucher (replicate tokensPerGroup aToken) tokenGroups
+    in assertRedemptionStatus redemption 400
+
+  , testCase "too few tokens" $
+    -- A redemption attempt with fewer tokens than are expected in the
+    -- indicated redemption group fails with an HTTP error.
+    let redemption = Redeem aVoucher (replicate (tokensPerGroup - 1) aToken) 0
+    in assertRedemptionStatus redemption 400
+
+  , testCase "too many tokens" $
+    -- A redemption attempt with more tokens than are expected in the
+    -- indicated redemption group fails with an HTTP error.
+    let redemption = Redeem aVoucher (replicate (tokensPerGroup + 1) aToken) 0
+    in assertRedemptionStatus redemption 400
   ]
   where
-    redemptionConfig = RedemptionConfig 16 1024 trivialIssue
+    totalTokens = 32
+    tokenGroups = 4
+    tokensPerGroup = totalTokens `div` tokenGroups
+    aToken = "a"
+    aVoucher = "abc"
+
+    redemptionConfig = RedemptionConfig
+      { redemptionConfigMaxCounter = tokenGroups
+      , redemptionConfigTokensPerVoucher = totalTokens
+      , redemptionConfigIssue = trivialIssue
+      }
     origins = ["example.invalid"]
     headers = [("origin", "example.invalid"), ("content-type", "application/json")]
     path = "/v1/redeem"
@@ -104,3 +124,17 @@ redemptionTests =
                  } path
 
     request = srequest . SRequest theRequest . encode
+
+    -- | Assert that using the given redemption parameters results in a
+    -- response with the given status.
+    assertRedemptionStatus redemption expectedStatus =
+      withFakeStripe (return chargeOkay) $
+      \stripeConfig -> do
+        db <- memory
+        payForVoucher db aVoucher (return $ Right $ ChargeId "xyz")
+
+        let app = paymentServerApp origins stripeConfig redemptionConfig db
+
+        (flip runSession) app $ do
+          response <- request redemption
+          assertStatus expectedStatus response