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"
|
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
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
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
|
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{..}
|
||||||
|
|
|
@ -23,5 +23,6 @@ in briefcase.buildHaskell.program {
|
||||||
http-conduit
|
http-conduit
|
||||||
rio
|
rio
|
||||||
envy
|
envy
|
||||||
|
req
|
||||||
];
|
];
|
||||||
}
|
}
|
||||||
|
|
|
@ -13,5 +13,6 @@ in briefcase.buildHaskell.shell {
|
||||||
http-conduit
|
http-conduit
|
||||||
rio
|
rio
|
||||||
envy
|
envy
|
||||||
|
req
|
||||||
];
|
];
|
||||||
}
|
}
|
||||||
|
|
Loading…
Reference in a new issue