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