diff options
Diffstat (limited to 'website/sandbox/learnpianochords/src')
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 ]; } |