Drop support for ServantT transformer type for server
After burning a few hours wrestling with the type system, I decided to revert to the simpler `Server API` type instead of the `ServantT` transformer type. The problem is that I couldn't write a MonadError instance for `RIO Context`, which is my `AppM` (i.e. application monad). Using `throwIO` in the server handlers results in 500 errors, which is not what I wanted. I'm still pretty fuzzy about what's happening; I now know that exception handling in Haskell is pretty gnaryly. I may revisit this at a later time when my knowledge is more extensive. For now: time to fry bigger fish. An easier abstract is for me to pass `T.Context` into `server` as an argument, which after all is what a Reader does. TL;DR: - Read server, client ports from .envrc - Define a top-level Failure type (empty for now) - Define a top-level Success type - Define App as RIO Context (Either Failure Success)
This commit is contained in:
		
							parent
							
								
									f61ed25755
								
							
						
					
					
						commit
						4ff1ea291c
					
				
					 3 changed files with 59 additions and 16 deletions
				
			
		| 
						 | 
				
			
			@ -15,12 +15,11 @@ import qualified GoogleSignIn
 | 
			
		|||
import qualified Types as T
 | 
			
		||||
--------------------------------------------------------------------------------
 | 
			
		||||
 | 
			
		||||
server :: ServerT API T.App
 | 
			
		||||
server = verifyGoogleSignIn
 | 
			
		||||
server :: T.Context -> Server API
 | 
			
		||||
server T.Context{..} = verifyGoogleSignIn
 | 
			
		||||
  where
 | 
			
		||||
    verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> T.App NoContent
 | 
			
		||||
    verifyGoogleSignIn :: T.VerifyGoogleSignInRequest -> Handler NoContent
 | 
			
		||||
    verifyGoogleSignIn T.VerifyGoogleSignInRequest{..} = do
 | 
			
		||||
      T.Context{..} <- ask
 | 
			
		||||
      validationResult <- liftIO $ GoogleSignIn.validateJWT False (EncodedJWT idToken)
 | 
			
		||||
      case validationResult of
 | 
			
		||||
        Valid _ -> do
 | 
			
		||||
| 
						 | 
				
			
			@ -30,19 +29,18 @@ server = verifyGoogleSignIn
 | 
			
		|||
          --   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 }
 | 
			
		||||
          throwError err401 { errBody = err |> GoogleSignIn.explainResult |> cs }
 | 
			
		||||
 | 
			
		||||
run :: T.App ()
 | 
			
		||||
run :: T.App
 | 
			
		||||
run = do
 | 
			
		||||
  ctx@T.Context{..} <- ask
 | 
			
		||||
  server
 | 
			
		||||
    |> hoistServer (Proxy @ API) (runRIO ctx)
 | 
			
		||||
  ctx
 | 
			
		||||
    |> server
 | 
			
		||||
    |> serve (Proxy @ API)
 | 
			
		||||
    |> cors (const $ Just corsPolicy)
 | 
			
		||||
    |> Warp.run contextServerPort
 | 
			
		||||
    |> liftIO
 | 
			
		||||
  pure $ Right ()
 | 
			
		||||
  where
 | 
			
		||||
    corsPolicy :: CorsResourcePolicy
 | 
			
		||||
    corsPolicy = simpleCorsResourcePolicy
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -2,7 +2,7 @@
 | 
			
		|||
module Main where
 | 
			
		||||
--------------------------------------------------------------------------------
 | 
			
		||||
import RIO
 | 
			
		||||
import Prelude (putStrLn)
 | 
			
		||||
import Prelude (putStr, putStrLn)
 | 
			
		||||
 | 
			
		||||
import qualified Types as T
 | 
			
		||||
import qualified System.Envy as Envy
 | 
			
		||||
| 
						 | 
				
			
			@ -18,8 +18,8 @@ getAppContext = do
 | 
			
		|||
    Left err -> pure $ Left err
 | 
			
		||||
    Right T.Env{..} -> pure $ Right T.Context
 | 
			
		||||
      { contextGoogleClientID = envGoogleClientID
 | 
			
		||||
      , contextClientPort = 8000
 | 
			
		||||
      , contextServerPort = 3000
 | 
			
		||||
      , contextServerPort = envServerPort
 | 
			
		||||
      , contextClientPort = envClientPort
 | 
			
		||||
      }
 | 
			
		||||
 | 
			
		||||
main :: IO ()
 | 
			
		||||
| 
						 | 
				
			
			@ -27,4 +27,10 @@ main = do
 | 
			
		|||
  mContext <- getAppContext
 | 
			
		||||
  case mContext of
 | 
			
		||||
    Left err -> putStrLn err
 | 
			
		||||
    Right ctx -> runRIO ctx App.run
 | 
			
		||||
    Right ctx -> do
 | 
			
		||||
      result <- runRIO ctx App.run
 | 
			
		||||
      case result of
 | 
			
		||||
        Left err -> do
 | 
			
		||||
          putStr "Something went wrong when executing the application: "
 | 
			
		||||
          putStrLn $ show err
 | 
			
		||||
        Right _ -> putStrLn "The application successfully executed."
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -9,11 +9,15 @@ import System.Envy (FromEnv, fromEnv, env)
 | 
			
		|||
-- | Read from .envrc
 | 
			
		||||
data Env = Env
 | 
			
		||||
  { envGoogleClientID :: !String
 | 
			
		||||
  , envServerPort :: !Int
 | 
			
		||||
  , envClientPort :: !Int
 | 
			
		||||
  } deriving (Eq, Show)
 | 
			
		||||
 | 
			
		||||
instance FromEnv Env where
 | 
			
		||||
  fromEnv _ = do
 | 
			
		||||
    envGoogleClientID <- env "GOOGLE_CLIENT_ID"
 | 
			
		||||
    envServerPort <- env "SERVER_PORT"
 | 
			
		||||
    envClientPort <- env "CLIENT_PORT"
 | 
			
		||||
    pure Env {..}
 | 
			
		||||
 | 
			
		||||
-- | Application context: a combination of Env and additional values.
 | 
			
		||||
| 
						 | 
				
			
			@ -23,8 +27,18 @@ data Context = Context
 | 
			
		|||
  , contextClientPort :: !Int
 | 
			
		||||
  }
 | 
			
		||||
 | 
			
		||||
-- | Type synonym for my application monad.
 | 
			
		||||
type App = RIO Context
 | 
			
		||||
-- | Top-level except for our application, as RIO recommends defining.
 | 
			
		||||
type Failure = ()
 | 
			
		||||
 | 
			
		||||
-- | When our app executes along the "happy path" this is the type of result it
 | 
			
		||||
-- produces.
 | 
			
		||||
type Success = ()
 | 
			
		||||
 | 
			
		||||
-- | This is our application monad.
 | 
			
		||||
type AppM = RIO Context
 | 
			
		||||
 | 
			
		||||
-- | The concrete type of our application.
 | 
			
		||||
type App = AppM (Either Failure Success)
 | 
			
		||||
 | 
			
		||||
data VerifyGoogleSignInRequest = VerifyGoogleSignInRequest
 | 
			
		||||
  { idToken :: !Text
 | 
			
		||||
| 
						 | 
				
			
			@ -34,3 +48,28 @@ instance FromJSON VerifyGoogleSignInRequest where
 | 
			
		|||
  parseJSON = withObject "" $ \x -> do
 | 
			
		||||
    idToken <- x .: "idToken"
 | 
			
		||||
    pure VerifyGoogleSignInRequest{..}
 | 
			
		||||
 | 
			
		||||
data GoogleLinkedAccount = GoogleLinkedAccount
 | 
			
		||||
  {
 | 
			
		||||
  -- { googleLinkedAccountUUID :: UUID
 | 
			
		||||
  -- , googleLinkedAccountEmail :: Email
 | 
			
		||||
  -- , googleLinkedAccountTsCreated :: Timestamp
 | 
			
		||||
    googleLinkedAccountGivenName :: !(Maybe Text)
 | 
			
		||||
  , googleLinkedAccountFamilyName :: !(Maybe Text)
 | 
			
		||||
  , googleLinkedAccountFullName :: !(Maybe Text)
 | 
			
		||||
  -- , googleLinkedAccountPictureURL :: URL
 | 
			
		||||
  -- , googleLinkedAccountLocale :: Maybe Locale
 | 
			
		||||
  } deriving (Eq, Show)
 | 
			
		||||
 | 
			
		||||
data PayingCustomer = PayingCustomer
 | 
			
		||||
  {
 | 
			
		||||
  -- { payingCustomerAccountUUID :: UUID
 | 
			
		||||
  -- , payingCustomerTsCreated :: Timestamp
 | 
			
		||||
  } deriving (Eq, Show)
 | 
			
		||||
 | 
			
		||||
data Session = Session
 | 
			
		||||
  {
 | 
			
		||||
  -- { sessionUUID :: UUID
 | 
			
		||||
  -- , sessionAccountUUID :: UUID
 | 
			
		||||
  -- , sessionTsCreated :: Timestamp
 | 
			
		||||
  } deriving (Eq, Show)
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue