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

7 files changed, 118 insertions, 5 deletions

diff --git a/website/sandbox/learnpianochords/src/server/API.hs b/website/sandbox/learnpianochords/src/server/API.hs
index aebfd92aab6c..fe3671e7aa3e 100644
--- a/website/sandbox/learnpianochords/src/server/API.hs
+++ b/website/sandbox/learnpianochords/src/server/API.hs
@@ -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
diff --git a/website/sandbox/learnpianochords/src/server/App.hs b/website/sandbox/learnpianochords/src/server/App.hs
index 92dee6045d46..e23757b01544 100644
--- a/website/sandbox/learnpianochords/src/server/App.hs
+++ b/website/sandbox/learnpianochords/src/server/App.hs
@@ -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
diff --git a/website/sandbox/learnpianochords/src/server/Main.hs b/website/sandbox/learnpianochords/src/server/Main.hs
index a163c66cda07..228c3363bc59 100644
--- a/website/sandbox/learnpianochords/src/server/Main.hs
+++ b/website/sandbox/learnpianochords/src/server/Main.hs
@@ -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
       }
diff --git a/website/sandbox/learnpianochords/src/server/Stripe.hs b/website/sandbox/learnpianochords/src/server/Stripe.hs
new file mode 100644
index 000000000000..5370b90abebf
--- /dev/null
+++ b/website/sandbox/learnpianochords/src/server/Stripe.hs
@@ -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
diff --git a/website/sandbox/learnpianochords/src/server/Types.hs b/website/sandbox/learnpianochords/src/server/Types.hs
index 2303a752e4ad..4a72865153ab 100644
--- a/website/sandbox/learnpianochords/src/server/Types.hs
+++ b/website/sandbox/learnpianochords/src/server/Types.hs
@@ -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{..}
diff --git a/website/sandbox/learnpianochords/src/server/default.nix b/website/sandbox/learnpianochords/src/server/default.nix
index 4efe1183d16a..6ed68d4417f4 100644
--- a/website/sandbox/learnpianochords/src/server/default.nix
+++ b/website/sandbox/learnpianochords/src/server/default.nix
@@ -23,5 +23,6 @@ in briefcase.buildHaskell.program {
     http-conduit
     rio
     envy
+    req
   ];
 }
diff --git a/website/sandbox/learnpianochords/src/server/shell.nix b/website/sandbox/learnpianochords/src/server/shell.nix
index 4d787184bd4a..a655c15871f9 100644
--- a/website/sandbox/learnpianochords/src/server/shell.nix
+++ b/website/sandbox/learnpianochords/src/server/shell.nix
@@ -13,5 +13,6 @@ in briefcase.buildHaskell.shell {
     http-conduit
     rio
     envy
+    req
   ];
 }