I'm trying to combine Servant authentication (servant-auth-server package) with RIO as my handler monad to avoid the ExceptT anti-pattern. However, I can't line up the types properly for handling denied authentications.
My (simplified) API endpoint is
type UserEndpoint = "user" :> (
Get '[JSON] User
:<|> ReqBody '[JSON] UpdatedUser :> Put '[JSON] User
)
and the corresponding server
protectedServer
:: HasLogFunc m
=> AuthResult AuthUserId
-> ServerT UserEndpoint (RIO m)
protectedServer (Authenticated authUser) =
getUser authUser :<|> updateUser authUser
-- Otherwise, we return a 401.
protectedServer _ = throwIO err401
A type error arises in the branch for denied authentication:
Could not deduce (MonadIO ((:<|>) (RIO m User)))
arising from a use of ‘throwIO’
[..]
I don't grok this type error. To my understanding (and given the signature of protectedServer
), the return type should be ServerT UserEndpoint (RIO m)
, which should have an instance of MonadIO
, so that exception handling according to the exceptions tutorial should use throwIO
instead of throwAll
from Servant.Auth.Server
. It seems that I haven't fully understood Servant's type machinery yet, where is my mistake?
The two handler functions are defined as
updateUser :: HasLogFunc m => AuthUserId -> UpdatedUser -> RIO m User
updateUser authUser updateUser = ...
getUser :: HasLogFunc m => AuthUserId -> RIO m User
getUser authUser = ...
The problem was that throwIO err401
is a single RIO
action. But when a servant server has more than one endpoint, each different handler must be composed with the :<|>
combinator.
If your API has has many endpoints, it will quickly become annoying to write 401-returning handlers for each and every one. Fortunately, it seems that servant-auth-server provides a throwAll
helper function which automatically builds error-returning handlers for an entire API.
Edit: as Ulrich has noted, the problem with throwAll
is that it only works with MonadError
monads, and RIO
is not an instance of MonadError
. But it should be possible to modify the typeclass so that it supports RIO
.
First, some imports and helper datatypes:
{-# LANGUAGE UndecidableInstances, TypeOperators, FlexibleInstances,
TypeFamilies, DataKinds, ImportQualifiedPost
#-}
module Main where
import RIO (RIO) -- rio
import RIO qualified
import Data.Tagged (Tagged (..)) -- package tagged
import Servant ((:<|>) (..), ServerError(..))
import Network.HTTP.Types -- package http-types
import Network.Wai -- package wai
import Data.ByteString.Char8 qualified as BS
And this is the main RIOThrowAll
typeclass:
class RIOThrowAll a where
rioThrowAll :: ServerError -> a
-- for a composition of endpoints
instance (RIOThrowAll a, RIOThrowAll b) => RIOThrowAll (a :<|> b) where
rioThrowAll e = rioThrowAll e :<|> rioThrowAll e
-- if we have a function, we ignore the argument and delegate on the result
instance (RIOThrowAll b) => RIOThrowAll (a -> b) where
rioThrowAll e = \_ -> rioThrowAll e
-- if we reach a RIO action at the tip of a function
instance RIOThrowAll (RIO.RIO env x) where
rioThrowAll e = RIO.throwIO e
-- this is only for Raw endpoints which embed a WAI app directly
instance RIOThrowAll (Tagged (RIO.RIO env x) Application) where
rioThrowAll e = Tagged $ \_req respond ->
respond $ responseLBS (mkStatus (errHTTPCode e) (BS.pack $ errReasonPhrase e))
(errHeaders e)
(errBody e)