diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 89f755458e41e87cfe74c2ed2247fff9871f7fd6..0cc0fb6fc71b823d4353fd4deacbaf8adfd9295b 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -21,6 +21,7 @@ library
, servant-server
, wai
, warp
+ , stripe-core
default-language: Haskell2010
executable PaymentServer-exe
@@ -41,6 +42,14 @@ test-suite PaymentServer-test
, hspec-wai
, hspec-wai-json
, aeson
+ , stripe-core
+ , time
+ , QuickCheck
+ , quickcheck-instances
+ , wai-extra
+ , bytestring
+ , text
+ , http-types
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
diff --git a/src/Lib.hs b/src/Lib.hs
index 3844204aadfc686548ee94661bb696ead5d67e35..996746be98fac078e6d13f8e940ba08d0ea3d487 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -12,15 +12,8 @@ import Network.Wai
import Network.Wai.Handler.Warp
import Servant
-data User = User
- { userId :: Int
- , userFirstName :: String
- , userLastName :: String
- } deriving (Eq, Show)
-
-$(deriveJSON defaultOptions ''User)
-
-type API = "users" :> Get '[JSON] [User]
+type API =
+ "webhook" :> Post '[JSON] ()
startApp :: IO ()
startApp = run 8080 app
@@ -32,9 +25,4 @@ api :: Proxy API
api = Proxy
server :: Server API
-server = return users
-
-users :: [User]
-users = [ User 1 "Isaac" "Newton"
- , User 2 "Albert" "Einstein"
- ]
+server = return ()
diff --git a/stack.yaml b/stack.yaml
index 9879a51389f8ae856386953ccd3db2a4ea146b24..75399a2e58530adf91ef7986d22afc5aff66d297 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -37,7 +37,8 @@ packages:
# Dependency packages to be pulled from upstream that are not in the resolver
# using the same syntax as the packages field.
# (e.g., acme-missiles-0.3)
-# extra-deps: []
+extra-deps:
+ - "stripe-core-2.5.0"
# Override default flag values for local packages and extra-deps
# flags: {}
diff --git a/test/Spec.hs b/test/Spec.hs
index 8aefe968b9a875f97786a3ab87cdf4bd7dbd20b6..bd0eadfbd184dfee4ac3dcea71ce1c6cdb2e7819 100644
--- a/test/Spec.hs
+++ b/test/Spec.hs
@@ -2,19 +2,185 @@
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
-import Lib (app)
+import Lib
+ ( app
+ )
+
+import Data.ByteString.Lazy as LazyBS
+import Data.ByteString as BS
+
+import Data.Text
+ ( Text
+ )
+
+import Data.Time.Clock
+ ( UTCTime
+ )
+
+import Data.Aeson
+ ( encode
+ )
+
+import Web.Stripe.Types
+ ( Charge(Charge)
+ , StatementDescription(StatementDescription)
+ , MetaData(MetaData)
+ , Description(Description)
+ , CustomerId(CustomerId)
+ , InvoiceId(InvoiceId)
+ , ChargeId(ChargeId)
+ , Expandable(Id)
+ , Currency(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.Hspec
+ ( Spec
+ , hspec
+ , describe
+ , it
+ )
import Test.Hspec.Wai
-import Test.Hspec.Wai.JSON
+ ( WaiSession
+ , with
+ , post
+ , request
+ , shouldRespondWith
+ )
+import Network.Wai.Test
+ ( SResponse
+ )
+
+import Network.HTTP.Types.Method
+ ( methodPost
+ )
+
+import Test.QuickCheck
+ ( Gen
+ , Arbitrary
+ , forAll
+ , property
+ , arbitrary
+ )
+
+import Test.QuickCheck.Instances.Time
+ ( -- Get the `Gen UTCTime` instance
+ )
+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
+ <*> arbitrary -- chargeCreated :: UTCTime
+ <*> arbitrary -- chargeLiveMode :: Bool
+ <*> arbitrary -- chargePaid :: Bool
+ <*> arbitrary -- chargeAmount :: Amount
+ <*> (return UnknownCurrency) -- 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
+ <*> arbitrary -- chargeMetaData :: MetaData
+ <*> arbitrary -- chargeStatementDescription :: Maybe StatementDescription
+ <*> arbitrary -- chargeReceiptEmail :: Maybe Text
+ <*> arbitrary -- chargeReceiptNumber :: Maybe Text
+
+
+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
+
+
+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 :: Gen Event
+chargeSucceededEvents =
+ Event
+ <$> arbitrary -- eventId
+ <*> arbitrary -- eventCreated
+ <*> arbitrary -- eventLiveMode
+ <*> (return ChargeSucceededEvent) -- eventType
+ <*> (ChargeEvent
+ <$> arbitrary -- the charge
+ ) -- eventData
+ <*> arbitrary -- eventObject
+ <*> arbitrary -- eventPendingWebHooks
+ <*> arbitrary -- eventRequest
+
spec :: Spec
spec = with (return app) $ do
- describe "GET /users" $ do
- it "responds with 200" $ do
- get "/users" `shouldRespondWith` 200
- it "responds with [User]" $ do
- let users = "[{\"userId\":1,\"userFirstName\":\"Isaac\",\"userLastName\":\"Newton\"},{\"userId\":2,\"userFirstName\":\"Albert\",\"userLastName\":\"Einstein\"}]"
- get "/users" `shouldRespondWith` users
+ 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