Support POST /create-payment-intent

Interact with Stripe's payment_intents API endpoint.

I'm not committing the index.html that contains client-side code that interacts
with the /create-payment-intent endpoint, but it contains sensitive information,
so I'm omitting it for now.

TL;DR:
- Define POST /create-payment-intent endpoint
- Include envStripeAPIKey in Context record
- Define a top-level Stripe module for making API calls
- Define types and instances that align with Stripes request and response types
- Depend on the Req library: a higher-level library than http-client
This commit is contained in:
William Carroll 2020-08-13 18:09:38 +01:00
parent de723c142b
commit 81aa32fe71
7 changed files with 118 additions and 5 deletions

View file

@ -11,3 +11,6 @@ import qualified Types as T
type API = "verify" type API = "verify"
:> ReqBody '[JSON] T.VerifyGoogleSignInRequest :> ReqBody '[JSON] T.VerifyGoogleSignInRequest
:> Post '[JSON] NoContent :> Post '[JSON] NoContent
:<|> "create-payment-intent"
:> ReqBody '[JSON] T.PaymentIntent
:> Post '[JSON] T.CreatePaymentIntentResponse

View file

@ -12,11 +12,13 @@ import Utils
import qualified Network.Wai.Handler.Warp as Warp import qualified Network.Wai.Handler.Warp as Warp
import qualified GoogleSignIn import qualified GoogleSignIn
import qualified Stripe
import qualified Types as T import qualified Types as T
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
server :: T.Context -> Server API server :: T.Context -> Server API
server T.Context{..} = verifyGoogleSignIn server ctx@T.Context{..} = verifyGoogleSignIn
:<|> createPaymentIntent
where where
verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent
verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do
@ -31,6 +33,11 @@ server T.Context{..} = verifyGoogleSignIn
err -> do err -> do
throwError err401 { errBody = err |> GoogleSignIn.explainResult |> cs } throwError err401 { errBody = err |> GoogleSignIn.explainResult |> cs }
createPaymentIntent :: T.PaymentIntent -> Handler T.CreatePaymentIntentResponse
createPaymentIntent pmt = do
clientSecret <- liftIO $ Stripe.createPaymentIntent ctx pmt
pure T.CreatePaymentIntentResponse{..}
run :: T.App run :: T.App
run = do run = do
ctx@T.Context{..} <- ask ctx@T.Context{..} <- ask

View file

@ -18,6 +18,7 @@ getAppContext = do
Left err -> pure $ Left err Left err -> pure $ Left err
Right T.Env{..} -> pure $ Right T.Context Right T.Env{..} -> pure $ Right T.Context
{ contextGoogleClientID = envGoogleClientID { contextGoogleClientID = envGoogleClientID
, contextStripeAPIKey = envStripeAPIKey
, contextServerPort = envServerPort , contextServerPort = envServerPort
, contextClientPort = envClientPort , contextClientPort = envClientPort
} }

View file

@ -0,0 +1,29 @@
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
--------------------------------------------------------------------------------
module Stripe where
--------------------------------------------------------------------------------
import RIO
import Prelude (print)
import Data.String.Conversions (cs)
import Data.Aeson
import Network.HTTP.Req
import qualified Types as T
--------------------------------------------------------------------------------
endpoint :: Text -> Url 'Https
endpoint slug =
https "api.stripe.com" /: "v1" /: slug
post :: (FromJSON b) => Text -> Text -> T.PaymentIntent -> IO (JsonResponse b)
post apiKey slug T.PaymentIntent{..} = runReq defaultHttpConfig $ do
let params = "amount" =: paymentIntentAmount
<> "currency" =: paymentIntentCurrency
req POST (endpoint slug) (ReqBodyUrlEnc params) jsonResponse (oAuth2Bearer (cs apiKey))
createPaymentIntent :: T.Context -> T.PaymentIntent -> IO T.Secret
createPaymentIntent T.Context{..} pmtIntent = do
res <- post contextStripeAPIKey "payment_intents" pmtIntent
let T.StripePaymentIntent{..} = responseBody res :: T.StripePaymentIntent
pure pmtIntentClientSecret

View file

@ -1,28 +1,33 @@
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------G
module Types where module Types where
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
import RIO import RIO
import Data.Aeson import Data.Aeson
import Network.HTTP.Req
import Web.Internal.HttpApiData (ToHttpApiData(..))
import System.Envy (FromEnv, fromEnv, env) import System.Envy (FromEnv, fromEnv, env)
-------------------------------------------------------------------------------- --------------------------------------------------------------------------------
-- | Read from .envrc -- | Read from .envrc
data Env = Env data Env = Env
{ envGoogleClientID :: !String { envGoogleClientID :: !Text
, envServerPort :: !Int , envServerPort :: !Int
, envClientPort :: !Int , envClientPort :: !Int
, envStripeAPIKey :: !Text
} deriving (Eq, Show) } deriving (Eq, Show)
instance FromEnv Env where instance FromEnv Env where
fromEnv _ = do fromEnv _ = do
envGoogleClientID <- env "GOOGLE_CLIENT_ID" envGoogleClientID <- env "GOOGLE_CLIENT_ID"
envStripeAPIKey <- env "STRIPE_API_KEY"
envServerPort <- env "SERVER_PORT" envServerPort <- env "SERVER_PORT"
envClientPort <- env "CLIENT_PORT" envClientPort <- env "CLIENT_PORT"
pure Env {..} pure Env {..}
-- | Application context: a combination of Env and additional values. -- | Application context: a combination of Env and additional values.
data Context = Context data Context = Context
{ contextGoogleClientID :: !String { contextGoogleClientID :: !Text
, contextStripeAPIKey :: !Text
, contextServerPort :: !Int , contextServerPort :: !Int
, contextClientPort :: !Int , contextClientPort :: !Int
} }
@ -45,7 +50,7 @@ data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest
} deriving (Eq, Show) } deriving (Eq, Show)
instance FromJSON VerifyGoogleSignInRequest where instance FromJSON VerifyGoogleSignInRequest where
parseJSON = withObject "" $ \x -> do parseJSON = withObject "VerifyGoogleSignInRequest" $ \x -> do
idToken <- x .: "idToken" idToken <- x .: "idToken"
pure VerifyGoogleSignInRequest{..} pure VerifyGoogleSignInRequest{..}
@ -73,3 +78,69 @@ data Session = Session
-- , sessionAccountUUID :: UUID -- , sessionAccountUUID :: UUID
-- , sessionTsCreated :: Timestamp -- , sessionTsCreated :: Timestamp
} deriving (Eq, Show) } deriving (Eq, Show)
data CurrencyCode = USD
deriving (Eq, Show)
instance ToJSON CurrencyCode where
toJSON USD = String "usd"
instance FromJSON CurrencyCode where
parseJSON = withText "CurrencyCode" $ \x ->
case x of
"usd" -> pure USD
_ -> fail "Expected a valid currency code like: \"usd\""
instance ToHttpApiData CurrencyCode where
toQueryParam USD = "usd"
data PaymentIntent = PaymentIntent
{ paymentIntentAmount :: !Int
, paymentIntentCurrency :: !CurrencyCode
} deriving (Eq, Show)
instance ToJSON PaymentIntent where
toJSON PaymentIntent{..} =
object [ "amount" .= paymentIntentAmount
, "currency" .= paymentIntentCurrency
]
instance FromJSON PaymentIntent where
parseJSON = withObject "" $ \x -> do
paymentIntentAmount <- x .: "amount"
paymentIntentCurrency <- x .: "currency"
pure PaymentIntent{..}
instance QueryParam PaymentIntent where
queryParam = undefined
-- All applications have their secrets... Using the secret type ensures that no
-- sensitive information will get printed to the screen.
newtype Secret = Secret Text deriving (Eq)
instance Show Secret where
show (Secret _) = "[REDACTED]"
instance ToJSON Secret where
toJSON (Secret x) = toJSON x
instance FromJSON Secret where
parseJSON = withText "Secret" $ \x -> pure $ Secret x
data CreatePaymentIntentResponse = CreatePaymentIntentResponse
{ clientSecret :: Secret
} deriving (Eq, Show)
instance ToJSON CreatePaymentIntentResponse where
toJSON CreatePaymentIntentResponse{..} =
object [ "clientSecret" .= clientSecret
]
data StripePaymentIntent = StripePaymentIntent
{ pmtIntentClientSecret :: Secret
} deriving (Eq, Show)
instance FromJSON StripePaymentIntent where
parseJSON = withObject "StripeCreatePaymentIntentResponse" $ \x -> do
pmtIntentClientSecret <- x .: "client_secret"
pure StripePaymentIntent{..}

View file

@ -23,5 +23,6 @@ in briefcase.buildHaskell.program {
http-conduit http-conduit
rio rio
envy envy
req
]; ];
} }

View file

@ -13,5 +13,6 @@ in briefcase.buildHaskell.shell {
http-conduit http-conduit
rio rio
envy envy
req
]; ];
} }