Search code examples
authenticationhaskellservantrio

Deny Authentication in Servant.Auth with RIO

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 = ...
Solution

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