Merge pull request #30 from vu3rdd/24.stripe-charge-rebased

Expose a browser facing API for creating Stripe charges

.circleci/config.yml

@@ -93,8 +93,8 @@ jobs:
           # the cache was written (but usually it will have).
           name: "Restore Cached Dependencies"
           keys:
-            - paymentserver-v1-{{ checksum "stack.yaml" }}-{{ checksum "PaymentServer.cabal" }}
-            - paymentserver-v1-{{ checksum "stack.yaml" }}
+            - paymentserver-v2-{{ checksum "stack.yaml" }}-{{ checksum "PaymentServer.cabal" }}
+            - paymentserver-v2-{{ checksum "stack.yaml" }}
 
       - run:
           # Build just our dependencies.  It's nice to have this as a separate
@@ -124,7 +124,7 @@ jobs:
           # way we get to save the cache whether or not the test suite goes on
           # to succeed.
           name: "Cache Dependencies"
-          key: paymentserver-v1-{{ checksum "stack.yaml" }}-{{ checksum "PaymentServer.cabal" }}
+          key: paymentserver-v2-{{ checksum "stack.yaml" }}-{{ checksum "PaymentServer.cabal" }}
           paths:
             - "/root/.stack"
             - ".stack-work"

PaymentServer.cabal

@@ -25,6 +25,7 @@ library
   build-depends:       base >= 4.7 && < 5
                      , optparse-applicative
                      , aeson
+                     , bytestring
                      , servant
                      , servant-server
                      , wai
@@ -32,6 +33,7 @@ library
                      , data-default
                      , warp
                      , warp-tls
+                     , stripe-haskell
                      , stripe-core
                      , text
                      , containers

nix/PaymentServer.nix

@@ -57,6 +57,7 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
       "library" = {
         depends = [
           (hsPkgs."base" or (buildDepError "base"))
+          (hsPkgs."bytestring" or (buildDepError "bytestring"))
           (hsPkgs."optparse-applicative" or (buildDepError "optparse-applicative"))
           (hsPkgs."aeson" or (buildDepError "aeson"))
           (hsPkgs."servant" or (buildDepError "servant"))
@@ -67,6 +68,7 @@ in { system, compiler, flags, pkgs, hsPkgs, pkgconfPkgs, ... }:
           (hsPkgs."warp" or (buildDepError "warp"))
           (hsPkgs."warp-tls" or (buildDepError "warp-tls"))
           (hsPkgs."stripe-core" or (buildDepError "stripe-core"))
+          (hsPkgs."stripe-haskell" or (buildDepError "stripe-haskell"))
           (hsPkgs."text" or (buildDepError "text"))
           (hsPkgs."containers" or (buildDepError "containers"))
           (hsPkgs."cryptonite" or (buildDepError "cryptonite"))

nix/pkgs.nix

@@ -3,6 +3,8 @@
     {
       packages = ({
         "stripe-core" = (((hackage.stripe-core)."2.5.0").revisions).default;
+        "stripe-haskell" = (((hackage.stripe-haskell)."2.5.0").revisions).default;
+        "stripe-http-client" = (((hackage.stripe-http-client)."2.5.0").revisions).default;
         } // { PaymentServer = ./PaymentServer.nix; }) // {};
       };
   resolver = "lts-14.1";

src/PaymentServer/Main.hs

@@ -47,6 +47,9 @@ import PaymentServer.Issuer
 import PaymentServer.Server
   ( paymentServerApp
   )
+import PaymentServer.Processors.Stripe
+  ( StripeSecretKey
+  )
 
 import Options.Applicative
   ( Parser
@@ -90,6 +93,7 @@ data ServerConfig = ServerConfig
   , database        :: Database
   , databasePath    :: Maybe Text
   , endpoint        :: Endpoint
+  , stripeKey       :: StripeSecretKey
   }
   deriving (Show, Eq)
 
@@ -159,7 +163,9 @@ sample = ServerConfig
     <> help "Path to on-disk database (sqlite3 only)"
     <> showDefault ) )
   <*> (http <|> https)
-
+  <*> option str
+  ( long "stripe-key"
+    <> help "Stripe Secret key" )
 
 opts :: ParserInfo ServerConfig
 opts = info (sample <**> helper)
@@ -221,6 +227,7 @@ getApp config =
             exitFailure
           Right getDB -> do
             db <- getDB
-            let app = paymentServerApp issuer db
+            let key = stripeKey config
+            let app = paymentServerApp key issuer db
             logger <- mkRequestLogger (def { outputFormat = Detailed True})
             return $ logger app

src/PaymentServer/Processors/Stripe.hs

@@ -6,30 +6,49 @@ module PaymentServer.Processors.Stripe
   ( StripeAPI
   , stripeServer
   , getVoucher
+  , StripeSecretKey
   ) where
 
 import Control.Monad.IO.Class
   ( liftIO
   )
-import Text.Printf
-  ( printf
+import Control.Monad
+  ( mzero
+  )
+import Data.ByteString
+  ( ByteString
+  )
+import Data.Text
+  ( Text
+  , unpack
+  )
+import Text.Read
+  ( readMaybe
   )
 import Data.Aeson
   ( ToJSON(toJSON)
+  , FromJSON(parseJSON)
+  , Value(Object)
   , object
+  , (.:)
   )
 import Servant
   ( Server
   , Handler
+  , err400
+  , err500
+  , ServerError(errBody)
+  , throwError
   )
 import Servant.API
   ( ReqBody
   , JSON
   , Post
   , (:>)
+  , (:<|>)((:<|>))
   )
 import Web.Stripe.Event
-  ( Event(Event, eventId, eventCreated, eventLiveMode, eventType, eventData, eventObject, eventPendingWebHooks, eventRequest)
+  ( Event(Event, eventId, eventType, eventData)
   , EventId(EventId)
   , EventType(ChargeSucceededEvent)
   , EventData(ChargeEvent)
@@ -37,19 +56,40 @@ import Web.Stripe.Event
 import Web.Stripe.Types
   ( Charge(Charge, chargeMetaData)
   , MetaData(MetaData)
+  , Currency
+  )
+import Web.Stripe.Error
+  ( StripeError(StripeError)
+  )
+import Web.Stripe.Charge
+  ( createCharge
+  , Amount(Amount)
+  , TokenId(TokenId)
+  )
+import Web.Stripe.Client
+  ( StripeConfig(StripeConfig)
+  , StripeKey(StripeKey)
+  )
+import Web.Stripe
+  ( stripe
+  , (-&-)
   )
 import PaymentServer.Persistence
   ( Voucher
   , VoucherDatabase(payForVoucher)
   )
 
+type StripeSecretKey = ByteString
 
 data Acknowledgement = Ok
 
 instance ToJSON Acknowledgement where
   toJSON Ok = object []
 
-type StripeAPI = "webhook" :> ReqBody '[JSON] Event :> Post '[JSON] Acknowledgement
+type StripeAPI = WebhookAPI
+               :<|> ChargesAPI
+
+type WebhookAPI = "webhook" :> ReqBody '[JSON] Event :> Post '[JSON] Acknowledgement
 
 -- | getVoucher finds the metadata item with the key `"Voucher"` and returns
 -- the corresponding value, or Nothing.
@@ -58,12 +98,12 @@ getVoucher (MetaData []) = Nothing
 getVoucher (MetaData (("Voucher", value):xs)) = Just value
 getVoucher (MetaData (x:xs)) = getVoucher (MetaData xs)
 
-stripeServer :: VoucherDatabase d => d -> Server StripeAPI
-stripeServer = webhook
+stripeServer :: VoucherDatabase d => StripeSecretKey -> d -> Server StripeAPI
+stripeServer key d = webhook d
+                     :<|> charge d key
 
+-- | Process charge succeeded events
 webhook :: VoucherDatabase d => d -> Event -> Handler Acknowledgement
-
--- Process charge succeeded events
 webhook d Event{eventId=Just (EventId eventId), eventType=ChargeSucceededEvent, eventData=(ChargeEvent charge)} =
   case getVoucher $ chargeMetaData charge of
     Nothing ->
@@ -83,3 +123,58 @@ webhook d Event{eventId=Just (EventId eventId), eventType=ChargeSucceededEvent,
 webhook d _ =
   -- TODO: Record the eventId somewhere.
   return Ok
+
+
+-- | Browser facing API that takes token, voucher and a few other information
+-- and calls stripe charges API. If payment succeeds, then the voucher is stored
+-- in the voucher database.
+type ChargesAPI = "charge" :> ReqBody '[JSON] Charges :> Post '[JSON] Acknowledgement
+
+data Charges = Charges
+  { token :: Text          -- ^ The text of a Stripe tokenized payment method.
+  , voucher :: Voucher     -- ^ The voucher for which this charge will pay.
+  , amount :: Int          -- ^ The amount of the charge in the minimum
+                           -- currency unit of the target currency (eg for
+                           -- USD, cents).
+  , currency :: Text       -- ^ The currency in which the charge will be made.
+  } deriving (Show, Eq)
+
+instance FromJSON Charges where
+  parseJSON (Object v) = Charges <$>
+                         v .: "token" <*>
+                         v .: "voucher" <*>
+                         v .: "amount" <*>
+                         v .: "currency"
+  parseJSON _ = mzero
+
+-- | call the stripe Charge API (with token, voucher in metadata, amount, currency etc
+-- and if the Charge is okay, then set the voucher as "paid" in the database.
+charge :: VoucherDatabase d => d -> StripeSecretKey -> Charges -> Handler Acknowledgement
+charge d key (Charges token voucher amount currency) = do
+  let config = StripeConfig (StripeKey key) Nothing
+      tokenId = TokenId token
+  currency' <- getCurrency currency
+  result <- liftIO $ stripe config $
+    createCharge (Amount amount) currency'
+      -&- tokenId
+      -&- MetaData [("Voucher", voucher)]
+  case result of
+    Right Charge { chargeMetaData = metadata } ->
+      -- verify that we are getting the same metadata that we sent.
+      case metadata of
+        MetaData [("Voucher", v)] ->
+          if v == voucher
+            then
+            do
+              liftIO $ payForVoucher d voucher
+              return Ok
+            else
+            throwError err500 { errBody = "Voucher code mismatch" }
+        _ -> throwError err400 { errBody = "Voucher code not found" }
+    Left StripeError {} -> throwError err400 { errBody = "Stripe charge didn't succeed" }
+    where
+      getCurrency :: Text -> Handler Currency
+      getCurrency maybeCurrency = do
+        case readMaybe (unpack currency) of
+          Just currency' -> return currency'
+          Nothing -> throwError err400 { errBody = "Invalid currency specified" }

src/PaymentServer/Server.hs

 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 -- | This module exposes a Servant-based Network.Wai server for payment
 -- interactions.
@@ -17,6 +18,7 @@ import Servant
   )
 import PaymentServer.Processors.Stripe
   ( StripeAPI
+  , StripeSecretKey
   , stripeServer
   )
 import PaymentServer.Redemption
@@ -36,9 +38,9 @@ type PaymentServerAPI
   :<|> "v1" :> "redeem" :> RedemptionAPI
 
 -- | Create a server which uses the given database.
-paymentServer :: VoucherDatabase d => Issuer -> d -> Server PaymentServerAPI
-paymentServer issuer database =
-  stripeServer database
+paymentServer :: VoucherDatabase d => StripeSecretKey -> Issuer -> d -> Server PaymentServerAPI
+paymentServer key issuer database =
+  stripeServer key database
   :<|> redemptionServer issuer database
 
 paymentServerAPI :: Proxy PaymentServerAPI
@@ -46,5 +48,5 @@ paymentServerAPI = Proxy
 
 -- | Create a Servant Application which serves the payment server API using
 -- the given database.
-paymentServerApp :: VoucherDatabase d => Issuer -> d -> Application
-paymentServerApp issuer = serve paymentServerAPI . paymentServer issuer
+paymentServerApp :: VoucherDatabase d => StripeSecretKey -> Issuer -> d -> Application
+paymentServerApp key issuer = serve paymentServerAPI . paymentServer key issuer

stack.yaml

@@ -39,6 +39,8 @@ packages:
 # (e.g., acme-missiles-0.3)
 extra-deps:
   - "stripe-core-2.5.0"
+  - "stripe-haskell-2.5.0"
+  - "stripe-http-client-2.5.0"
 
 # Override default flag values for local packages and extra-deps
 # flags: {}