diff options
Diffstat (limited to 'users/wpcarro/website/sandbox/learnpianochords/src/server')
16 files changed, 698 insertions, 0 deletions
diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/.envrc b/users/wpcarro/website/sandbox/learnpianochords/src/server/.envrc new file mode 100644 index 0000000000..9e714732fe --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/.envrc @@ -0,0 +1,7 @@ +source_up +use_nix +export SERVER_PORT=3000 +export CLIENT_PORT=8000 +# TODO(wpcarro): Prefer age-nix solution if possible. +export GOOGLE_CLIENT_ID="$(jq -j '.google | .clientId' < $WPCARRO/secrets.json)" +export STRIPE_API_KEY="$(jq -j '.stripe | .apiKey' < $WPCARRO/secrets.json)" diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/.ghci b/users/wpcarro/website/sandbox/learnpianochords/src/server/.ghci new file mode 100644 index 0000000000..151d070ca1 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/.ghci @@ -0,0 +1,7 @@ +:set prompt "> " +:set -Wall + +:set -XOverloadedStrings +:set -XNoImplicitPrelude +:set -XRecordWildCards +:set -XTypeApplications diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/API.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/API.hs new file mode 100644 index 0000000000..fe3671e7aa --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/API.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} +-------------------------------------------------------------------------------- +module API where +-------------------------------------------------------------------------------- +import Servant.API + +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/users/wpcarro/website/sandbox/learnpianochords/src/server/App.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/App.hs new file mode 100644 index 0000000000..b7a31457b7 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/App.hs @@ -0,0 +1,57 @@ +-------------------------------------------------------------------------------- +module App where +-------------------------------------------------------------------------------- +import RIO hiding (Handler) +import Servant +import API +import Data.String.Conversions (cs) +import Control.Monad.IO.Class (liftIO) +import Network.Wai.Middleware.Cors +import GoogleSignIn (EncodedJWT(..), ValidationResult(..)) +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 ctx@T.Context{..} = verifyGoogleSignIn + :<|> createPaymentIntent + where + verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent + verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do + validationResult <- liftIO $ GoogleSignIn.validateJWT False (EncodedJWT idToken) + case validationResult of + Valid _ -> do + -- If GoogleLinkedAccounts has email from JWT: + -- create a new session for email + -- Else: + -- Redirect the SPA to the sign-up / payment page + pure NoContent + 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 + ctx + |> server + |> serve (Proxy @API) + |> cors (const $ Just corsPolicy) + |> Warp.run contextServerPort + |> liftIO + pure $ Right () + where + corsPolicy :: CorsResourcePolicy + corsPolicy = simpleCorsResourcePolicy + { corsOrigins = Just (["http://localhost:8000"], True) + , corsMethods = simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"] + , corsRequestHeaders = simpleHeaders ++ ["Content-Type", "Authorization"] + } diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Fixtures.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Fixtures.hs new file mode 100644 index 0000000000..7c153e4228 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Fixtures.hs @@ -0,0 +1,67 @@ +-------------------------------------------------------------------------------- +module Fixtures where +-------------------------------------------------------------------------------- +import RIO +import Web.JWT +import Utils + +import qualified Data.Map as Map +import qualified GoogleSignIn +import qualified TestUtils +import qualified Data.Time.Clock.POSIX as POSIX +import qualified System.IO.Unsafe as Unsafe +-------------------------------------------------------------------------------- + +-- | These are the JWT fields that I'd like to overwrite in the `googleJWT` +-- function. +data JWTFields = JWTFields + { overwriteSigner :: Signer + , overwriteAuds :: [StringOrURI] + , overwriteIss :: StringOrURI + , overwriteExp :: NumericDate + } + +defaultJWTFields :: JWTFields +defaultJWTFields = do + let tenDaysFromToday = POSIX.getPOSIXTime + |> Unsafe.unsafePerformIO + |> (\x -> x * 60 * 60 * 25 * 10) + |> numericDate + |> TestUtils.unsafeJust + JWTFields + { overwriteSigner = hmacSecret "secret" + , overwriteAuds = ["771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"] + |> fmap TestUtils.unsafeStringOrURI + , overwriteIss = TestUtils.unsafeStringOrURI "accounts.google.com" + , overwriteExp = tenDaysFromToday + } + +googleJWT :: JWTFields -> GoogleSignIn.EncodedJWT +googleJWT JWTFields{..} = + encodeSigned signer jwtHeader claimSet + |> GoogleSignIn.EncodedJWT + where + signer :: Signer + signer = overwriteSigner + + jwtHeader :: JOSEHeader + jwtHeader = JOSEHeader + { typ = Just "JWT" + , cty = Nothing + , alg = Just RS256 + , kid = Just "f05415b13acb9590f70df862765c655f5a7a019e" + } + + claimSet :: JWTClaimsSet + claimSet = JWTClaimsSet + { iss = Just overwriteIss + , sub = stringOrURI "114079822315085727057" + , aud = overwriteAuds |> Right |> Just + -- TODO: Replace date creation with a human-readable date constructor. + , Web.JWT.exp = Just overwriteExp + , nbf = Nothing + -- TODO: Replace date creation with a human-readable date constructor. + , iat = numericDate 1596752853 + , unregisteredClaims = ClaimsMap (Map.fromList []) + , jti = stringOrURI "0d3d7fa1fe05bedec0a91c88294936b2b4d1b13c" + } diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs new file mode 100644 index 0000000000..dcccadcb70 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/GoogleSignIn.hs @@ -0,0 +1,111 @@ +-------------------------------------------------------------------------------- +module GoogleSignIn where +-------------------------------------------------------------------------------- +import RIO +import Data.String.Conversions (cs) +import Web.JWT +import Utils + +import qualified Network.HTTP.Simple as HTTP +import qualified Data.Text as Text +import qualified Web.JWT as JWT +import qualified Data.Time.Clock.POSIX as POSIX +-------------------------------------------------------------------------------- + +newtype EncodedJWT = EncodedJWT Text + deriving (Show) + +newtype DecodedJWT = DecodedJWT (JWT UnverifiedJWT) + deriving (Show) + +instance Eq DecodedJWT where + (DecodedJWT _) == (DecodedJWT _) = True + +data ValidationResult + = Valid DecodedJWT + | CannotDecodeJWT + | GoogleSaysInvalid Text + | NoMatchingClientIDs [StringOrURI] + | WrongIssuer StringOrURI + | StringOrURIParseFailure Text + | TimeConversionFailure + | MissingRequiredClaim Text + | StaleExpiry NumericDate + deriving (Eq, Show) + +-- | Returns True when the supplied `jwt` meets the following criteria: +-- * The token has been signed by Google +-- * The value of `aud` matches my Google client's ID +-- * The value of `iss` matches is "accounts.google.com" or +-- "https://accounts.google.com" +-- * The `exp` time has not passed +-- +-- Set `skipHTTP` to `True` to avoid making the network request for testing. +validateJWT :: Bool + -> EncodedJWT + -> IO ValidationResult +validateJWT skipHTTP (EncodedJWT encodedJWT) = do + case encodedJWT |> decode of + Nothing -> pure CannotDecodeJWT + Just jwt -> do + if skipHTTP then + continue jwt + else do + let request = "https://oauth2.googleapis.com/tokeninfo" + |> HTTP.setRequestQueryString [ ( "id_token", Just (cs encodedJWT) ) ] + res <- HTTP.httpLBS request + if HTTP.getResponseStatusCode res /= 200 then + pure $ GoogleSaysInvalid (res |> HTTP.getResponseBody |> cs) + else + continue jwt + where + continue :: JWT UnverifiedJWT -> IO ValidationResult + continue jwt = do + let audValues :: [StringOrURI] + audValues = jwt |> claims |> auds + expectedClientID :: Text + expectedClientID = "771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com" + expectedIssuers :: [Text] + expectedIssuers = [ "accounts.google.com" + , "https://accounts.google.com" + ] + mExpectedClientID :: Maybe StringOrURI + mExpectedClientID = stringOrURI expectedClientID + mExpectedIssuers :: Maybe [StringOrURI] + mExpectedIssuers = expectedIssuers |> traverse stringOrURI + case (mExpectedClientID, mExpectedIssuers) of + (Nothing, _) -> pure $ StringOrURIParseFailure expectedClientID + (_, Nothing) -> pure $ StringOrURIParseFailure (Text.unwords expectedIssuers) + (Just clientID, Just parsedIssuers) -> + -- TODO: Prefer reading clientID from a config. I'm thinking of the + -- AppContext type having my Configuration + if not $ clientID `elem` audValues then + pure $ NoMatchingClientIDs audValues + else + case (jwt |> claims |> iss, jwt |> claims |> JWT.exp) of + (Nothing, _) -> pure $ MissingRequiredClaim "iss" + (_, Nothing) -> pure $ MissingRequiredClaim "exp" + (Just jwtIssuer, Just jwtExpiry) -> + if not $ jwtIssuer `elem` parsedIssuers then + pure $ WrongIssuer jwtIssuer + else do + mCurrentTime <- POSIX.getPOSIXTime |> fmap numericDate + case mCurrentTime of + Nothing -> pure TimeConversionFailure + Just currentTime -> + if not $ currentTime <= jwtExpiry then + pure $ StaleExpiry jwtExpiry + else + pure $ jwt |> DecodedJWT |> Valid + +-- | Attempt to explain the `ValidationResult` to a human. +explainResult :: ValidationResult -> String +explainResult (Valid _) = "Everything appears to be valid" +explainResult CannotDecodeJWT = "We had difficulty decoding the provided JWT" +explainResult (GoogleSaysInvalid x) = "After checking with Google, they claimed that the provided JWT was invalid: " ++ cs x +explainResult (NoMatchingClientIDs audFields) = "None of the values in the `aud` field on the provided JWT match our client ID: " ++ show audFields +explainResult (WrongIssuer issuer) = "The `iss` field in the provided JWT does not match what we expect: " ++ show issuer +explainResult (StringOrURIParseFailure x) = "We had difficulty parsing values as URIs" ++ show x +explainResult TimeConversionFailure = "We had difficulty converting the current time to a value we can use to compare with the JWT's `exp` field" +explainResult (MissingRequiredClaim claim) = "Your JWT is missing the following claim: " ++ cs claim +explainResult (StaleExpiry x) = "The `exp` field on your JWT has expired" ++ x |> show |> cs diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Main.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Main.hs new file mode 100644 index 0000000000..228c3363bc --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Main.hs @@ -0,0 +1,37 @@ +-------------------------------------------------------------------------------- +module Main where +-------------------------------------------------------------------------------- +import RIO +import Prelude (putStr, putStrLn) + +import qualified Types as T +import qualified System.Envy as Envy +import qualified App +-------------------------------------------------------------------------------- + +-- | Attempt to read environment variables from the system and initialize the +-- Context data type for our application. +getAppContext :: IO (Either String T.Context) +getAppContext = do + mEnv <- Envy.decodeEnv + case mEnv of + Left err -> pure $ Left err + Right T.Env{..} -> pure $ Right T.Context + { contextGoogleClientID = envGoogleClientID + , contextStripeAPIKey = envStripeAPIKey + , contextServerPort = envServerPort + , contextClientPort = envClientPort + } + +main :: IO () +main = do + mContext <- getAppContext + case mContext of + Left err -> putStrLn err + Right ctx -> do + result <- runRIO ctx App.run + case result of + Left err -> do + putStr "Something went wrong when executing the application: " + putStrLn $ show err + Right _ -> putStrLn "The application successfully executed." diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Spec.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Spec.hs new file mode 100644 index 0000000000..3c476bbf7b --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Spec.hs @@ -0,0 +1,74 @@ +-------------------------------------------------------------------------------- +module Spec where +-------------------------------------------------------------------------------- +import RIO +import Test.Hspec +import Utils +import Web.JWT (numericDate, decode) +import GoogleSignIn (EncodedJWT(..), DecodedJWT(..), ValidationResult(..)) + +import qualified GoogleSignIn +import qualified Fixtures as F +import qualified TestUtils +import qualified Data.Time.Clock.POSIX as POSIX +-------------------------------------------------------------------------------- + +main :: IO () +main = hspec $ do + describe "GoogleSignIn" $ + describe "validateJWT" $ do + let validateJWT' = GoogleSignIn.validateJWT True + it "returns a decode error when an incorrectly encoded JWT is used" $ do + validateJWT' (GoogleSignIn.EncodedJWT "rubbish") `shouldReturn` CannotDecodeJWT + + it "returns validation error when the aud field doesn't match my client ID" $ do + let auds = ["wrong-client-id"] + |> fmap TestUtils.unsafeStringOrURI + encodedJWT = F.defaultJWTFields { F.overwriteAuds = auds } + |> F.googleJWT + validateJWT' encodedJWT `shouldReturn` NoMatchingClientIDs auds + + it "returns validation success when one of the aud fields matches my client ID" $ do + let auds = ["wrong-client-id", "771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"] + |> fmap TestUtils.unsafeStringOrURI + encodedJWT@(EncodedJWT jwt) = + F.defaultJWTFields { F.overwriteAuds = auds } + |> F.googleJWT + decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT + validateJWT' encodedJWT `shouldReturn` Valid decodedJWT + + it "returns validation error when one of the iss field doesn't match accounts.google.com or https://accounts.google.com" $ do + let erroneousIssuer = TestUtils.unsafeStringOrURI "not-accounts.google.com" + encodedJWT = F.defaultJWTFields { F.overwriteIss = erroneousIssuer } + |> F.googleJWT + validateJWT' encodedJWT `shouldReturn` WrongIssuer erroneousIssuer + + it "returns validation success when the iss field matches accounts.google.com or https://accounts.google.com" $ do + let erroneousIssuer = TestUtils.unsafeStringOrURI "https://accounts.google.com" + encodedJWT@(EncodedJWT jwt) = + F.defaultJWTFields { F.overwriteIss = erroneousIssuer } + |> F.googleJWT + decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT + validateJWT' encodedJWT `shouldReturn` Valid decodedJWT + + it "fails validation when the exp field has expired" $ do + let mErroneousExp = numericDate 0 + case mErroneousExp of + Nothing -> True `shouldBe` False + Just erroneousExp -> do + let encodedJWT = F.defaultJWTFields { F.overwriteExp = erroneousExp } + |> F.googleJWT + validateJWT' encodedJWT `shouldReturn` StaleExpiry erroneousExp + + it "passes validation when the exp field is current" $ do + mFreshExp <- POSIX.getPOSIXTime + |> fmap (\x -> x * 60 * 60 * 24 * 10) -- 10 days later + |> fmap numericDate + case mFreshExp of + Nothing -> True `shouldBe` False + Just freshExp -> do + let encodedJWT@(EncodedJWT jwt) = + F.defaultJWTFields { F.overwriteExp = freshExp } + |> F.googleJWT + decodedJWT = jwt |> decode |> TestUtils.unsafeJust |> DecodedJWT + validateJWT' encodedJWT `shouldReturn` Valid decodedJWT diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Stripe.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Stripe.hs new file mode 100644 index 0000000000..5370b90abe --- /dev/null +++ b/users/wpcarro/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/users/wpcarro/website/sandbox/learnpianochords/src/server/TestUtils.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/TestUtils.hs new file mode 100644 index 0000000000..24054bf47a --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/TestUtils.hs @@ -0,0 +1,17 @@ +-------------------------------------------------------------------------------- +module TestUtils where +-------------------------------------------------------------------------------- +import RIO +import Web.JWT +import Data.String.Conversions (cs) +-------------------------------------------------------------------------------- + +unsafeStringOrURI :: String -> StringOrURI +unsafeStringOrURI x = + case stringOrURI (cs x) of + Nothing -> error $ "Failed to convert to StringOrURI: " ++ x + Just res -> res + +unsafeJust :: Maybe a -> a +unsafeJust Nothing = error "Attempted to force a Nothing to be a something" +unsafeJust (Just x) = x diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/Types.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Types.hs new file mode 100644 index 0000000000..4a72865153 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Types.hs @@ -0,0 +1,146 @@ +--------------------------------------------------------------------------------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 :: !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 :: !Text + , contextStripeAPIKey :: !Text + , contextServerPort :: !Int + , contextClientPort :: !Int + } + +-- | Top-level except for our application, as RIO recommends defining. +type Failure = () + +-- | When our app executes along the "happy path" this is the type of result it +-- produces. +type Success = () + +-- | This is our application monad. +type AppM = RIO Context + +-- | The concrete type of our application. +type App = AppM (Either Failure Success) + +data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest + { idToken :: !Text + } deriving (Eq, Show) + +instance FromJSON VerifyGoogleSignInRequest where + parseJSON = withObject "VerifyGoogleSignInRequest" $ \x -> do + idToken <- x .: "idToken" + pure VerifyGoogleSignInRequest{..} + +data GoogleLinkedAccount = GoogleLinkedAccount + { + -- { googleLinkedAccountUUID :: UUID + -- , googleLinkedAccountEmail :: Email + -- , googleLinkedAccountTsCreated :: Timestamp + googleLinkedAccountGivenName :: !(Maybe Text) + , googleLinkedAccountFamilyName :: !(Maybe Text) + , googleLinkedAccountFullName :: !(Maybe Text) + -- , googleLinkedAccountPictureURL :: URL + -- , googleLinkedAccountLocale :: Maybe Locale + } deriving (Eq, Show) + +data PayingCustomer = PayingCustomer + { + -- { payingCustomerAccountUUID :: UUID + -- , payingCustomerTsCreated :: Timestamp + } deriving (Eq, Show) + +data Session = Session + { + -- { sessionUUID :: UUID + -- , 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/users/wpcarro/website/sandbox/learnpianochords/src/server/Utils.hs b/users/wpcarro/website/sandbox/learnpianochords/src/server/Utils.hs new file mode 100644 index 0000000000..2f401af2fb --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/Utils.hs @@ -0,0 +1,8 @@ +-------------------------------------------------------------------------------- +module Utils where +-------------------------------------------------------------------------------- +import Data.Function ((&)) +-------------------------------------------------------------------------------- + +(|>) :: a -> (a -> b) -> b +(|>) = (&) diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/default.nix b/users/wpcarro/website/sandbox/learnpianochords/src/server/default.nix new file mode 100644 index 0000000000..262693ae82 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/default.nix @@ -0,0 +1,28 @@ +{ depot, ... }: + +depot.users.wpcarro.buildHaskell.program { + name = "server"; + srcs = builtins.path { + path = ./.; + name = "LearnPianoChords-server-src"; + }; + ghcExtensions = [ + "OverloadedStrings" + "NoImplicitPrelude" + "RecordWildCards" + "TypeApplications" + ]; + deps = hpkgs: with hpkgs; [ + servant-server + aeson + wai-cors + warp + jwt + unordered-containers + base64 + http-conduit + rio + envy + req + ]; +} diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/index.html b/users/wpcarro/website/sandbox/learnpianochords/src/server/index.html new file mode 100644 index 0000000000..459a5c8c82 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/index.html @@ -0,0 +1,35 @@ +<!DOCTYPE html> +<html lang="en"> + <head> + <meta charset="UTF-8" /> + <title>Google Sign-in</title> + <script src="https://apis.google.com/js/platform.js" async defer></script> + <meta name="google-signin-client_id" content="771151720060-buofllhed98fgt0j22locma05e7rpngl.apps.googleusercontent.com"> + </head> + <body> + <div class="g-signin2" data-onsuccess="onSignIn"></div> + <a href="#" onclick="signOut();">Sign out</a> + <script> + function onSignIn(googleUser) { + var idToken = googleUser.getAuthResponse().id_token; + fetch('http://localhost:3000/verify', { + method: 'POST', + headers: { + 'Content-Type': 'application/json', + }, + body: JSON.stringify({ + idToken: idToken, + }) + }) + .then(x => console.log(x)) + .catch(err => console.error(err)); + } + function signOut() { + var auth2 = gapi.auth2.getAuthInstance(); + auth2.signOut().then(function () { + console.log('User signed out.'); + }); + } + </script> + </body> +</html> diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/init.sql b/users/wpcarro/website/sandbox/learnpianochords/src/server/init.sql new file mode 100644 index 0000000000..c220bd4406 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/init.sql @@ -0,0 +1,41 @@ +BEGIN TRANSACTION; + +DROP TABLE IF EXISTS GoogleLinkedAccounts; +DROP TABLE IF EXISTS PayingCustomers; +DROP TABLE IF EXISTS Sessions; + +-- Store some of the information that Google provides to us from the JWT. +CREATE TABLE GoogleLinkedAccounts ( + accountUUID TEXT CHECK(LENGTH(uuid) == 36) NOT NULL UNIQUE, + email TEXT NOT NULL UNIQUE, + tsCreated TEXT NOT NULL, -- 'YYYY-MM-DD HH:MM:SS' + givenName TEXT, + familyName TEXT, + fullName TEXT, + pictureURL TEXT, + locale TEXT, + PRIMARY KEY (accountUUID) +); + +-- Track which of our customers have a paid account. +-- Defines a one-to-one relationship between: +-- GoogleLinkedAccounts and PayingCustomers +CREATE TABLE PayingCustomers ( + accountUUID TEXT, + tsCreated TEXT, + PRIMARY KEY (accountUUID), + FOREIGN KEY (accountUUID) REFERENCES GoogleLinkedAccounts ON DELETE CASCADE +); + +-- Define mobile and web sessions for our users. +-- Defines a one-to-many relationship between: +-- GoogleLinkedAccounts and Sessions +CREATE TABLE Sessions ( + sessionUUID TEXT CHECK(LENGTH(sessionUUID) == 36) NOT NULL UNIQUE, + accountUUID TEXT, + tsCreated TEXT NOT NULL, -- 'YYYY-MM-DD HH:MM:SS' + PRIMARY KEY (sessionUUID) + FOREIGN KEY(accountUUID) REFERENCES GoogleLinkedAccounts ON DELETE CASCADE +); + +COMMIT; diff --git a/users/wpcarro/website/sandbox/learnpianochords/src/server/shell.nix b/users/wpcarro/website/sandbox/learnpianochords/src/server/shell.nix new file mode 100644 index 0000000000..6ec8264470 --- /dev/null +++ b/users/wpcarro/website/sandbox/learnpianochords/src/server/shell.nix @@ -0,0 +1,18 @@ +{ depot, ... }: + +depot.users.wpcarro.buildHaskell.shell { + deps = hpkgs: with hpkgs; [ + hspec + servant-server + aeson + wai-cors + warp + jwt + unordered-containers + base64 + http-conduit + rio + envy + req + ]; +} |