From 36670d1b17f736b4d61f8546d403a914b760665a Mon Sep 17 00:00:00 2001
From: Jean-Paul Calderone <exarkun@twistedmatrix.com>
Date: Thu, 22 Aug 2019 12:34:01 -0400
Subject: [PATCH] Try this with Tasty
It's sort of a meaningless change. Blech.
---
PaymentServer.cabal | 13 +++-
test/Driver.hs | 8 +++
test/SpecStripe.hs | 67 ++++++++++++++++++++
test/{Spec.hs => Util/Gen.hs} | 64 ++------------------
test/Util/JSON.hs | 111 ++++++++++++++++++++++++++++++++++
test/Util/WAI.hs | 24 ++++++++
6 files changed, 227 insertions(+), 60 deletions(-)
create mode 100644 test/Driver.hs
create mode 100644 test/SpecStripe.hs
rename test/{Spec.hs => Util/Gen.hs} (72%)
create mode 100644 test/Util/JSON.hs
create mode 100644 test/Util/WAI.hs
diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 0cc0fb6..b24d075 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -35,7 +35,11 @@ executable PaymentServer-exe
test-suite PaymentServer-test
type: exitcode-stdio-1.0
hs-source-dirs: test
- main-is: Spec.hs
+ main-is: Driver.hs
+ other-modules: SpecStripe
+ , Util.WAI
+ , Util.Gen
+ , Util.JSON
build-depends: base
, PaymentServer
, hspec
@@ -50,6 +54,13 @@ test-suite PaymentServer-test
, bytestring
, text
, http-types
+ , tasty
+ , tasty-th
+ , tasty-discover
+ , tasty-hspec
+ , tasty-hedgehog
+ , tasty-quickcheck
+ , hedgehog
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
diff --git a/test/Driver.hs b/test/Driver.hs
new file mode 100644
index 0000000..f2287e7
--- /dev/null
+++ b/test/Driver.hs
@@ -0,0 +1,8 @@
+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}
+
+-- This is a module where we can hang the above preprocessor definition to
+-- direct tasty-discover to find our test suite spread across the rest of the
+-- modules rooted in this directory.
+--
+-- See the test-suite definition in PaymentServer.cabal
+-- See also https://git.coop/decentral1se/tasty-discover
diff --git a/test/SpecStripe.hs b/test/SpecStripe.hs
new file mode 100644
index 0000000..6388d85
--- /dev/null
+++ b/test/SpecStripe.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+--
+-- Test suite for Stripe support in the payment server.
+--
+
+module SpecStripe where
+
+import Data.ByteString as BS
+import Data.ByteString.Lazy as LazyBS
+import Data.Aeson
+ ( encode
+ )
+import Test.Hspec
+ ( Spec
+ , describe
+ , it
+ )
+import Test.Hspec.Wai
+ ( WaiSession
+ , WaiExpectation
+ , with
+ , post
+ , shouldRespondWith
+ , liftIO
+ )
+import Test.Hspec.Wai.QuickCheck
+ ( -- Get Test.QuickCheck.Property.Testable instance for WaiExpectation
+ property
+ )
+import Test.QuickCheck
+ ( generate
+ )
+import Util.WAI
+ ( postJSON
+ )
+import Util.Gen
+ ( chargeSucceededEvents
+ )
+import Util.JSON
+ ( -- ToJSON instance for Event
+ )
+import Lib
+ ( app
+ )
+
+aChargeEvent :: IO LazyBS.ByteString
+aChargeEvent = encode <$> generate chargeSucceededEvents
+
+spec_webhook :: Spec
+spec_webhook = with (return app) $
+ -- I would like to make these property tests but I can't figure out how to
+ -- use QuickCheck (or Hedgehog) to write property tests for web code.
+
+ describe "error behavior of POST /webhook" $ do
+ it "responds to non-JSON Content-Type with 400 (Invalid Request)" $
+ post "/webhook" "xxx" `shouldRespondWith` 400
+
+ it "responds to JSON non-Event body with 400 (Invalid Request)" $
+ postJSON "/webhook" "{}" `shouldRespondWith` 400
+
+spec_webhook' :: Spec
+spec_webhook' = with (return app) $
+ describe "success behavior of POST /webhook" $ do
+ it "responds to a JSON Event body with 200 (OK)" $ do
+ event <- liftIO aChargeEvent
+ postJSON "/webhook" event `shouldRespondWith` 200
diff --git a/test/Spec.hs b/test/Util/Gen.hs
similarity index 72%
rename from test/Spec.hs
rename to test/Util/Gen.hs
index 211811b..1798441 100644
--- a/test/Spec.hs
+++ b/test/Util/Gen.hs
@@ -1,13 +1,8 @@
-{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
-module Main (main) where
-import Lib
- ( app
- )
-
-import Data.ByteString.Lazy as LazyBS
-import Data.ByteString as BS
+module Util.Gen
+ ( chargeSucceededEvents
+ ) where
import Data.Text
( Text
@@ -17,10 +12,6 @@ import Data.Time.Clock
( UTCTime
)
-import Data.Aeson
- ( encode
- )
-
import Web.Stripe.Types
( Charge(Charge)
, StatementDescription(StatementDescription)
@@ -42,32 +33,10 @@ import Web.Stripe.Event
, EventId(EventId)
)
-import Test.Hspec
- ( Spec
- , hspec
- , describe
- , it
- )
-import Test.Hspec.Wai
- ( WaiSession
- , with
- , post
- , request
- , shouldRespondWith
- )
-import Network.Wai.Test
- ( SResponse
- )
-
-import Network.HTTP.Types.Method
- ( methodPost
- )
import Test.QuickCheck
( Gen
, Arbitrary
- , forAll
- , property
, arbitrary
)
@@ -78,19 +47,10 @@ import Test.QuickCheck.Instances.Text
( -- Get the `Gen Text` instance
)
-main :: IO ()
-main = hspec spec
-
--- Post some JSON to a path.
--- Return a function from path to a response
-postJSON :: BS.ByteString -> (LazyBS.ByteString -> WaiSession SResponse)
-postJSON path =
- request methodPost path [("Content-Type", "application/json")]
-
instance Arbitrary Charge where
arbitrary = Charge
<$> arbitrary -- chargeId :: ChargeId
- <*> arbitrary -- chargeObject :: Text
+ <*> (return "charge") -- chargeObject :: Text
<*> arbitrary -- chargeCreated :: UTCTime
<*> arbitrary -- chargeLiveMode :: Bool
<*> arbitrary -- chargePaid :: Bool
@@ -167,20 +127,6 @@ chargeSucceededEvents =
<*> (ChargeEvent
<$> arbitrary -- the charge
) -- eventData
- <*> arbitrary -- eventObject
+ <*> (return "event") -- eventObject
<*> arbitrary -- eventPendingWebHooks
<*> arbitrary -- eventRequest
-
-spec :: Spec
-spec = with (return app) $ do
- describe "error behavior of POST /webhook" $ do
- it "responds to non-JSON Content-Type with 400 (Invalid Request)" $
- post "/webhook" "{}" `shouldRespondWith` 400
-
- it "responds to JSON non-Event body with 400 (Invalid Request)" $
- postJSON "/webhook" "{}" `shouldRespondWith` 400
-
- describe "success behavior of POST /webhook" $ do
- it "responds to JSON-encoded Event body with 200 (OK)" $
- forAll chargeSucceededEvents $ \event ->
- postJSON "/webhook" (encode event) `shouldRespondWith` 200
diff --git a/test/Util/JSON.hs b/test/Util/JSON.hs
new file mode 100644
index 0000000..fda5e90
--- /dev/null
+++ b/test/Util/JSON.hs
@@ -0,0 +1,111 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Util.JSON where
+
+import Web.Stripe.Types
+ ( Charge(Charge)
+ , ChargeId(ChargeId)
+ , InvoiceId(InvoiceId)
+ , Amount(Amount)
+ , Currency(USD)
+ )
+import Web.Stripe.Event
+ ( Event(Event)
+ , EventData(ChargeEvent)
+ , EventType(ChargeSucceededEvent)
+ , EventId(EventId)
+ )
+
+import Data.Aeson
+ ( ToJSON(toJSON)
+ , Value(String, Number)
+ , object
+ , (.=)
+ )
+
+instance ToJSON Event where
+ toJSON (Event
+ eventId
+ eventCreated
+ eventLiveMode
+ eventType
+ eventData
+ eventObject
+ eventPendingWebHooks
+ eventRequest)
+ = object
+ [ "id" .= eventId
+ , "object" .= eventObject
+ , "api_version" .= String "2018-05-21"
+ , "created" .= eventCreated
+ , "data" .= object [ "object" .= eventData ]
+ , "type" .= eventType
+ , "livemode" .= eventLiveMode
+ , "pending_webhooks" .= eventPendingWebHooks
+ , "request" .= eventRequest
+ ]
+
+instance ToJSON EventId where
+ toJSON (EventId eId) = String eId
+
+instance ToJSON InvoiceId where
+ toJSON (InvoiceId iId) = String iId
+
+instance ToJSON ChargeId where
+ toJSON (ChargeId cId) = String cId
+
+instance ToJSON Currency where
+ toJSON USD = "USD"
+
+instance ToJSON EventType where
+ toJSON ChargeSucceededEvent = "charge.succeeded"
+
+instance ToJSON EventData where
+ toJSON (ChargeEvent charge) = toJSON charge
+
+instance ToJSON Amount where
+ toJSON (Amount a) = Number $ fromIntegral a
+
+instance ToJSON Charge where
+ toJSON (Charge
+ chargeId
+ chargeObject
+ chargeCreated
+ chargeLiveMode
+ chargePaid
+ chargeAmount
+ chargeCurrency
+ chargeRefunded
+ chargeCreditChard
+ chargeCaptured
+ chargeRefunds
+ chargeBalanceTransaction
+ chargeFailureMessage
+ chargeFailureCode
+ chargeAmountRefunded
+ chargeCustomerId
+ chargeInvoice
+ chargeDescription
+ chargeDispute
+ chargeMetaData
+ chargeStatementDescription
+ chargeReceiptEmail
+ chargeNumber
+ )
+ = object
+ [ "id" .= chargeId
+ , "object" .= chargeObject
+ , "amount" .= chargeAmount
+ -- , "amount_refunded" .= chargeAmountRefunded
+ -- , "balance_transaction" .= chargeBalanceTransaction
+ , "captured" .= chargeCaptured
+ , "created" .= chargeCreated
+ , "currency" .= chargeCurrency
+ -- , "customer" .= chargeCustomerId
+ -- , "description" .= chargeDescription
+ -- , "dispute" .= chargeDispute
+ -- , "failure_code" .= chargeFailureCode
+ -- , "failure_message" .= chargeFailureMessage
+ -- , "invoice" .= chargeInvoice
+ , "livemode" .= chargeLiveMode
+ ]
diff --git a/test/Util/WAI.hs b/test/Util/WAI.hs
new file mode 100644
index 0000000..53d29ff
--- /dev/null
+++ b/test/Util/WAI.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Util.WAI
+ ( postJSON
+ ) where
+
+import Data.ByteString.Lazy as LazyBS
+import Data.ByteString as BS
+import Test.Hspec.Wai
+ ( WaiSession
+ , request
+ )
+import Network.HTTP.Types.Method
+ ( methodPost
+ )
+import Network.Wai.Test
+ ( SResponse
+ )
+
+-- Post some JSON to a path.
+-- Return a function from path to a response
+postJSON :: BS.ByteString -> (LazyBS.ByteString -> WaiSession SResponse)
+postJSON path =
+ request methodPost path [("Content-Type", "application/json")]
--
GitLab