From 3d59d0f150c0ba30d7fca8a9ff82aa7c6da29e19 Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Wed, 4 Sep 2019 13:40:37 -0400
Subject: [PATCH] Probably correct token fingerprinting
---
PaymentServer.cabal | 1 +
src/PaymentServer/Redemption.hs | 17 +++-
test/Driver.hs | 6 +-
test/SpecRedemption.hs | 133 ++++++++++++++++++++------------
4 files changed, 101 insertions(+), 56 deletions(-)
diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 8f716de..60a849c 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -31,6 +31,7 @@ library
, stripe-core
, text
, containers
+ , cryptonite
default-language: Haskell2010
executable PaymentServer-exe
diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs
index 8fd54ba..11acd39 100644
--- a/src/PaymentServer/Redemption.hs
+++ b/src/PaymentServer/Redemption.hs
@@ -20,6 +20,11 @@ import Control.Monad.IO.Class
)
import Data.Text
( Text
+ , pack
+ )
+import Data.Text.Encoding
+ ( encodeUtf8
+ , decodeUtf8
)
import Data.Aeson
( ToJSON(toJSON, toEncoding)
@@ -43,6 +48,10 @@ import Servant.API
, ReqBody
, (:>)
)
+import Crypto.Hash
+ ( SHA3_512(SHA3_512)
+ , hashWith
+ )
import PaymentServer.Persistence
( VoucherDatabase(redeemVoucher)
, Fingerprint
@@ -86,8 +95,12 @@ redeem database (Redeem voucher tokens) = do
let fingerprint = fingerprintFromTokens tokens
result <- liftIO $ PaymentServer.Persistence.redeemVoucher database voucher fingerprint
case result of
- Left err -> return Failed
+ Left err -> throwError jsonErr400
Right () -> return Succeeded
fingerprintFromTokens :: [BlindedToken] -> Fingerprint
-fingerprintFromTokens _ = "fingerprint"
+fingerprintFromTokens =
+ let
+ hash = pack . show . hashWith SHA3_512 . encodeUtf8
+ in
+ foldl (\b a -> hash $ a `mappend` b) "" . map hash
diff --git a/test/Driver.hs b/test/Driver.hs
index 6462a8a..258e02f 100644
--- a/test/Driver.hs
+++ b/test/Driver.hs
@@ -31,11 +31,9 @@ tests = do
t3 <- pure $ QC.testProperty "getVoucherWithoutVoucher" SpecStripe.prop_getVoucherWithoutVoucher
- t4 <- HS.testSpec "simple" SpecRedemption.spec_simple
+ t4 <- HS.testSpec "redemption" SpecRedemption.spec_redemption
- t5 <- HS.testSpec "memory db" SpecRedemption.spec_memory_db
-
- pure $ T.testGroup "./test/Driver.hs" [t0,t1,t2,t3,t4,t5]
+ pure $ T.testGroup "./test/Driver.hs" [t0,t1,t2,t3,t4]
ingredients :: [T.Ingredient]
ingredients = T.defaultIngredients
main :: IO ()
diff --git a/test/SpecRedemption.hs b/test/SpecRedemption.hs
index 0f6879b..7c545b9 100644
--- a/test/SpecRedemption.hs
+++ b/test/SpecRedemption.hs
@@ -5,6 +5,9 @@
module SpecRedemption where
+import Data.ByteString
+ ( ByteString
+ )
import Text.Printf
( printf
)
@@ -31,7 +34,9 @@ import Test.Hspec
, runIO
)
import Test.Hspec.Wai
- ( with
+ ( ResponseMatcher(ResponseMatcher)
+ , WaiExpectation
+ , with
, shouldRespondWith
, liftIO
)
@@ -39,7 +44,8 @@ import Test.Hspec.Wai.QuickCheck
( property
)
import Test.QuickCheck
- ( (==>)
+ ( Property
+ , (==>)
)
import Test.QuickCheck.Monadic
( pre
@@ -60,7 +66,8 @@ import PaymentServer.Redemption
, redemptionServer
)
import PaymentServer.Persistence
- ( Voucher
+ ( RedeemError(NotPaid)
+ , Voucher
, Fingerprint
, VoucherDatabase(payForVoucher, redeemVoucher)
, MemoryVoucherDatabase
@@ -75,50 +82,76 @@ app = serve redemptionAPI . redemptionServer
path = "/"
-spec_simple :: Spec
-spec_simple = with (app <$> memory) $ parallel $ do
- describe (printf "error behavior of POST %s" (show path)) $ do
- wrongMethodNotAllowed "GET" path
- nonJSONUnsupportedMediaType path
- wrongJSONInvalidRequest path "{}"
-
-withConnection :: VoucherDatabase d => IO d -> ((d -> IO ()) -> IO ())
-withConnection getDB = bracket getDB (\db -> return ())
-
-make_spec_db :: VoucherDatabase d => IO d -> Spec
-make_spec_db getDatabase = do
- -- Create the database so we can interact with it directly in the tests
- -- below.
- database <- runIO getDatabase
- before (return $ app database) $
- describe "redemption attempts on the server" $ do
- it "receive 400 (Invalid Request) when the voucher is unpaid" $
- property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
- postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 400
-
- it "receive 200 (OK) when the voucher is paid" $
- property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
- do
- liftIO $ payForVoucher database voucher
- postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 200
-
- it "receive 200 (OK) when the voucher is paid and previously redeemed with the same tokens" $
- property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
- do
- liftIO $ payForVoucher database voucher
- postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 200
- postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 200
-
- it "receive 400 (OK) when the voucher is paid and previously redeemed with different tokens" $
- property $ \(voucher :: Voucher) (firstTokens :: [BlindedToken]) (secondTokens :: [BlindedToken]) ->
- do
- liftIO $ payForVoucher database voucher
- postJSON path (encode $ Redeem voucher firstTokens) `shouldRespondWith` 200
- postJSON path (encode $ Redeem voucher secondTokens) `shouldRespondWith` 400
-
-
-
-
-spec_memory_db :: Spec
-spec_memory_db =
- make_spec_db memory
+propertyRedeem :: ByteString -> Voucher -> [BlindedToken] -> ResponseMatcher -> WaiExpectation
+propertyRedeem path voucher tokens matcher =
+ postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` matcher
+
+-- | A VoucherDatabaseTestDouble has a VoucherDatabase instance which provides
+-- a number of different behaviors which are useful to be able to directly
+-- test against.
+data VoucherDatabaseTestDouble
+ -- | A RefuseRedemption database always refuses redemption with a given error.
+ = RefuseRedemption RedeemError
+ -- | A PermitRedemption database always permits redemption.
+ | PermitRedemption
+ deriving (Show)
+
+instance VoucherDatabase VoucherDatabaseTestDouble where
+ payForVoucher _ voucher = return ()
+ redeemVoucher (RefuseRedemption err) _ _ = return $ Left err
+ redeemVoucher PermitRedemption _ _ = return $ Right ()
+
+spec_redemption :: Spec
+spec_redemption = parallel $ do
+ database <- runIO memory
+ with (return . app $ database) $
+ do
+ describe (printf "error behavior of POST %s" (show path)) $
+ do
+ wrongMethodNotAllowed "GET" path
+ nonJSONUnsupportedMediaType path
+ wrongJSONInvalidRequest path "{}"
+
+ -- I would rather write these two as property tests but I don't know
+ -- how.
+ describe "double redemption" $ do
+ it "succeeds with the same tokens" $ do
+ let voucher = "abc" :: Voucher
+ let tokens = [ "def", "ghi" ] :: [BlindedToken]
+ liftIO $ payForVoucher database voucher
+ propertyRedeem path voucher tokens 200
+ propertyRedeem path voucher tokens 200
+
+ it "fails with different tokens" $ do
+ let voucher = "jkl" :: Voucher
+ let firstTokens = [ "mno", "pqr" ] :: [BlindedToken]
+ let secondTokens = [ "stu", "vwx" ] :: [BlindedToken]
+ liftIO $ payForVoucher database voucher
+ propertyRedeem path voucher firstTokens 200
+ propertyRedeem path voucher secondTokens 400
+
+
+ describe "redemption" $ do
+ with (return . app $ RefuseRedemption NotPaid) $
+ it "receives 400 (Invalid Request) when the voucher is not paid" $ property $
+ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
+ propertyRedeem path voucher tokens 400
+
+ with (return $ app PermitRedemption) $
+ it "receive 200 (OK) when redemption succeeds" $ property $
+ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
+ propertyRedeem path voucher tokens 200
+
+ -- it "receive 200 (OK) when the voucher is paid and previously redeemed with the same tokens" $
+ -- property $ \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
+ -- do
+ -- liftIO $ payForVoucher database voucher
+ -- postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 200
+ -- postJSON path (encode $ Redeem voucher tokens) `shouldRespondWith` 200
+
+ -- it "receive 400 (OK) when the voucher is paid and previously redeemed with different tokens" $
+ -- property $ \(voucher :: Voucher) (firstTokens :: [BlindedToken]) (secondTokens :: [BlindedToken]) ->
+ -- do
+ -- liftIO $ payForVoucher database voucher
+ -- postJSON path (encode $ Redeem voucher firstTokens) `shouldRespondWith` 200
+ -- postJSON path (encode $ Redeem voucher secondTokens) `shouldRespondWith` 400
--
GitLab