Prefer ServantT for server to consume App context
Long story -> short: I'd like to access my App monad from within my Servant handlers. While this code type-checks, I'm not sure it's working as intended. Needing to change throwError to throwIO fails the "smell test". I expect to refactor this code, but I'm calling it a night for now.
This commit is contained in:
parent
bbcd0bf27d
commit
f61ed25755
2 changed files with 33 additions and 24 deletions
|
@ -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"]
|
||||
}
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in a new issue