Auth Aware Haskell Functions

I’ve been working on a user management system that needs to have complex yet flexible auth rules. The goal is to reliably inject and review auth (authentication + authorization) rules into endpoints. The most straightforwed solution is consider authentication part of the endpoint logic. While this may work for a smaller application, quickly becomes unmanageable for complex systems.

It is much more cleaner to separate the auth from the application. This is already a very common pattern and there are a lot of tools that help you do this. For example, you run a separate policy server on top of our endpoints to create this abstraction.

While this is a possible solution this is over-abstration for my use case. I want a more tightly integrated haskell based auth layer. I will try to describe the auth layer I plan to use for the user management system. How auth is implemented is not what we will be looking at. It is more about how it is structured and injected.

Interface

Validation

There are a few layer through with the input data from a user has to pass though before they get a response. The request input first needs to me sanitised (or validated) for the rest of the application to accept it.

newtype Validated a = Validated a

newtype ValidationError = ValidationError String deriving (Show)

data ValidationResult a
    = VRFailed ValidationError
    | VRPassed (Validated a)

class Validation a where
    validate :: a -> ValidationResult a

The type class above provides an abstract interface for validation. For now, it might seem bland but we will go through an example at the end to see how all of this fits togather.

Auth

newtype Permitted payload ctx = Permitted { permittedCtx :: ctx }

newtype PermissionError = PermissionError String deriving (Show)

data PermitDecision payload ctx
    = PDDenied PermissionError
    | PDAllowed (Permitted payload ctx)

class Monad m => Auth m payload where
    type AuthContext payload
    permit ::
        Maybe Jwt ->
        Validated payload ->
        m (PermitDecision payload (AuthContext payload))

This is not as simple as the validation interface but should not be very hard to read. AuthContext here is interesting though. There is a unique AuthContext to every endpoint. It is essentially the additional context you want to propagate along with the auth decision. The reason for having this is to not repeat costly functionality. The auth layer may make some costly outbound calls to build the context for making the auth decision. This context may potentially be used later and so we propagate this context.

Logic

class Monad m => Logic m payload where
    type LogicResult payload
    logic ::
        Validated payload ->
        Permitted payload (AuthContext payload) ->
        m (LogicResult payload)

This should be very straightforward to read. It is not hard to see why we we need a LogicResult. Different endpoints have different outputs.

Runner

The endpoint is all of these steps combined together.

runEndpoint ::
    forall m payload.
    ( MonadThrow m
    , Validation payload
    , Auth m payload
    , Logic m payload
    ) =>
    Maybe Jwt -> payload -> m (LogicResult payload)
runEndpoint cs payload0 = do
    payload <- vresult throwM pure (validate payload0)
    decision <- permit cs payload
    case decision of
        PDDenied perr -> throwM perr
        PDAllowed ctx -> logic payload ctx

Example

Let’s start with the assumption that a few functions already exist.

data User = User { userId :: Int }

getUserFromToken :: Jwt -> IO User
checkRole :: User -> Role -> IO Bool

parseJwt is essentially an authentication check and checkRole checks if the user has specific role. checkRole may be part of a very elaborate RBAC system.

Let’s assume we have a user information table represented by the type:

data ModifiedBy = Self | Admin Int | SupportStaff Int

data UserInfo = UserInfo
    { uiFullName   :: String
    , uiModifiedBy :: ModifiedBy
    , uiUserId     :: ForeignKey User -- ForeignKey User == Int
    }

getUserInfo :: ForeignKey User -> UserInfo
setUserFullName :: String -> String -> ForeignKey User -> IO ()

Our system allows uiFullName to be modified by: 1. The user themselves 2. The admin 3. The support staff that manages the user

From the type we can also see that our syetem tracks who edited the info.

The support staff information may look like the following:

data SupportStaffAssignments = SupportStaffAssignments
    { ssStaffId    :: ForeignKey User   -- ForeignKey User == Int
    , ssAssignedTo :: [ForeignKey User] -- ForeignKey User == Int
    }

getSupportStaff :: ForeignKey User -> IO SupportStaffAssignments

Additionally, let’s also assume that the full name always needs to be <= 40 characters.

Endpoint Implementation

With that context our endpoint would look like the following:

data UdpateFullNameEndpoint = UdpateFullNameEndpoint
    { ufneNewFullName :: String
    , ufneTargetUser  :: ForeignKey User
    }

We can start by implementing the logic first. The logic should be very simple and straightforward. And since we know Logic is only executed after Validation and Auth, we are confident about the input and the permissions.

instance Logic IO UdpateFullNameEndpoint where
    type LogicResult UdpateFullNameEndpoint = ()
    logic (Validated (UdpateFullNameEndpoint{..})) (Permitted modifiedBy) =
        setUserFullName ufneNewFullName ufneTargetUser modifiedBy

The validation would look like:

instance Validation UdpateFullNameEndpoint where
    validate val =
        if length (ufneNewFullName val) <= 40
        then VRPassed (Validated val)
        else VRFailed (ValidationError "Name is > 40 characters.")

The auth is a little more elaborate because of our requirements:

instance Auth IO UdpateFullNameEndpoint where
    type AuthContext UdpateFullNameEndpoint = ModifiedBy
    permit (Just jwt) (Validated val) = do
        actor <- getUserFromToken jwt
        let actorId = userId actor
            targetUserId = ufneTargetUser val
        if actorId == targetUserId
        then pure $ PDAllowed $ Permitted Self
        else do
            isAdmin <- checkRole actor "admin"
            if isAdmin
            then pure $ PDAllowed $ Permitted $ Admin uid
            else do
                isSupportStaff  <- checkRole actor "support_staff"
                if isSupportStaff
                then do
                    staffVal <- getSupportStaff actorId
                    if ssAssignedTo staffVal `elem` targetUserId
                    then pure $ PDAllowed $ Permitted $ SupportStaff uid
                    else pure $ PDDenied
                else pure $ PDDenied

I hope you’re able to see the power of our simple abstractions. Our complete endpoint is essentially 3 different abstaract parts that play well together. We can organize and manage these parts independently which make updating and reviewing a lot more easier.

Out Auth layer is quite complex. It integrates both ABAC and RBAC while not explicitly differentiating between those. It may be a a good idea to break the auth layer further but at the moment, I don’t see a good reason to do that. This simple abstraction should work for a majority of use-cases while keeping things managable.