website/sandbox/learnpianochords/src/server/App.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50

--------------------------------------------------------------------------------
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 Types as T
--------------------------------------------------------------------------------

server :: T.Context -> Server API
server T.Context{..} = verifyGoogleSignIn
  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 }

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