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:
parent
de723c142b
commit
81aa32fe71
7 changed files with 118 additions and 5 deletions
|
@ -11,3 +11,6 @@ import qualified Types as T
|
|||
type API = "verify"
|
||||
:> ReqBody '[JSON] T.VerifyGoogleSignInRequest
|
||||
:> Post '[JSON] NoContent
|
||||
:<|> "create-payment-intent"
|
||||
:> ReqBody '[JSON] T.PaymentIntent
|
||||
:> Post '[JSON] T.CreatePaymentIntentResponse
|
||||
|
|
|
@ -12,11 +12,13 @@ import Utils
|
|||
|
||||
import qualified Network.Wai.Handler.Warp as Warp
|
||||
import qualified GoogleSignIn
|
||||
import qualified Stripe
|
||||
import qualified Types as T
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
server :: T.Context -> Server API
|
||||
server T.Context{..} = verifyGoogleSignIn
|
||||
server ctx@T.Context{..} = verifyGoogleSignIn
|
||||
:<|> createPaymentIntent
|
||||
where
|
||||
verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent
|
||||
verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do
|
||||
|
@ -31,6 +33,11 @@ server T.Context{..} = verifyGoogleSignIn
|
|||
err -> do
|
||||
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 = do
|
||||
ctx@T.Context{..} <- ask
|
||||
|
|
|
@ -18,6 +18,7 @@ getAppContext = do
|
|||
Left err -> pure $ Left err
|
||||
Right T.Env{..} -> pure $ Right T.Context
|
||||
{ contextGoogleClientID = envGoogleClientID
|
||||
, contextStripeAPIKey = envStripeAPIKey
|
||||
, contextServerPort = envServerPort
|
||||
, contextClientPort = envClientPort
|
||||
}
|
||||
|
|
29
website/sandbox/learnpianochords/src/server/Stripe.hs
Normal file
29
website/sandbox/learnpianochords/src/server/Stripe.hs
Normal 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
|
|
@ -1,28 +1,33 @@
|
|||
--------------------------------------------------------------------------------
|
||||
--------------------------------------------------------------------------------G
|
||||
module Types where
|
||||
--------------------------------------------------------------------------------
|
||||
import RIO
|
||||
import Data.Aeson
|
||||
import Network.HTTP.Req
|
||||
import Web.Internal.HttpApiData (ToHttpApiData(..))
|
||||
import System.Envy (FromEnv, fromEnv, env)
|
||||
--------------------------------------------------------------------------------
|
||||
|
||||
-- | Read from .envrc
|
||||
data Env = Env
|
||||
{ envGoogleClientID :: !String
|
||||
{ envGoogleClientID :: !Text
|
||||
, envServerPort :: !Int
|
||||
, envClientPort :: !Int
|
||||
, envStripeAPIKey :: !Text
|
||||
} deriving (Eq, Show)
|
||||
|
||||
instance FromEnv Env where
|
||||
fromEnv _ = do
|
||||
envGoogleClientID <- env "GOOGLE_CLIENT_ID"
|
||||
envStripeAPIKey <- env "STRIPE_API_KEY"
|
||||
envServerPort <- env "SERVER_PORT"
|
||||
envClientPort <- env "CLIENT_PORT"
|
||||
pure Env {..}
|
||||
|
||||
-- | Application context: a combination of Env and additional values.
|
||||
data Context = Context
|
||||
{ contextGoogleClientID :: !String
|
||||
{ contextGoogleClientID :: !Text
|
||||
, contextStripeAPIKey :: !Text
|
||||
, contextServerPort :: !Int
|
||||
, contextClientPort :: !Int
|
||||
}
|
||||
|
@ -45,7 +50,7 @@ data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest
|
|||
} deriving (Eq, Show)
|
||||
|
||||
instance FromJSON VerifyGoogleSignInRequest where
|
||||
parseJSON = withObject "" $ \x -> do
|
||||
parseJSON = withObject "VerifyGoogleSignInRequest" $ \x -> do
|
||||
idToken <- x .: "idToken"
|
||||
pure VerifyGoogleSignInRequest{..}
|
||||
|
||||
|
@ -73,3 +78,69 @@ data Session = Session
|
|||
-- , sessionAccountUUID :: UUID
|
||||
-- , sessionTsCreated :: Timestamp
|
||||
} 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{..}
|
||||
|
|
|
@ -23,5 +23,6 @@ in briefcase.buildHaskell.program {
|
|||
http-conduit
|
||||
rio
|
||||
envy
|
||||
req
|
||||
];
|
||||
}
|
||||
|
|
|
@ -13,5 +13,6 @@ in briefcase.buildHaskell.shell {
|
|||
http-conduit
|
||||
rio
|
||||
envy
|
||||
req
|
||||
];
|
||||
}
|
||||
|
|
Loading…
Reference in a new issue