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:
William Carroll 2020-08-09 23:15:12 +01:00
parent bbcd0bf27d
commit f61ed25755
2 changed files with 33 additions and 24 deletions

View file

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

View file

@ -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)