From 7d58f8a1de73bb4057e0b01a0895bee24d718629 Mon Sep 17 00:00:00 2001
From: Ramakrishnan Muthukrishnan <ram@leastauthority.com>
Date: Thu, 31 Oct 2019 13:14:21 +0530
Subject: [PATCH] WIP: make a call to the Stripe "charges" API with the given
 data

The skeleton is in place, a lot of actual work still needs to be done.
---
 PaymentServer.cabal                    |  2 ++
 src/PaymentServer/Processors/Stripe.hs | 47 +++++++++++++++++++-------
 src/PaymentServer/Server.hs            |  3 +-
 stack.yaml                             |  2 ++
 4 files changed, 40 insertions(+), 14 deletions(-)

diff --git a/PaymentServer.cabal b/PaymentServer.cabal
index 6359ffb..b6cd94e 100644
--- a/PaymentServer.cabal
+++ b/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
diff --git a/src/PaymentServer/Processors/Stripe.hs b/src/PaymentServer/Processors/Stripe.hs
index 9a23fcc..a8a595f 100644
--- a/src/PaymentServer/Processors/Stripe.hs
+++ b/src/PaymentServer/Processors/Stripe.hs
@@ -14,8 +14,12 @@ import Control.Monad.IO.Class
 import Control.Monad
   ( mzero
   )
+import Data.ByteString
+  ( ByteString
+  )
 import Data.Text
   ( Text
+  , unpack
   )
 import Text.Printf
   ( printf
@@ -52,7 +56,17 @@ import PaymentServer.Persistence
   ( Voucher
   , VoucherDatabase(payForVoucher)
   )
-
+import Web.Stripe.Charge
+  ( createCharge
+  , Amount(..)
+  )
+import Web.Stripe.Client
+  ( StripeConfig(..)
+  , StripeKey(..)
+  )
+import Web.Stripe
+  ( stripe
+  )
 
 data Acknowledgement = Ok
 
@@ -60,7 +74,7 @@ instance ToJSON Acknowledgement where
   toJSON Ok = object []
 
 type StripeAPI = WebhookAPI
-               :<|> ChargeAPI
+               :<|> ChargesAPI
 
 type WebhookAPI = "webhook" :> ReqBody '[JSON] Event :> Post '[JSON] Acknowledgement
 
@@ -71,9 +85,9 @@ getVoucher (MetaData []) = Nothing
 getVoucher (MetaData (("Voucher", value):xs)) = Just value
 getVoucher (MetaData (x:xs)) = getVoucher (MetaData xs)
 
-stripeServer :: VoucherDatabase d => d -> Server StripeAPI
-stripeServer d = (webhook d)
-                 :<|> (charge d)
+stripeServer :: VoucherDatabase d => d -> ByteString -> Server StripeAPI
+stripeServer d key = (webhook d)
+                     :<|> (charge d key)
 
 -- | Process charge succeeded events
 webhook :: VoucherDatabase d => d -> Event -> Handler Acknowledgement
@@ -101,20 +115,27 @@ webhook d _ =
 -- | 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 ChargeAPI = "charge" :> ReqBody '[JSON] Token :> Post '[JSON] Acknowledgement
+type ChargesAPI = "charge" :> ReqBody '[JSON] Charges :> Post '[JSON] Acknowledgement
 
-data Token = Token
+data Charges = Charges
   { token :: Text
   , voucher :: Voucher
+  , amount :: Int
+  , currency :: Text
   } deriving (Show, Eq)
 
-instance FromJSON Token where
-  parseJSON (Object v) = Token <$>
+instance FromJSON Charges where
+  parseJSON (Object v) = Charges <$>
                          v .: "token" <*>
-                         v .: "voucher"
+                         v .: "voucher" <*>
+                         v .: "amount" <*>
+                         v .: "currency"
   parseJSON _ = mzero
 
-charge :: VoucherDatabase d => d -> Token -> Handler Acknowledgement
-charge d (Token token voucher) =
-  -- call the stripe Charge API
+charge :: VoucherDatabase d => d -> ByteString -> Charges -> Handler Acknowledgement
+charge d key (Charges token voucher amount currency) = do
+  -- call the stripe Charge API (with token, voucher in metadata, amount, currency etc
+  -- and if the Charge is okay, then return set the voucher as "paid" in the database.
+  let config = StripeConfig (StripeKey key) Nothing
+  result <- liftIO $ stripe config $ createCharge (Amount amount) (read (unpack currency))
   return Ok
diff --git a/src/PaymentServer/Server.hs b/src/PaymentServer/Server.hs
index 973ef12..d8898e0 100644
--- a/src/PaymentServer/Server.hs
+++ b/src/PaymentServer/Server.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 -- | This module exposes a Servant-based Network.Wai server for payment
 -- interactions.
@@ -38,7 +39,7 @@ type PaymentServerAPI
 -- | Create a server which uses the given database.
 paymentServer :: VoucherDatabase d => Issuer -> d -> Server PaymentServerAPI
 paymentServer issuer database =
-  stripeServer database
+  stripeServer database "test"
   :<|> redemptionServer issuer database
 
 paymentServerAPI :: Proxy PaymentServerAPI
diff --git a/stack.yaml b/stack.yaml
index c4bc686..0af84a3 100644
--- a/stack.yaml
+++ b/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: {}
-- 
GitLab