diff --git a/.circleci/config.yml b/.circleci/config.yml
index da126d8a83de1c0378b9b5907d178320022b2854..e60115f100dde8f1b2551b964f95e6fd30ebfb9c 100644
--- a/.circleci/config.yml
+++ b/.circleci/config.yml
@@ -15,7 +15,7 @@
version: 2.1
jobs:
- test:
+ build:
docker:
# Run in a highly Nix-capable environment. This lets us use Stack's nix
# integration and other useful Nix features to specify and run the
@@ -89,8 +89,6 @@ jobs:
--no-terminal \
--only-dependencies \
--fast \
- --test \
- --no-run-tests \
--jobs 1 \
--interleaved-output"
nix-shell shell.nix --run "$BUILD"
@@ -111,7 +109,7 @@ jobs:
- ".stack-work"
- run:
- name: "Run Tests"
+ name: "Building"
command: |
# shell.nix gives us the stack we want. Then stack.yaml specifies
# some more of the Nix-based environment to be able to build and
@@ -129,11 +127,6 @@ jobs:
# times for our dependencies (as well as reduce compiler memory
# usage which may be important at least for stripe-core).
#
- # --test runs the test suite.
- #
- # --coverage gathers coverage information during the test run.
- # Steps below publish the result.
- #
# --haddock builds the Haskell API documentation.
# --haddock-internal builds docs even for unexposed modules.
# --no-haddock-deps skips building docs for all our dependencies.
@@ -141,8 +134,6 @@ jobs:
--no-terminal \
--interleaved-output \
--fast \
- --test \
- --coverage \
--haddock \
--haddock-internal \
--no-haddock-deps"
@@ -161,15 +152,8 @@ jobs:
- run:
name: "Prepare Artifacts for Upload"
command: |
- mv $(nix-shell shell.nix --run "stack path --local-hpc-root") /tmp
mv $(nix-shell shell.nix --run "stack path --local-doc-root")/PaymentServer-* /tmp/PaymentServer-docs
- - store_artifacts:
- # This contains the html coverage report as well as the raw data in
- # .tix format.
- path: "/tmp/hpc"
- destination: "coverage"
-
- store_artifacts:
# This contains the html haddock output for the project.
path: "/tmp/PaymentServer-docs"
@@ -179,4 +163,4 @@ workflows:
version: 2
everything:
jobs:
- - "test"
+ - "build"
diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 7fc38d823cedcaf763bf6304360c2f98a0560925..ebbcb7b59acf57c442131a0adab753ba01983769 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -46,47 +46,6 @@ executable PaymentServer-exe
, PaymentServer
default-language: Haskell2010
-test-suite PaymentServer-test
- type: exitcode-stdio-1.0
- hs-source-dirs: test
- main-is: Driver.hs
- other-modules: SpecStripe
- , SpecPersistence
- , SpecRedemption
- , Util.WAI
- , Util.Gen
- , Util.JSON
- , Util.Spec
- build-depends: base
- , PaymentServer
- , hspec
- , hspec-wai
- , hspec-wai-json
- , hspec-expectations
- , aeson
- , stripe-core
- , time
- , QuickCheck
- , quickcheck-instances
- , checkers
- , wai-extra
- , bytestring
- , text
- , http-types
- , tasty
- , tasty-th
- , tasty-discover
- , tasty-quickcheck
- , tasty-hspec
- , tasty-hunit
- , tasty-wai
- , servant-server
- , containers
- , unordered-containers
- , ilist
- ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wmissing-import-lists -Wunused-imports
- default-language: Haskell2010
-
source-repository head
type: git
location: https://github.com/privatestorageio/PaymentServer
diff --git a/README.rst b/README.rst
index 211cf19bfb7a568f1ad99094911e50072c0a8bb2..069ce2c1d60278551c3b4097e8fd949cc3c0d610 100644
--- a/README.rst
+++ b/README.rst
@@ -16,11 +16,7 @@ Build using Stack::
Testing
-------
-You can run the PaymentServer automated test suite using stack::
-
- $ stack test
-
-You may also want to perform manual integration testing against Stripe.
+You can perform manual integration testing against Stripe.
First, run the server::
$ stack run
diff --git a/test/Driver.hs b/test/Driver.hs
deleted file mode 100644
index f2287e7136655bb1b55f1262258bcbd21bb32cb8..0000000000000000000000000000000000000000
--- a/test/Driver.hs
+++ /dev/null
@@ -1,8 +0,0 @@
-{-# 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/SpecPersistence.hs b/test/SpecPersistence.hs
deleted file mode 100644
index db6d8a5be3f33853454c11bb95f3439b71766128..0000000000000000000000000000000000000000
--- a/test/SpecPersistence.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
---
--- Test suite related to the persistence system.
---
-
-module SpecPersistence where
-
-import Control.Monad.IO.Class
- ( liftIO
- )
-import Test.Hspec
- ( Spec
- , describe
- , it
- )
-import Test.Hspec.Expectations
- ( shouldReturn
- )
-import Test.QuickCheck
- ( Property
- , property
- , (==>)
- )
-import Test.QuickCheck.Monadic
- ( monadicIO
- , run
- , assert
- , pre
- )
-import Test.QuickCheck.Instances.Text
- (
- )
-import PaymentServer.Persistence
- ( RedeemError(NotPaid, AlreadyRedeemed)
- , Voucher
- , Fingerprint
- , VoucherDatabase(payForVoucher, redeemVoucher)
- , memory
- )
-
--- | A voucher which has not been paid for cannot be redeemed.
-unpaidVoucherNotRedeemable :: VoucherDatabase d => IO d -> Property
-unpaidVoucherNotRedeemable getDB = property $ \voucher fingerprint -> do
- db <- liftIO getDB
- redeemVoucher db voucher fingerprint `shouldReturn` Left NotPaid
-
--- | A voucher which is paid for can be redeemed with any fingerprint.
-paidVoucherRedeemable :: VoucherDatabase d => IO d -> Property
-paidVoucherRedeemable getDB = property $ \voucher fingerprint -> do
- db <- liftIO getDB
- () <- payForVoucher db voucher
- redeemVoucher db voucher fingerprint `shouldReturn` Right ()
-
--- | A voucher which is paid for can be redeemed more than once as long as the
--- same fingerprint is used each time.
-paidVoucherMultiRedeemable :: VoucherDatabase d => IO d -> Property
-paidVoucherMultiRedeemable getDB = property $ \voucher fingerprint -> do
- db <- liftIO getDB
- () <- payForVoucher db voucher
- let redeem = redeemVoucher db voucher fingerprint
- redeem
- redeem `shouldReturn` Right ()
-
--- | A voucher which is paid for can not be redeemed a second time with a
--- different fingerprint than was used on the first attempt.
-paidVoucherMismatchFingerprint :: VoucherDatabase d => IO d -> Property
-paidVoucherMismatchFingerprint getDB = property $ \voucher fingerprint fingerprint' ->
- fingerprint /= fingerprint' ==> do
- db <- liftIO getDB
- () <- payForVoucher db voucher
- let redeem = redeemVoucher db voucher
- redeem fingerprint
- redeem fingerprint' `shouldReturn` Left AlreadyRedeemed
-
-makeSpec :: VoucherDatabase d => IO d -> Spec
-makeSpec getDB =
- describe "voucher interactions" $
- do
- it "denies redemption of a not-paid-for voucher" $ unpaidVoucherNotRedeemable getDB
- it "allows redemption of paid-for vouchers" $ paidVoucherRedeemable getDB
- it "allows multiple redemption as long as the same fingerprint is used" $ paidVoucherMultiRedeemable getDB
- it "denies a subsequent redemption with a different fingerprint" $ paidVoucherMismatchFingerprint getDB
-
-spec_memory = makeSpec memory
diff --git a/test/SpecRedemption.hs b/test/SpecRedemption.hs
deleted file mode 100644
index 6e85850aef01062a5f0cf0f00075d7c94d817efb..0000000000000000000000000000000000000000
--- a/test/SpecRedemption.hs
+++ /dev/null
@@ -1,236 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
--- | Test suite related to voucher redemption.
-
-module SpecRedemption where
-
-import Data.ByteString
- ( ByteString
- )
-import Text.Printf
- ( printf
- )
-import Data.Aeson
- ( decode
- , encode
- )
-import Servant
- ( Application
- , Proxy(Proxy)
- , serve
- )
-import Test.Tasty.Providers
- ( TestName
- , singleTest
- )
-import Test.Tasty
- ( TestTree
- , testGroup
- , withResource
- )
-import Test.Tasty.HUnit
- ( Assertion
- , testCase
- )
-import Test.Tasty.Wai
- ( testWai
- , assertStatus'
- , assertBody
- , assertHeader
- , get
- )
-
-import Test.Tasty.QuickCheck
- ( testProperty
- )
-
-import Network.HTTP.Types
- ( status200
- , status405
- )
-
-import Test.Hspec
- ( Spec
- , parallel
- , describe
- , it
- , runIO
- )
-import Network.HTTP.Types
- ( Header
- )
-import Test.Hspec.Wai
- ( ResponseMatcher(matchBody, matchHeaders)
- , (<:>)
- , WaiExpectation
- , Body
- , MatchBody(MatchBody)
- , with
- , shouldRespondWith
- , liftIO
- )
-import Test.QuickCheck
- ( ioProperty
- )
-import Test.Hspec.Wai.QuickCheck
- ( Testable(toProperty)
- , WaiProperty(unWaiProperty)
- , property
- )
-import Test.QuickCheck.Instances.Text ()
-import Util.Spec
- ( wrongMethodNotAllowed
- , nonJSONUnsupportedMediaType
- , wrongJSONInvalidRequest
- )
-import Util.WAI
- ( postJSON
- )
-import PaymentServer.Issuer
- ( BlindedToken
- , ChallengeBypass(ChallengeBypass)
- , Issuer
- , trivialIssue
- )
-import PaymentServer.Redemption
- ( RedemptionAPI
- , Redeem(Redeem)
- , Result(Failed, Succeeded)
- , redemptionServer
- )
-import PaymentServer.Persistence
- ( RedeemError(NotPaid)
- , Voucher
- , VoucherDatabase(payForVoucher, redeemVoucher)
- , memory
- )
-
-redemptionAPI :: Proxy RedemptionAPI
-redemptionAPI = Proxy
-
-app :: VoucherDatabase d => Issuer -> d -> Application
-app issue = serve redemptionAPI . redemptionServer issue
-
-path = "/"
-
-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 trivialIssue 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 trivialIssue (RefuseRedemption NotPaid)) $
- -- it "receives a failure response when the voucher is not paid" $ property $
- -- \(voucher :: Voucher) (tokens :: [BlindedToken]) ->
- -- propertyRedeem path voucher tokens 400
- -- { matchBody = matchJSONBody Failed
- -- -- major/minor, fine. charset=utf-8... okay. but really this is
- -- -- overspecified by encoding the exact byte sequence. I'd rather
- -- -- assert semantic equality.
- -- , matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
- -- }
-
- -- with (return $ app trivialIssue PermitRedemption) $
- -- it "receive a success response when redemption succeeds" $ property
- -- \(voucher :: Voucher) (tokens :: [BlindedToken]) -> do
- -- (ChallengeBypass key signatures proof) <- trivialIssue tokens
- -- return $
- -- propertyRedeem path voucher tokens 200
- -- { matchBody = matchJSONBody $ Succeeded key signatures proof
- -- , matchHeaders = ["Content-Type" <:> "application/json;charset=utf-8"]
- -- }
-
- -- 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
-
-matchJSONBody :: Result -> MatchBody
-matchJSONBody expected =
- let
- bodyMatcher :: [Header] -> Body -> Maybe String
- bodyMatcher headers actualBody =
- case decode actualBody of
- Nothing ->
- Just $ "failed to decode body as value of expected type: " ++ show actualBody
- Just actual ->
- if actual == expected then
- Nothing
- else
- Just $ "decoded body does not equal expected value: " ++ show actual ++ show expected
- in
- MatchBody bodyMatcher
-
--- testWithDatabase :: VoucherDatabase d => d -> Assertion
--- testWithDatabase database =
--- let
--- testApp = app trivialIssue database
--- in
-
--- test_redemption :: TestTree
--- test_redemption =
--- let
--- testApp = memory >>= (return . app trivialIssue)
--- in
--- withResource testApp (\x -> return ()) $ \getApp ->
--- testGroup "Voucher Redemption"
--- [ testWai' getApp "a non-POST receives a 405 (Method Not Allowed) response" $
--- do
--- res <- get "/"
--- assertStatus' status405 res
--- assertBody "blub" res
--- ]
diff --git a/test/SpecStripe.hs b/test/SpecStripe.hs
deleted file mode 100644
index d2a281b1f5eadef91c4fee31e2f73b387f11e17a..0000000000000000000000000000000000000000
--- a/test/SpecStripe.hs
+++ /dev/null
@@ -1,126 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
---
--- Test suite for Stripe support in the payment server.
---
-
-module SpecStripe where
-
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy as LazyBS
-import Data.Aeson
- ( encode
- )
-import Test.Hspec
- ( Spec
- , parallel
- , describe
- , it
- )
-import Test.Hspec.Wai
- ( WaiSession
- , WaiExpectation
- , MatchBody(MatchBody)
- , ResponseMatcher(matchBody)
- , Body
- , with
- , post
- , shouldRespondWith
- , liftIO
- )
-import Test.Hspec.Wai.QuickCheck
- ( property
- )
-import Test.QuickCheck
- ( Property
- , Gen
- , arbitrary
- , generate
- , forAll
- , (===)
- , (=/=)
- )
-import Util.WAI
- ( postJSON
- )
-import Util.Gen
- ( ChargeEvents(GoodChargeEvent, BadChargeEvent)
- , chargeSucceededEvents
- , metaDatasWithVoucher
- , metaDatasWithoutVoucher
- )
-import Util.JSON
- ( -- ToJSON instance for Event
- )
-import Network.HTTP.Types
- ( Header
- )
-import Servant
- ( Application
- , Proxy(Proxy)
- , serve
- )
-import Web.Stripe.Types
- ( MetaData(MetaData)
- )
-import PaymentServer.Processors.Stripe
- ( StripeAPI
- , stripeServer
- , getVoucher
- )
-import PaymentServer.Persistence
- ( Voucher
- , memory
- )
-import Util.Spec
- ( wrongMethodNotAllowed
- , nonJSONUnsupportedMediaType
- , wrongJSONInvalidRequest
- )
-
-stripeAPI :: Proxy StripeAPI
-stripeAPI = Proxy
-
-app :: IO Application
-app = serve stripeAPI . stripeServer <$> memory
-
-spec_webhook :: Spec
-spec_webhook = with app $ parallel $ do
- describe "error behavior of POST /webhook" $ do
- wrongMethodNotAllowed "GET" "/webhook"
- nonJSONUnsupportedMediaType "/webhook"
- wrongJSONInvalidRequest "/webhook" "{}"
-
- -- I would like to make most or all of these into property tests. *This*
- -- test shows how you can do it. Yay. The main thing (for me, anyway) to
- -- remember is to use `property` from Test.Hspec.Wai.QuickCheck and not from
- -- `Test.QuickCheck`. :/ Unsure whether I love the apparent Haskell
- -- convention of giving the same name to *similar* functions.
- describe "success behavior of POST /webhook" $
- it "responds to a JSON Event body with 200 (OK)" $
- let
- test e =
- postJSON "/webhook" (encode e) `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }
- -- For now these are the same. Maybe they always will be? The HTTP
- -- behavior is the same though the backend behavior may differ. Note
- -- that a "test_" prefix would cause tasty-discover to find this and try
- -- to call it - but it can't since it's not a top-level, let alone
- -- exported.
- xtest_postWithEventBody (GoodChargeEvent e) = test e
- xtest_postWithEventBody (BadChargeEvent e) = test e
- in
- property xtest_postWithEventBody
-
-
-bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String
-bodyMatcher _ "{}" = Nothing
-bodyMatcher _ body = Just $ show body
-
-prop_getVoucherFindsVoucher :: Property
-prop_getVoucherFindsVoucher = forAll metaDatasWithVoucher $ \x ->
- getVoucher x =/= Nothing
-
-prop_getVoucherWithoutVoucher :: Property
-prop_getVoucherWithoutVoucher = forAll metaDatasWithoutVoucher $ \x ->
- getVoucher x === Nothing
diff --git a/test/Util/Gen.hs b/test/Util/Gen.hs
deleted file mode 100644
index ffba41237a591d05a7834df9663564f46d7b5d2b..0000000000000000000000000000000000000000
--- a/test/Util/Gen.hs
+++ /dev/null
@@ -1,187 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Util.Gen
- ( chargeSucceededEvents
- , metaDatasWithoutVoucher
- , metaDatasWithVoucher
- , posixTimes
- , hasVoucher
- , ChargeEvents(GoodChargeEvent, BadChargeEvent)
- ) where
-
-import Data.Text
- ( Text
- )
-import Data.List.Index
- ( insertAt
- )
-import Data.Time.Clock
- ( UTCTime(UTCTime)
- )
-import Data.Time.Clock.POSIX
- ( POSIXTime
- , posixSecondsToUTCTime
- )
-import Web.Stripe.Types
- ( Charge(Charge)
- , StatementDescription(StatementDescription)
- , MetaData(MetaData)
- , Description(Description)
- , CustomerId(CustomerId)
- , InvoiceId(InvoiceId)
- , ChargeId(ChargeId)
- , Expandable(Id)
- , Currency(USD, UnknownCurrency)
- , Amount(Amount)
- , StripeList(StripeList, list, totalCount, hasMore)
- )
-import Web.Stripe.Event
- ( Event(Event, eventId, eventCreated, eventLiveMode, eventType, eventData, eventObject, eventPendingWebHooks, eventRequest)
- , EventType(ChargeSucceededEvent)
- , EventData(ChargeEvent)
- , EventId(EventId)
- )
-import Test.QuickCheck
- ( Gen
- , Arbitrary
- , arbitrary
- , Positive(Positive)
- , oneof
- , suchThat
- , suchThatMap
- )
-import Test.QuickCheck.Instances.Tuple
- ( (>*<)
- )
-import Test.QuickCheck.Instances.Time
- ( -- Get the `Gen UTCTime` instance
- )
-import Test.QuickCheck.Instances.Text
- ( -- Get the `Gen Text` instance
- )
-import PaymentServer.Persistence
- ( Voucher
- )
-
-instance Arbitrary Charge where
- arbitrary = charges True
-
-instance Semigroup (StripeList a) where
- -- Very weak implementation
- x <> y = StripeList (list x <> list y) "" "" Nothing (hasMore x || hasMore y)
-
-instance Monoid (StripeList a) where
- mempty = StripeList [] "" "" (Just 0) False
-
-instance Arbitrary Amount where
- arbitrary = Amount <$> arbitrary
-
-
-instance Arbitrary EventId where
- arbitrary = EventId <$> arbitrary
-
-
-instance Arbitrary StatementDescription where
- arbitrary = StatementDescription <$> arbitrary
-
-metaDatasWithoutVoucher = (arbitrary :: Gen MetaData) `suchThat` (not . hasVoucher)
--- Just filtering out random metadatas that don't have a voucher makes for an
--- incredibly inefficient generator. So start without a voucher and then add
--- one.
-metaDatasWithVoucher = ((arbitrary :: Gen Voucher) >*< metaDatasWithoutVoucher) `suchThatMap` (Just. uncurry addVoucher)
-
-addVoucher :: Voucher -> MetaData -> MetaData
-addVoucher voucher (MetaData []) = MetaData [("Voucher", voucher)]
-addVoucher voucher (MetaData items) =
- MetaData (insertAt (1234567 `mod` length items) ("Voucher", voucher) items)
-
-instance Arbitrary MetaData where
- arbitrary = MetaData <$> arbitrary
-
-instance Arbitrary Description where
- arbitrary = Description <$> arbitrary
-
-
-instance Arbitrary InvoiceId where
- arbitrary = InvoiceId <$> arbitrary
-
-
-instance Arbitrary ChargeId where
- arbitrary = ChargeId <$> arbitrary
-
-
-instance Arbitrary CustomerId where
- arbitrary = CustomerId <$> arbitrary
-
-
-instance Arbitrary a => Arbitrary (Expandable a) where
- arbitrary = Id <$> arbitrary
-
-chargeSucceededEvents :: Bool -> Gen Event
-chargeSucceededEvents withVoucher =
- Event
- <$> arbitrary -- eventId
- <*> posixTimes -- eventCreated
- <*> arbitrary -- eventLiveMode
- <*> return ChargeSucceededEvent -- eventType
- <*> chargeEvents withVoucher -- eventData
- <*> return "event" -- eventObject
- <*> arbitrary -- eventPendingWebHooks
- <*> arbitrary -- eventRequest
-
-
-chargeEvents :: Bool -> Gen EventData
-chargeEvents withVoucher =
- ChargeEvent <$> charges withVoucher
-
-charges :: Bool -> Gen Charge
-charges withVoucher =
- Charge
- <$> arbitrary -- chargeId :: ChargeId
- <*> return "charge" -- chargeObject :: Text
- <*> posixTimes -- chargeCreated :: UTCTime
- <*> arbitrary -- chargeLiveMode :: Bool
- <*> arbitrary -- chargePaid :: Bool
- <*> arbitrary -- chargeAmount :: Amount
- <*> oneof
- [ return UnknownCurrency
- , return USD
- ] -- chargeCurrency :: Currency
- <*> return False -- chargeRefunded :: Bool
- <*> return Nothing -- chargeCreditCard :: Maybe Card
- <*> arbitrary -- chargeCaptured :: Bool
- <*> return mempty -- chargeRefunds :: StripeList Refund
- <*> return Nothing -- chargeBalanceTransaction :: Maybe (Expandable TransactionId)
- <*> return Nothing -- chargeFailureMessage :: Maybe Text
- <*> return Nothing -- chargeFailureCode :: Maybe Text
- <*> return 0 -- chargeAmountRefunded :: Int
- <*> arbitrary -- chargeCustomerId :: Maybe (Expandable CustomerId)
- <*> return Nothing -- chargeInvoice :: Maybe (Expandable InvoiceId)
- <*> arbitrary -- chargeDescription :: Maybe Description
- <*> return Nothing -- chargeDispute :: Maybe Dispute
- <*> (
- if withVoucher then
- metaDatasWithVoucher
- else
- metaDatasWithoutVoucher
- ) -- chargeMetaData :: MetaData
- <*> arbitrary -- chargeStatementDescription :: Maybe StatementDescription
- <*> arbitrary -- chargeReceiptEmail :: Maybe Text
- <*> arbitrary -- chargeReceiptNumber :: Maybe Text
-
-data ChargeEvents
- = GoodChargeEvent Event
- | BadChargeEvent Event
- deriving (Show, Eq)
-
-instance Arbitrary ChargeEvents where
- arbitrary = oneof
- [ chargeSucceededEvents True `suchThatMap` (Just . GoodChargeEvent)
- , chargeSucceededEvents False `suchThatMap` (Just . BadChargeEvent)
- ]
-
-posixTimes :: Gen UTCTime
-posixTimes = (arbitrary :: Gen Integer) `suchThatMap` (Just . posixSecondsToUTCTime . fromIntegral . abs)
-
-hasVoucher :: MetaData -> Bool
-hasVoucher (MetaData items) = elem "Voucher" . map fst $ items
diff --git a/test/Util/JSON.hs b/test/Util/JSON.hs
deleted file mode 100644
index f43be9f362f703a9cc376cfa3fb8f72dd6dce601..0000000000000000000000000000000000000000
--- a/test/Util/JSON.hs
+++ /dev/null
@@ -1,175 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Util.JSON where
-
-import Data.Time.Clock.POSIX
- ( utcTimeToPOSIXSeconds
- )
-import Data.HashMap.Lazy
- ( fromList
- )
-import qualified Data.Sequence as Seq
-import Web.Stripe.Types
- ( Charge(Charge)
- , ChargeId(ChargeId)
- , InvoiceId(InvoiceId)
- , Amount(Amount)
- , Currency(USD, UnknownCurrency)
- , MetaData(MetaData)
- , StripeList(StripeList)
- , Refund(Refund)
- , RefundId(RefundId)
- , TransactionId(TransactionId)
- , Expandable(Id)
- )
-import Web.Stripe.Event
- ( Event(Event)
- , EventData(ChargeEvent)
- , EventType(ChargeSucceededEvent)
- , EventId(EventId)
- )
-import Data.Aeson
- ( ToJSON(toJSON)
- , Value(String, Number, Object, Array)
- , object
- , (.=)
- )
-import Data.Aeson.Types
- ( listValue
- )
-
-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" .= utcTimeToPOSIXSeconds eventCreated
- , "data" .= object [ "object" .= eventData ]
- , "type" .= eventType
- , "livemode" .= eventLiveMode
- , "pending_webhooks" .= eventPendingWebHooks
- , "request" .= eventRequest
- ]
-
-instance ToJSON a => ToJSON (Expandable a) where
- toJSON (Id eId) = toJSON eId
-
-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 RefundId where
- toJSON (RefundId rId) = String rId
-
-instance ToJSON TransactionId where
- toJSON (TransactionId tId) = String tId
-
-instance ToJSON Currency where
- toJSON USD = "USD"
- toJSON UnknownCurrency = "???"
-
-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 MetaData where
- toJSON (MetaData items) = (Object . fromList . map (\(k, v) -> (k, String v))) items
-
-instance ToJSON Refund where
- toJSON (Refund
- refundId
- refundAmount
- refundCurrency
- refundCreated
- refundObject
- refundCharge
- refundBalanceTransaction
- refundMetaData
- )
- = object
- [ "id" .= refundId
- , "amount" .= refundAmount
- , "currency" .= refundCurrency
- , "created" .= utcTimeToPOSIXSeconds refundCreated
- , "object" .= refundObject
- , "charge" .= refundCharge
- , "balance_transaction" .= refundBalanceTransaction
- , "metadata" .= refundMetaData
- ]
-
-instance (ToJSON a) => ToJSON (StripeList a) where
- toJSON (StripeList elements stripeUrl obj totalCount hasMore)
- = object
- [ "data" .= toJSON elements
- , "url" .= stripeUrl
- , "object" .= obj
- , "has_more" .= hasMore
- ]
-
-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" .= utcTimeToPOSIXSeconds chargeCreated
- , "currency" .= chargeCurrency
- -- , "customer" .= chargeCustomerId
- -- , "description" .= chargeDescription
- -- , "dispute" .= chargeDispute
- -- , "failure_code" .= chargeFailureCode
- -- , "failure_message" .= chargeFailureMessage
- -- , "invoice" .= chargeInvoice
- , "livemode" .= chargeLiveMode
- , "metadata" .= chargeMetaData
- , "paid" .= chargePaid
- , "receipt_email" .= chargeReceiptEmail
- , "refunded" .= chargeRefunded
- , "refunds" .= chargeRefunds
- ]
diff --git a/test/Util/Spec.hs b/test/Util/Spec.hs
deleted file mode 100644
index 9ce6f8de4f85163cc5e050c03511d95aac801083..0000000000000000000000000000000000000000
--- a/test/Util/Spec.hs
+++ /dev/null
@@ -1,32 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
-module Util.Spec
- ( wrongMethodNotAllowed
- , nonJSONUnsupportedMediaType
- , wrongJSONInvalidRequest
- ) where
-
-import Test.Hspec
- ( it
- )
-import Test.Hspec.Wai
- ( post
- , request
- , shouldRespondWith
- )
-
-import Util.WAI
- ( postJSON
- )
-
-wrongMethodNotAllowed method path =
- it "responds to an unsupported method with 405 (Method Not Allowed)" $
- request method path [] "" `shouldRespondWith` 405
-
-nonJSONUnsupportedMediaType path =
- it "responds to non-JSON Content-Type with 415 (Unsupported Media Type)" $
- post path "xxx" `shouldRespondWith` 415
-
-wrongJSONInvalidRequest path json =
- it "responds to JSON body representing the wrong data with 400 (Invalid Request)" $
- postJSON path json `shouldRespondWith` 400
diff --git a/test/Util/WAI.hs b/test/Util/WAI.hs
deleted file mode 100644
index 53d29ff74af1c937a477b89390868a23d7090d3d..0000000000000000000000000000000000000000
--- a/test/Util/WAI.hs
+++ /dev/null
@@ -1,24 +0,0 @@
-{-# 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")]