diff --git a/PaymentServer.cabal b/PaymentServer.cabal index e72b908..090fbff 100644 --- a/PaymentServer.cabal +++ b/PaymentServer.cabal @@ -52,13 +52,13 @@ library , servant-prometheus , mtl default-language: Haskell2010 - ghc-options: -Wmissing-import-lists -Wunused-imports + ghc-options: -Werror -Wall -Wno-name-shadowing -Wno-orphans -Wno-error=unused-do-bind pkgconfig-depends: libchallenge_bypass_ristretto_ffi executable PaymentServer-exe hs-source-dirs: app main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports + ghc-options: -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , PaymentServer default-language: Haskell2010 @@ -66,7 +66,7 @@ executable PaymentServer-exe executable PaymentServer-generate-key hs-source-dirs: generate-key main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports + ghc-options: -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , text , PaymentServer @@ -75,7 +75,7 @@ executable PaymentServer-generate-key executable PaymentServer-get-public-key hs-source-dirs: get-public-key main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports + ghc-options: -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , text , optparse-applicative @@ -85,7 +85,7 @@ executable PaymentServer-get-public-key executable PaymentServer-complete-payment hs-source-dirs: complete-payment main-is: Main.hs - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports + ghc-options: -Werror -threaded -rtsopts -with-rtsopts=-N build-depends: base , time , text @@ -132,6 +132,7 @@ test-suite PaymentServer-tests , stripe-core , PaymentServer default-language: Haskell2010 + ghc-options: -Wall -Wno-name-shadowing source-repository head type: git diff --git a/complete-payment/Main.hs b/complete-payment/Main.hs index b41a3a3..7c609d0 100644 --- a/complete-payment/Main.hs +++ b/complete-payment/Main.hs @@ -40,8 +40,6 @@ import Options.Applicative ( Parser , ParserInfo , strOption - , option - , auto , long , help , showDefault diff --git a/generate-key/Main.hs b/generate-key/Main.hs index 723c9aa..1c6323e 100644 --- a/generate-key/Main.hs +++ b/generate-key/Main.hs @@ -3,17 +3,11 @@ module Main ( main ) where -import Prelude hiding - ( putStrLn - ) - -import Data.Text.IO - ( putStrLn - ) +import qualified Data.Text.IO as TIO import PaymentServer.Ristretto ( randomSigningKey ) main :: IO () -main = randomSigningKey >>= putStrLn +main = randomSigningKey >>= TIO.putStrLn diff --git a/get-public-key/Main.hs b/get-public-key/Main.hs index 4127ec1..34c1400 100644 --- a/get-public-key/Main.hs +++ b/get-public-key/Main.hs @@ -3,15 +3,7 @@ module Main ( main ) where -import Prelude hiding - ( putStrLn - , getLine - ) - -import Data.Text.IO - ( putStrLn - , getLine - ) +import qualified Data.Text.IO as TIO import Options.Applicative ( ParserInfo @@ -37,4 +29,4 @@ opts = info (pure () <**> helper) main :: IO () main = - execParser opts >> getLine >>= getPublicKey >>= putStrLn + execParser opts >> TIO.getLine >>= getPublicKey >>= TIO.putStrLn diff --git a/src/PaymentServer/Main.hs b/src/PaymentServer/Main.hs index 22c73bc..1c835ea 100644 --- a/src/PaymentServer/Main.hs +++ b/src/PaymentServer/Main.hs @@ -110,7 +110,6 @@ import Options.Applicative import System.Exit ( exitFailure ) -import Data.Semigroup ((<>)) import qualified Data.Text.IO as TIO import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Char8 @@ -264,6 +263,7 @@ main = do logEndpoint (endpoint config) run app +getPortNumber :: Endpoint -> Port getPortNumber (TCPEndpoint portNumber) = portNumber getPortNumber (TLSEndpoint portNumber _ _ _) = portNumber @@ -272,7 +272,7 @@ getRunner endpoint = let onException :: Maybe Request -> SomeException -> IO () onException _ exc = do - print "onException" + print ("onException" :: Text) print exc return () onExceptionResponse :: SomeException -> Response @@ -310,12 +310,12 @@ getApp config = (Ristretto, Just keyPath) -> do key <- TIO.readFile keyPath return $ Right $ ristrettoIssue key - _ -> return $ Left "invalid options" + _ -> return $ Left ("invalid options" :: Text) getDatabase ServerConfig{ database, databasePath } = case (database, databasePath) of (Memory, Nothing) -> Right memory (SQLite3, Just path) -> Right (sqlite path) - _ -> Left "invalid options" + _ -> Left ("invalid options" :: Text) stripeConfig ServerConfig { stripeKeyPath @@ -339,7 +339,7 @@ getApp config = in do issuer <- getIssuer config case issuer of - Left err -> do + Left err -> do -- XXX shae turn this into a monad instead of a stairstep print err exitFailure Right issuer -> diff --git a/src/PaymentServer/Persistence.hs b/src/PaymentServer/Persistence.hs index de0d72b..83495d5 100644 --- a/src/PaymentServer/Persistence.hs +++ b/src/PaymentServer/Persistence.hs @@ -71,7 +71,7 @@ instance Exception PaymentError instance Eq PaymentError where AlreadyPaid == AlreadyPaid = True PaymentFailed self == PaymentFailed other = show self == show other - self == other = False + _self == _other = False -- | Reasons that a voucher cannot be redeemed. data RedeemError = @@ -181,7 +181,7 @@ data VoucherDatabaseState = | SQLiteDB { connect :: IO Sqlite.Connection } instance VoucherDatabase VoucherDatabaseState where - payForVoucher MemoryDB{ paid = paidRef, redeemed = redeemed } voucher pay = do + payForVoucher MemoryDB{ paid = paidRef } voucher pay = do -- Surely far from ideal... paid <- readIORef paidRef if Set.member voucher paid @@ -237,6 +237,8 @@ instance VoucherDatabase VoucherDatabaseState where transformBusy (Sqlite.SQLError Sqlite.ErrorBusy _ _) = return . Left $ DatabaseUnavailable + -- XXX things went poorly, should we handle with more detail? + transformBusy panic = error $ "redeemVoucherHelper got bad input " <> show panic -- | Look up the voucher, counter tuple which previously performed a @@ -369,7 +371,7 @@ insertVoucher dbConn voucher pay = Right _ -> do Sqlite.execute dbConn "INSERT INTO vouchers (name, charge_id) VALUES (?, ?)" (voucher, Nothing :: Maybe Text) return result - Left err -> + Left _err -> return result -- | Mark the given voucher as having been redeemed (with the given @@ -392,6 +394,7 @@ sqlite path = let exec = Sqlite.execute_ dbConn exec "PRAGMA busy_timeout = 60000" exec "PRAGMA foreign_keys = ON" + -- XXX handle any upgrade failures here! Sqlite.withExclusiveTransaction dbConn (upgradeSchema latestVersion dbConn) return dbConn @@ -494,7 +497,7 @@ upgradeSchema targetVersion conn = do oneStep :: [Sqlite.Query] -> IO [()] oneStep = mapM $ Sqlite.execute_ conn in do - mapM oneStep upgrades + mapM_ oneStep upgrades return $ Right () diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs index bf4ea67..2a6766c 100644 --- a/src/PaymentServer/Processors/Stripe.hs +++ b/src/PaymentServer/Processors/Stripe.hs @@ -76,17 +76,14 @@ import Servant.API ( Header , ReqBody , JSON - , OctetStream - , PlainText , Post , Accept(contentType) , MimeUnrender(mimeUnrender) , (:>) ) import Web.Stripe.Event - ( Event(Event, eventId, eventType, eventData) - , EventId(EventId) - , EventType(ChargeSucceededEvent, CheckoutSessionCompleted, PaymentIntentCreated) + ( Event(Event, eventType, eventData) + , EventType(CheckoutSessionCompleted) , EventData(ChargeEvent, CheckoutSessionEvent) ) @@ -109,8 +106,7 @@ import Web.Stripe.Charge , TokenId(TokenId) ) import Web.Stripe.Client - ( StripeConfig(StripeConfig, secretKey) - , StripeKey(StripeKey) + ( StripeConfig ) import Web.Stripe ( stripe @@ -130,7 +126,6 @@ import PaymentServer.Persistence , ProcessorResult ) import Data.Data (Typeable) -import Servant.API.ContentTypes (AcceptHeader(AcceptHeader)) data Acknowledgement = Ok deriving (Eq, Show) @@ -164,8 +159,8 @@ getVoucher Event{eventData=(ChargeEvent charge)} = voucherFromMetadata . chargeMetaData $ charge where voucherFromMetadata (MetaData []) = Nothing - voucherFromMetadata (MetaData (("Voucher", value):xs)) = Just value - voucherFromMetadata (MetaData (x:xs)) = voucherFromMetadata (MetaData xs) + voucherFromMetadata (MetaData (("Voucher", value):_)) = Just value + voucherFromMetadata (MetaData (_:xs)) = voucherFromMetadata (MetaData xs) getVoucher _ = Nothing chargeServer :: VoucherDatabase d => StripeConfig -> d -> Server ChargesAPI @@ -215,7 +210,7 @@ webhookServer WebhookConfig { webhookConfigKey } d (Just signatureText) payload -- should be able to indicate error I guess. _ <- liftIO . payForVoucher d v . return . Right $ () return Ok - Right event@Event { eventType } -> + Right Event { eventType } -> throwError . jsonErr status400 . pack $ "unsupported event type " ++ show eventType -- | Browser facing API that takes token, voucher and a few other information @@ -280,8 +275,7 @@ charge stripeConfig d (Charges token voucher 650 USD) = do throwError $ voucherAlreadyPaid "Payment for voucher already supplied" Left (PaymentFailed (StripeError { errorType = errorType, errorMsg = msg })) -> do - liftIO $ print "Stripe createCharge failed:" - liftIO $ print msg + liftIO $ print $ "Stripe createCharge failed: " <> msg let err = errorForStripe errorType ( Data.Text.concat [ "Stripe charge didn't succeed: ", msg ]) throwError err @@ -336,6 +330,7 @@ charge stripeConfig d (Charges token voucher 650 USD) = do charge _ _ (Charges _ _ 650 _) = throwError (jsonErr status400 "Unsupported currency") -- The wrong amount charge _ _ (Charges _ _ _ USD) = throwError (jsonErr status400 "Incorrect charge amount") +charge badInput1 _badInput2 badInput3 = error $ mconcat ["charge got unexpected input : ", show badInput1, " ", "some VoucherDatabase value", " ", show badInput3] jsonErr :: Status -> Text -> ServerError jsonErr (Status statusCode statusMessage) detail = ServerError diff --git a/src/PaymentServer/Redemption.hs b/src/PaymentServer/Redemption.hs index 02e2bbd..a25a251 100644 --- a/src/PaymentServer/Redemption.hs +++ b/src/PaymentServer/Redemption.hs @@ -17,10 +17,6 @@ module PaymentServer.Redemption , redemptionServer ) where -import Prelude hiding - ( concat - ) - import GHC.Generics ( Generic ) @@ -39,8 +35,8 @@ import Control.Monad.IO.Class import Data.Text ( Text , pack - , concat ) +import qualified Data.Text as Text import Data.Text.Encoding ( encodeUtf8 ) @@ -176,6 +172,7 @@ instance FromJSON Result where type RedemptionAPI = ReqBody '[JSON] Redeem :> Post '[JSON] Result +jsonErr :: ToJSON a => ServerError -> a -> ServerError jsonErr err reason = err { errBody = encode reason , errHeaders = [ ("Content-Type", "application/json;charset=utf-8") ] @@ -198,7 +195,7 @@ retry op = numRetries = totalRetryDuration `div` perRetryDelay policy = constantDelay (perRetryDelay * 1000) <> limitRetries numRetries - shouldRetry status value = + shouldRetry _status value = case value of Left NotPaid -> return True _ -> return False @@ -290,4 +287,4 @@ signaturesIssued -- be used as an identifier for this exact sequence of tokens. fingerprintFromTokens :: [BlindedToken] -> Fingerprint fingerprintFromTokens = - pack . show . hashWith SHA3_512 . encodeUtf8 . concat + pack . show . hashWith SHA3_512 . encodeUtf8 . Text.concat diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs index 4115989..63f5bc2 100644 --- a/src/PaymentServer/Server.hs +++ b/src/PaymentServer/Server.hs @@ -52,9 +52,6 @@ import PaymentServer.Metrics ( MetricsAPI , metricsServer ) -import PaymentServer.Issuer - ( Issuer - ) import PaymentServer.Persistence ( VoucherDatabase ) diff --git a/test/FakeStripe.hs b/test/FakeStripe.hs index d48da37..202a6e8 100644 --- a/test/FakeStripe.hs +++ b/test/FakeStripe.hs @@ -18,15 +18,6 @@ import Data.ByteString.Lazy ( ByteString ) -import Data.Time.Clock - ( UTCTime(UTCTime) - , secondsToDiffTime - ) - -import Data.Time.Calendar - ( Day(ModifiedJulianDay) - ) - import Network.HTTP.Types ( status200 , status400 @@ -183,11 +174,11 @@ aCharge = [r| -- Accept a charge creation and respond in the affirmative. chargeOkay :: Application -chargeOkay req respond = +chargeOkay _req respond = respond . responseLBS status200 [] $ aCharge chargeFailed :: ByteString -> Application -chargeFailed stripeResponse req respond = +chargeFailed stripeResponse _req respond = respond . responseLBS status400 [] $ stripeResponse -- Pass a Stripe-flavored configuration for a running Wai application to a diff --git a/test/Metrics.hs b/test/Metrics.hs index d232808..68885a0 100644 --- a/test/Metrics.hs +++ b/test/Metrics.hs @@ -16,9 +16,7 @@ import Test.Tasty ) import Test.Tasty.HUnit - ( testCase - , assertEqual - ) + ( testCase ) import Network.HTTP.Types ( methodGet @@ -48,6 +46,7 @@ import Prometheus , unsafeRegister , counter , incCounter + , Counter ) import PaymentServer.Metrics @@ -73,12 +72,13 @@ readMetrics = request $ setPath defaultRequest { requestMethod = methodGet } "/m -- Register a counter at the top-level because the registry is global and this -- lets us avoid thinking about collisions or unregistration. unsafeRegister -- is (only) safe for defining a top-level symbol. +aCounter :: Counter aCounter = unsafeRegister $ counter (Info "a_counter" "A test counter.") +-- | A ``GET /metrics`` request receives a text/plain OK response containing +-- current Prometheus-formatted metrics information. metricsTests :: TestTree metricsTests = - -- | A ``GET /metrics`` request receives a text/plain OK response containing - -- current Prometheus-formatted metrics information. testCase "plaintext metrics response" $ let app :: Application diff --git a/test/Persistence.hs b/test/Persistence.hs index f946231..c815aa5 100644 --- a/test/Persistence.hs +++ b/test/Persistence.hs @@ -61,6 +61,8 @@ import PaymentServer.Persistence , readVersion ) +import Control.Monad (void) + data ArbitraryException = ArbitraryException deriving (Show, Eq) @@ -74,9 +76,13 @@ tests = testGroup "Persistence" ] -- Some dummy values that should be replaced by the use of QuickCheck. +voucher :: Voucher voucher = "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa" +anotherVoucher :: Voucher anotherVoucher = "zzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzzz" +fingerprint :: Fingerprint fingerprint = "bbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbbb" +anotherFingerprint :: Fingerprint anotherFingerprint = "cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc" aChargeId :: ChargeId @@ -228,7 +234,7 @@ sqlite3DatabaseVoucherPaymentTests = where makeDatabase = do tempdir <- getTemporaryDirectory - (path, handle) <- openTempFile tempdir "voucher-.db" + (path, _handle) <- openTempFile tempdir "voucher-.db" return . sqlite . Text.pack $ path genericTests = makeVoucherPaymentTests "sqlite3" makeDatabase @@ -248,6 +254,7 @@ sqlite3DatabaseVoucherPaymentTests = let expected = Left DatabaseUnavailable result <- redeemVoucher fastBusyConn voucher fingerprint assertEqual "Redeeming voucher while database busy" expected result + _ -> error "srsly, what?" -- XXX does this need explicit connection closing? ] where fastBusyConnection @@ -270,7 +277,7 @@ sqlite3DatabaseSchemaTests = -- hurt to target every intermediate version specifically, though. I -- think that's what SmallCheck is for? Sqlite.withConnection ":memory:" $ \conn -> do - upgradeSchema latestVersion conn + void $ upgradeSchema latestVersion conn let expected = Right latestVersion actual <- readVersion conn assertEqual "The recorded schema version should be the latest value" expected actual @@ -285,7 +292,7 @@ sqlite3DatabaseSchemaTests = , testCase "identify version 1" $ -- readVersion identifies schema version 1 Sqlite.withConnection ":memory:" $ \conn -> do - upgradeSchema 1 conn + void $ upgradeSchema 1 conn let expected = Right 1 actual <- readVersion conn assertEqual "readVersion identifies database schema version 1" expected actual @@ -293,7 +300,7 @@ sqlite3DatabaseSchemaTests = , testCase "identify version 2" $ -- readVersion identifies schema version 1 Sqlite.withConnection ":memory:" $ \conn -> do - upgradeSchema 2 conn + void $ upgradeSchema 2 conn let expected = Right 2 actual <- readVersion conn assertEqual "readVersion identifies database schema version 2" expected actual diff --git a/test/Redemption.hs b/test/Redemption.hs index f435b7a..d688eef 100644 --- a/test/Redemption.hs +++ b/test/Redemption.hs @@ -12,25 +12,17 @@ import Test.Tasty ) import Test.Tasty.HUnit - ( testCase - , assertEqual - ) + ( testCase ) import Data.Aeson ( encode ) -import Network.Wai.Handler.Warp - ( testWithApplication - ) - import Network.Wai.Test ( SRequest(SRequest) , runSession - , request , srequest , defaultRequest - , assertHeader , assertStatus , setPath ) @@ -65,6 +57,8 @@ import FakeStripe , ChargeId(ChargeId) ) +import Control.Monad ( void ) + tests :: TestTree tests = testGroup "Redemption" [ redemptionTests @@ -131,7 +125,7 @@ redemptionTests = withFakeStripe (return chargeOkay) $ \webhookConfig stripeConfig -> do db <- memory - payForVoucher db aVoucher (return $ Right $ ChargeId "xyz") + void $ payForVoucher db aVoucher (return $ Right $ ChargeId "xyz") -- It would be nice if we exercised `getApp` here instead of doing it -- all ourselves. diff --git a/test/Ristretto.hs b/test/Ristretto.hs index 2d83534..64d9025 100644 --- a/test/Ristretto.hs +++ b/test/Ristretto.hs @@ -19,7 +19,7 @@ import Test.Tasty.HUnit ) import PaymentServer.Ristretto - ( Issuance(Issuance, publicKey, signatures, proof) + ( Issuance(Issuance, publicKey, signatures) , ristretto , randomSigningKey , randomToken @@ -42,7 +42,7 @@ issueTests = testGroup "Issuance" let blindedTokens = [aBlindToken] result <- ristretto key blindedTokens case result of - (Right Issuance { publicKey, signatures, proof }) -> do + (Right Issuance { publicKey, signatures }) -> do assertEqual "The public key matches the signing key." expectedPublicKey publicKey assertEqual "The number of signatures equals the number of tokens." (length blindedTokens) (length signatures) -- XXX The proof checks out diff --git a/test/Spec.hs b/test/Spec.hs index 2c1646c..633b28f 100644 --- a/test/Spec.hs +++ b/test/Spec.hs @@ -25,4 +25,5 @@ tests = testGroup "Tests" , Ristretto.tests ] +main :: IO () main = defaultMain tests diff --git a/test/Stripe.hs b/test/Stripe.hs index a1b8aa6..9f400f0 100644 --- a/test/Stripe.hs +++ b/test/Stripe.hs @@ -22,9 +22,9 @@ import Test.Tasty import Test.Tasty.HUnit ( testCase , assertEqual + , assertBool ) - import Data.Text.Lazy.Encoding ( encodeUtf8 ) @@ -34,11 +34,7 @@ import Data.Text.Lazy , concat ) -import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import Control.Monad.IO.Class - ( liftIO - ) import Control.Monad.Trans.Except ( runExceptT @@ -75,7 +71,6 @@ import Network.Wai.Test ( SRequest(SRequest) , SResponse(simpleStatus, simpleBody) , runSession - , request , srequest , defaultRequest , assertHeader @@ -88,8 +83,7 @@ import Network.Wai ) import PaymentServer.Persistence - ( Voucher - , RedeemError(NotPaid) + ( RedeemError(NotPaid) , memory , payForVoucher , redeemVoucher @@ -101,7 +95,6 @@ import PaymentServer.Processors.Stripe , Failure(Failure) , WebhookConfig(WebhookConfig) , charge - , webhookServer , stripeSignature ) @@ -121,6 +114,8 @@ import FakeStripe , cardError , apiError ) +import Data.Maybe ( isJust ) +import Control.Monad ( void ) tests :: TestTree tests = testGroup "Stripe" @@ -150,7 +145,7 @@ corsTests = , testCase "a request with an already-paid voucher receives a CORS-enabled response" $ do let pay = return . Right . ChargeId $ "abc" db <- memory - payForVoucher db (toStrict alreadyPaidVoucher') pay + void $ payForVoucher db (toStrict alreadyPaidVoucher') pay assertCORSHeader' db chargeOkay "POST" applicationJSON (alreadyPaidVoucher alreadyPaidVoucher') ] where @@ -191,7 +186,7 @@ chargeTests :: TestTree chargeTests = testGroup "Charges" [ testCase "non-USD currency is rejected" $ - withFakeStripe (return chargeOkay) $ \webhookConfig stripeConfig -> do + withFakeStripe (return chargeOkay) $ \_webhookConfig stripeConfig -> do let amount = 650 let currency = AED db <- memory @@ -201,7 +196,7 @@ chargeTests = assertEqual "The JSON body includes the reason" (Just $ Failure "Unsupported currency") (decode body) , testCase "incorrect USD amount is rejected" $ - withFakeStripe (return chargeOkay) $ \webhookConfig stripeConfig -> do + withFakeStripe (return chargeOkay) $ \_webhookConfig stripeConfig -> do let amount = 649 let currency = USD db <- memory @@ -211,7 +206,7 @@ chargeTests = assertEqual "The JSON body includes the reason" (Just $ Failure "Incorrect charge amount") (decode body) , testCase "a Stripe charge failure is propagated" $ - withFakeStripe (return (chargeFailed cardError)) $ \webhookConfig stripeConfig -> do + withFakeStripe (return (chargeFailed cardError)) $ \_webhookConfig stripeConfig -> do let amount = 650 let currency = USD db <- memory @@ -223,17 +218,17 @@ chargeTests = (Just $ Failure "Stripe charge didn't succeed: Your card is expired.") (decode body) , testCase "the HTTP error code is derived from the specific failure" $ - withFakeStripe (return (chargeFailed apiError)) $ \webhookConfig stripeConfig -> do + withFakeStripe (return (chargeFailed apiError)) $ \_webhookConfig stripeConfig -> do let amount = 650 let currency = USD db <- memory - (Left (ServerError code phrase body _)) <- runExceptT . runHandler' $ charge stripeConfig db (Charges token voucher amount currency) + (Left (ServerError code phrase _body _)) <- runExceptT . runHandler' $ charge stripeConfig db (Charges token voucher amount currency) -- The `apiError` is for a Stripe API error. assertEqual "The result is an error" 503 code assertEqual "The HTTP phrase matches the code" "Service Unavailable" phrase , testCase "currect USD amount is accepted" $ - withFakeStripe (return chargeOkay) $ \webhookConfig stripeConfig -> do + withFakeStripe (return chargeOkay) $ \_webhookConfig stripeConfig -> do let amount = 650 let currency = USD db <- memory @@ -294,7 +289,7 @@ webhookTests = response <- (flip runSession) app $ srequest theSRequest -- It should fail but we don't really care what the message is. - let (Just (Failure _)) = decode . simpleBody $ response + assertBool "pattern matches" $ isJust $ (decode . simpleBody $ response :: Maybe Failure) assertEqual "The response is 400" status400 (simpleStatus response) , testCase "If the request body contains a checkout.session.completed event and the signature is correct then the voucher is marked as paid and the response is OK" $ do @@ -329,7 +324,7 @@ webhookTests = assertResponse status200 (db, response) return db - assertResponse status (db, response) = + assertResponse status (_, response) = assertEqual ("The response is " ++ (show status)) status (simpleStatus response) -- Assert that the database allows us to redeem a voucher, demonstrating