diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 0cc0fb6fc71b823d4353fd4deacbaf8adfd9295b..b24d075397df0785213855345ec5f4643e5fcb35 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 0000000000000000000000000000000000000000..f2287e7136655bb1b55f1262258bcbd21bb32cb8
--- /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 0000000000000000000000000000000000000000..6388d85f3307d611e340f4f12ed9fff84a066eb8
--- /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 211811b473da03d8133c33f4adeb932f71f5a8b5..17984419ed158fe09ad6b5152b69fa085758ac36 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 0000000000000000000000000000000000000000..fda5e9039a9ad02a73a97f530c4e89077310eef2
--- /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 0000000000000000000000000000000000000000..53d29ff74af1c937a477b89390868a23d7090d3d
--- /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")]