Basic Servant framework & working test suite for Stripe processor

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
 

app/Main.hs

 module Main where
 
-import Lib
-
 main :: IO ()
-main = startApp
+main = return ()

src/PaymentServer/Processors/Stripe.hs

+{-# 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

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

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)

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
     ]