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:
William Carroll 2020-08-10 15:02:05 +01:00
parent f61ed25755
commit 4ff1ea291c
3 changed files with 59 additions and 16 deletions

View file

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

View file

@ -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."

View file

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