diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index b24d075397df0785213855345ec5f4643e5fcb35..45da40142973cef1783c29678a53f54685e28881 100644
--- a/PaymentServer.cabal
+++ b/PaymentServer.cabal
@@ -15,9 +15,10 @@ cabal-version: >=1.10
library
hs-source-dirs: src
- exposed-modules: Lib
+ exposed-modules: PaymentServer.Processors.Stripe
build-depends: base >= 4.7 && < 5
, aeson
+ , servant
, servant-server
, wai
, warp
@@ -61,6 +62,9 @@ test-suite PaymentServer-test
, tasty-hedgehog
, tasty-quickcheck
, hedgehog
+ , servant-server
+ , containers
+ , unordered-containers
ghc-options: -threaded -rtsopts -with-rtsopts=-N
default-language: Haskell2010
diff --git a/app/Main.hs b/app/Main.hs
index f66a415f02080ad1b552d1fb655750fe9ed0b03a..d82a4bd93b7e75a6ff9845150450ae0709b93086 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -1,6 +1,4 @@
module Main where
-import Lib
-
main :: IO ()
-main = startApp
+main = return ()
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
new file mode 100644
index 0000000000000000000000000000000000000000..94b10a361a2d7282e592749ed3fa50cb4240de68
--- /dev/null
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -0,0 +1,56 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+
+module PaymentServer.Processors.Stripe
+ ( StripeAPI
+ , stripeServer
+ ) where
+
+import Control.Monad.IO.Class
+ ( liftIO
+ )
+import Text.Printf
+ ( printf
+ )
+import Data.Aeson
+ ( ToJSON(toJSON)
+ , object
+ )
+import Servant
+ ( Server
+ , Handler
+ )
+import Servant.API
+ ( ReqBody
+ , JSON
+ , Post
+ , (:>)
+ )
+import Web.Stripe.Event
+ ( Event(Event, eventId, eventCreated, eventLiveMode, eventType, eventData, eventObject, eventPendingWebHooks, eventRequest)
+ , EventId(EventId)
+ , EventType(ChargeSucceededEvent)
+ , EventData(ChargeEvent)
+ )
+import Web.Stripe.Types
+ ( Charge(Charge)
+ )
+
+data Acknowledgement = Ok
+
+instance ToJSON Acknowledgement where
+ toJSON Ok = object []
+
+type StripeAPI = "webhook" :> ReqBody '[JSON] Event :> Post '[JSON] Acknowledgement
+
+stripeServer :: Server StripeAPI
+stripeServer = webhook
+
+webhook :: Event -> Handler Acknowledgement
+
+-- Process charge succeeded events
+webhook Event{eventId=Just (EventId eventId), eventType=ChargeSucceededEvent, eventData=ChargeEvent{}} = do
+ return Ok
+
+-- Disregard anything else - but return success so that Stripe doesn't retry.
+webhook _ = return Ok
diff --git a/test/SpecStripe.hs b/test/SpecStripe.hs
index eca31010bfae4104e70a66e537ce51678853bd07..979406dd8e3513572d012064327b89b2794d07cf 100644
--- a/test/SpecStripe.hs
+++ b/test/SpecStripe.hs
@@ -19,6 +19,9 @@ import Test.Hspec
import Test.Hspec.Wai
( WaiSession
, WaiExpectation
+ , MatchBody(MatchBody)
+ , ResponseMatcher(matchBody)
+ , Body
, with
, post
, shouldRespondWith
@@ -36,9 +39,24 @@ import Util.Gen
import Util.JSON
( -- ToJSON instance for Event
)
-import Lib
- ( app
+import Network.HTTP.Types
+ ( Header
)
+import Servant
+ ( Application
+ , Proxy(Proxy)
+ , serve
+ )
+import PaymentServer.Processors.Stripe
+ ( StripeAPI
+ , stripeServer
+ )
+
+stripeAPI :: Proxy StripeAPI
+stripeAPI = Proxy
+
+app :: Application
+app = serve stripeAPI stripeServer
aChargeEvent :: IO LazyBS.ByteString
aChargeEvent = encode <$> generate chargeSucceededEvents
@@ -49,8 +67,8 @@ spec_webhook = with (return app) $
-- 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 non-JSON Content-Type with 415 (Unsupported Media Type)" $
+ post "/webhook" "xxx" `shouldRespondWith` 415
it "responds to JSON non-Event body with 400 (Invalid Request)" $
postJSON "/webhook" "{}" `shouldRespondWith` 400
@@ -60,4 +78,7 @@ spec_webhook' = with (return app) $
describe "success behavior of POST /webhook" $
it "responds to a JSON Event body with 200 (OK)" $ do
event <- liftIO aChargeEvent
- postJSON "/webhook" event `shouldRespondWith` 200
+ postJSON "/webhook" event `shouldRespondWith` 200 { matchBody = MatchBody bodyMatcher }
+
+bodyMatcher :: [Network.HTTP.Types.Header] -> Body -> Maybe String
+bodyMatcher _ body = if body == "{}" then Nothing else Just $ show body
diff --git a/test/Util/Gen.hs b/test/Util/Gen.hs
index 64b838b985af37f62aaa598bb8575c9a3cb6df48..5bdeffdf0205832efab09d8a67fea4da231a077d 100644
--- a/test/Util/Gen.hs
+++ b/test/Util/Gen.hs
@@ -9,7 +9,12 @@ import Data.Text
)
import Data.Time.Clock
- ( UTCTime
+ ( UTCTime(UTCTime)
+ )
+
+import Data.Time.Clock.POSIX
+ ( POSIXTime
+ , posixSecondsToUTCTime
)
import Web.Stripe.Types
@@ -21,7 +26,7 @@ import Web.Stripe.Types
, InvoiceId(InvoiceId)
, ChargeId(ChargeId)
, Expandable(Id)
- , Currency(UnknownCurrency)
+ , Currency(USD, UnknownCurrency)
, Amount(Amount)
, StripeList(StripeList, list, totalCount, hasMore)
)
@@ -38,6 +43,9 @@ import Test.QuickCheck
( Gen
, Arbitrary
, arbitrary
+ , Positive(Positive)
+ , oneof
+ , suchThatMap
)
import Test.QuickCheck.Instances.Time
@@ -51,11 +59,14 @@ instance Arbitrary Charge where
arbitrary = Charge
<$> arbitrary -- chargeId :: ChargeId
<*> return "charge" -- chargeObject :: Text
- <*> arbitrary -- chargeCreated :: UTCTime
+ <*> posixTimes -- chargeCreated :: UTCTime
<*> arbitrary -- chargeLiveMode :: Bool
<*> arbitrary -- chargePaid :: Bool
<*> arbitrary -- chargeAmount :: Amount
- <*> return UnknownCurrency -- chargeCurrency :: Currency
+ <*> oneof
+ [ return UnknownCurrency
+ , return USD
+ ] -- chargeCurrency :: Currency
<*> return False -- chargeRefunded :: Bool
<*> return Nothing -- chargeCreditCard :: Maybe Card
<*> arbitrary -- chargeCaptured :: Bool
@@ -116,12 +127,11 @@ instance Arbitrary CustomerId where
instance Arbitrary a => Arbitrary (Expandable a) where
arbitrary = Id <$> arbitrary
-
chargeSucceededEvents :: Gen Event
chargeSucceededEvents =
Event
<$> arbitrary -- eventId
- <*> arbitrary -- eventCreated
+ <*> posixTimes -- eventCreated
<*> arbitrary -- eventLiveMode
<*> return ChargeSucceededEvent -- eventType
<*> (ChargeEvent
@@ -130,3 +140,9 @@ chargeSucceededEvents =
<*> return "event" -- eventObject
<*> arbitrary -- eventPendingWebHooks
<*> arbitrary -- eventRequest
+
+posixTimes :: Gen UTCTime
+posixTimes = (arbitrary :: Gen Integer) `suchThatMap` (Just . posixSecondsToUTCTime . fromIntegral . abs)
+
+-- dropFractionalSeconds :: UTCTime -> UTCTime
+-- dropFractionalSeconds (UTCTime day dayTime) = UTCTime day (round dayTime)
diff --git a/test/Util/JSON.hs b/test/Util/JSON.hs
index fda5e9039a9ad02a73a97f530c4e89077310eef2..f43be9f362f703a9cc376cfa3fb8f72dd6dce601 100644
--- a/test/Util/JSON.hs
+++ b/test/Util/JSON.hs
@@ -2,12 +2,25 @@
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)
+ , Currency(USD, UnknownCurrency)
+ , MetaData(MetaData)
+ , StripeList(StripeList)
+ , Refund(Refund)
+ , RefundId(RefundId)
+ , TransactionId(TransactionId)
+ , Expandable(Id)
)
import Web.Stripe.Event
( Event(Event)
@@ -15,13 +28,15 @@ import Web.Stripe.Event
, EventType(ChargeSucceededEvent)
, EventId(EventId)
)
-
import Data.Aeson
( ToJSON(toJSON)
- , Value(String, Number)
+ , Value(String, Number, Object, Array)
, object
, (.=)
)
+import Data.Aeson.Types
+ ( listValue
+ )
instance ToJSON Event where
toJSON (Event
@@ -37,7 +52,7 @@ instance ToJSON Event where
[ "id" .= eventId
, "object" .= eventObject
, "api_version" .= String "2018-05-21"
- , "created" .= eventCreated
+ , "created" .= utcTimeToPOSIXSeconds eventCreated
, "data" .= object [ "object" .= eventData ]
, "type" .= eventType
, "livemode" .= eventLiveMode
@@ -45,6 +60,9 @@ instance ToJSON Event where
, "request" .= eventRequest
]
+instance ToJSON a => ToJSON (Expandable a) where
+ toJSON (Id eId) = toJSON eId
+
instance ToJSON EventId where
toJSON (EventId eId) = String eId
@@ -54,8 +72,15 @@ instance ToJSON InvoiceId where
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"
@@ -66,6 +91,40 @@ instance ToJSON EventData where
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
@@ -96,10 +155,10 @@ instance ToJSON Charge where
[ "id" .= chargeId
, "object" .= chargeObject
, "amount" .= chargeAmount
- -- , "amount_refunded" .= chargeAmountRefunded
+ , "amount_refunded" .= chargeAmountRefunded
-- , "balance_transaction" .= chargeBalanceTransaction
, "captured" .= chargeCaptured
- , "created" .= chargeCreated
+ , "created" .= utcTimeToPOSIXSeconds chargeCreated
, "currency" .= chargeCurrency
-- , "customer" .= chargeCustomerId
-- , "description" .= chargeDescription
@@ -108,4 +167,9 @@ instance ToJSON Charge where
-- , "failure_message" .= chargeFailureMessage
-- , "invoice" .= chargeInvoice
, "livemode" .= chargeLiveMode
+ , "metadata" .= chargeMetaData
+ , "paid" .= chargePaid
+ , "receipt_email" .= chargeReceiptEmail
+ , "refunded" .= chargeRefunded
+ , "refunds" .= chargeRefunds
]