diff --git a/website/sandbox/learnpianochords/src/server/App.hs b/website/sandbox/learnpianochords/src/server/App.hs index 98742daef..095e6169b 100644 --- a/website/sandbox/learnpianochords/src/server/App.hs +++ b/website/sandbox/learnpianochords/src/server/App.hs @@ -6,41 +6,47 @@ 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 Network.Wai.Middleware.Cors as Cors import qualified GoogleSignIn import qualified Types as T -------------------------------------------------------------------------------- -server :: Server API +server :: ServerT API T.App server = verifyGoogleSignIn where - verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent + verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> T.App 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 } + T.Context{..} <- ask + 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 + -- TODO: I would prefer to use `throwError` here, but after changing + -- to ServerT, I couldn't get the code to compile. + throwIO err401 { errBody = err |> GoogleSignIn.explainResult |> cs } -run :: RIO T.Context () +run :: T.App () run = do - T.Context{..} <- ask - liftIO $ Warp.run contextServerPort (enforceCors $ serve (Proxy @ API) $ server) + ctx@T.Context{..} <- ask + server + |> hoistServer (Proxy @ API) (runRIO ctx) + |> serve (Proxy @ API) + |> cors (const $ Just corsPolicy) + |> Warp.run contextServerPort + |> liftIO where - enforceCors = Cors.cors (const $ Just corsPolicy) - corsPolicy :: Cors.CorsResourcePolicy - corsPolicy = - Cors.simpleCorsResourcePolicy - { Cors.corsOrigins = Just (["http://localhost:8000"], True) - , Cors.corsMethods = Cors.simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"] - , Cors.corsRequestHeaders = Cors.simpleHeaders ++ ["Content-Type", "Authorization"] - } + corsPolicy :: CorsResourcePolicy + corsPolicy = simpleCorsResourcePolicy + { corsOrigins = Just (["http://localhost:8000"], True) + , corsMethods = simpleMethods ++ ["PUT", "PATCH", "DELETE", "OPTIONS"] + , corsRequestHeaders = simpleHeaders ++ ["Content-Type", "Authorization"] + } diff --git a/website/sandbox/learnpianochords/src/server/Types.hs b/website/sandbox/learnpianochords/src/server/Types.hs index 3a9decf39..a9e6661f6 100644 --- a/website/sandbox/learnpianochords/src/server/Types.hs +++ b/website/sandbox/learnpianochords/src/server/Types.hs @@ -23,6 +23,9 @@ data Context = Context , contextClientPort :: !Int } +-- | Type synonym for my application monad. +type App = RIO Context + data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest { idToken :: !Text } deriving (Eq, Show)