From c3d51dad68b1d9241a42141762ab3aeec8bb9070 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Thu, 5 Sep 2019 11:24:56 -0400
Subject: [PATCH] Don't repeat yourself
---
src/PaymentServer/Redemption.hs | 10 +++++-----
src/PaymentServer/Server.hs | 5 ++++-
test/SpecRedemption.hs | 11 ++++++-----
3 files changed, 15 insertions(+), 11 deletions(-)
diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs
index 96dcdaf..c2cbe06 100644
--- a/src/PaymentServer/Redemption.hs
+++ b/src/PaymentServer/Redemption.hs
@@ -63,7 +63,7 @@ import PaymentServer.Issuer
, Proof
, BlindedToken
, ChallengeBypass(ChallengeBypass)
- , trivialIssue
+ , Issuer
)
data Result
@@ -111,21 +111,21 @@ jsonErr400 = err400
, errHeaders = [ ("Content-Type", "application/json;charset=utf-8") ]
}
-redemptionServer :: VoucherDatabase d => d -> Server RedemptionAPI
+redemptionServer :: VoucherDatabase d => Issuer -> d -> Server RedemptionAPI
redemptionServer = redeem
-- | Handler for redemption requests. Use the database to try to redeem the
-- voucher and return signatures. Return a failure if this is not possible
-- (eg because the voucher was already redeemed).
-redeem :: VoucherDatabase d => d -> Redeem -> Handler Result
-redeem database (Redeem voucher tokens) = do
+redeem :: VoucherDatabase d => Issuer -> d -> Redeem -> Handler Result
+redeem issue database (Redeem voucher tokens) = do
let fingerprint = fingerprintFromTokens tokens
result <- liftIO $ PaymentServer.Persistence.redeemVoucher database voucher fingerprint
case result of
Left err -> throwError jsonErr400
Right () ->
let
- (ChallengeBypass key signatures proof) = trivialIssue tokens
+ (ChallengeBypass key signatures proof) = issue tokens
in
return $ Succeeded key signatures proof
diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs
index f55b779..6eea6ab 100644
--- a/src/PaymentServer/Server.hs
+++ b/src/PaymentServer/Server.hs
@@ -23,6 +23,9 @@ import PaymentServer.Redemption
( RedemptionAPI
, redemptionServer
)
+import PaymentServer.Issuer
+ ( trivialIssue
+ )
import PaymentServer.Persistence
( VoucherDatabase
)
@@ -36,7 +39,7 @@ type PaymentServerAPI
paymentServer :: VoucherDatabase d => d -> Server PaymentServerAPI
paymentServer d =
stripeServer d
- :<|> redemptionServer d
+ :<|> redemptionServer trivialIssue d
paymentServerAPI :: Proxy PaymentServerAPI
paymentServerAPI = Proxy
diff --git a/test/SpecRedemption.hs b/test/SpecRedemption.hs
index 1017fa1..d75ee75 100644
--- a/test/SpecRedemption.hs
+++ b/test/SpecRedemption.hs
@@ -55,6 +55,7 @@ import Util.WAI
import PaymentServer.Issuer
( BlindedToken
, ChallengeBypass(ChallengeBypass)
+ , Issuer
, trivialIssue
)
import PaymentServer.Redemption
@@ -73,8 +74,8 @@ import PaymentServer.Persistence
redemptionAPI :: Proxy RedemptionAPI
redemptionAPI = Proxy
-app :: VoucherDatabase d => d -> Application
-app = serve redemptionAPI . redemptionServer
+app :: VoucherDatabase d => Issuer -> d -> Application
+app issue = serve redemptionAPI . redemptionServer issue
path = "/"
@@ -100,7 +101,7 @@ instance VoucherDatabase VoucherDatabaseTestDouble where
spec_redemption :: Spec
spec_redemption = parallel $ do
database <- runIO memory
- with (return . app $ database) $
+ with (return $ app trivialIssue database) $
do
describe (printf "error behavior of POST %s" (show path)) $
do
@@ -128,7 +129,7 @@ spec_redemption = parallel $ do
describe "redemption" $ do
- with (return . app $ RefuseRedemption NotPaid) $
+ with (return $ app trivialIssue (RefuseRedemption NotPaid)) $
it "receives a failure response when the voucher is not paid" $ property $
\(voucher :: Voucher) (tokens :: [BlindedToken]) ->
propertyRedeem path voucher tokens 400
@@ -139,7 +140,7 @@ spec_redemption = parallel $ do
, matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
}
- with (return $ app PermitRedemption) $
+ with (return $ app trivialIssue PermitRedemption) $
it "receive a success response when redemption succeeds" $ property $
\(voucher :: Voucher) (tokens :: [BlindedToken]) ->
let
--
GitLab