subtree(users/wpcarro): docking briefcase at '24f5a642'

git-subtree-dir: users/wpcarro
git-subtree-mainline: 464bbcb15c
git-subtree-split: 24f5a642af
Change-Id: I6105b3762b79126b3488359c95978cadb3efa789

users/wpcarro/website/sandbox/learnpianochords/src/server/.envrc

@@ -0,0 +1,6 @@
+source_up
+use_nix
+export SERVER_PORT=3000
+export CLIENT_PORT=8000
+export GOOGLE_CLIENT_ID="$(jq -j '.google | .clientId' < ~/briefcase/secrets.json)"
+export STRIPE_API_KEY="$(jq -j '.stripe | .apiKey' < ~/briefcase/secrets.json)"

users/wpcarro/website/sandbox/learnpianochords/src/server/.ghci

@@ -0,0 +1,7 @@
+:set prompt "> "
+:set -Wall
+
+:set -XOverloadedStrings
+:set -XNoImplicitPrelude
+:set -XRecordWildCards
+:set -XTypeApplications

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

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"]
+      }

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"
+      }

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

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."

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

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

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

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{..}

users/wpcarro/website/sandbox/learnpianochords/src/server/Utils.hs

@@ -0,0 +1,8 @@
+--------------------------------------------------------------------------------
+module Utils where
+--------------------------------------------------------------------------------
+import Data.Function ((&))
+--------------------------------------------------------------------------------
+
+(|>) :: a -> (a -> b) -> b
+(|>) = (&)

users/wpcarro/website/sandbox/learnpianochords/src/server/default.nix

@@ -0,0 +1,28 @@
+let
+  briefcase = import <briefcase> {};
+in briefcase.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
+  ];
+}

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>

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;

users/wpcarro/website/sandbox/learnpianochords/src/server/shell.nix

@@ -0,0 +1,18 @@
+let
+  briefcase = import <briefcase> {};
+in briefcase.buildHaskell.shell {
+  deps = hpkgs: with hpkgs; [
+    hspec
+    servant-server
+    aeson
+    wai-cors
+    warp
+    jwt
+    unordered-containers
+    base64
+    http-conduit
+    rio
+    envy
+    req
+  ];
+}