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…
	
	Add table
		Add a link
		
	
		Reference in a new issue