Servant Authorization Example using Type Level Params

[DeepakKapiswe]

Can someone please explain or give a beginner friendly minimal example of Authorization implementation using 2nd Approach of the comment :

you would state that you require 1/ an authenticated user 2/ with at least some given role/authorization level. So in servant-auth it would be something like:
data Role = NormalUser | Moderator | Administrator
data User (minRole :: Role) = User { ... }
-- let's say we're using JWT
type API = Auth '[JWT] (User Administrator) :> Get '[JSON] Int
and then the auth check would only go through if the user is confirmed to be an admin. The main downside is that you have to write the authorization logic in the "auth check". Another one is that this type level param to User can be annoying/awkward to work with.

described here #73 (comment)

[alpmestan]

@DeepakKapiswe and I talked about this on IRC and it seemed like my short description there was a bit too short.

Let's say we're going to have the following User values traveling around (encoded) in JWT tokens:

data Role = Normal | Moderator | Admin
  deriving Ord
data User = User { username :: String, role :: Role }

The second approach is about adding a type parameter to User, of kind Role, so that a User r value would be guaranteed to have a role field such that compare role r /= LT, i.e such that the value of the role field would be greater than the one that tags the User value. So if we have a User Moderator, we're sure that the role field is either Moderator or Admin. So we can do (separate type to be able to switch between one and the other easily):

newtype UserAtLeast (r :: Role) = UAL User

A key function we will need:

userAtLeast :: User -> Maybe (UserAtLeast r)

But we need to constrain the r, since we will need to convert it to a (value-level) Role value. Let's use the following typeclass.

class KnownRole (r :: Role) where
  knownRole :: Proxy r -> Role

instance KnownRole 'Normal where
  knownRole _ = Normal

instance KnownRole 'Moderator where
  knownRole _ = Moderator

instance KnownRole 'Admin where
  knownRole _ = Admin

Now we should be able to implement userAtLeast.

-- requires {-# LANGUAGE ScopedTypeVariables #-}
userAtLeast :: forall (r :: Role). KnownRole r => User -> Maybe (UserAtLeast r)
userAtLeast usr
  | minRole <= role usr = Just (UAL usr)
  | otherwise = Nothing

  where minRole = knownRole (Proxy :: Proxy r)

Now, given a User value, a call to userAtLeast will return Nothing or a validated user depending on the choice of r.

You just have to use servant-auth's Auth combinator with UserAtLeast 'Normal/UserAtLeast 'Moderator/UserAtLeast 'Admin as the user type to make use of this. This requires you to call userAtLeast somewhere, e.g in the FromJWT instance for UserAtLeast, which could piggyback on one that you'd derive for User using Generic, but would additionally perform the userAtLeast check.

With servant's general auth machinery, since you're the one constructing the auth check (unlike with servant-auth), you could stick a call to userAtLeast in the auth check's implementation at the end.

Note: it's not strictly necessary to have UserAtLeast and User be separate types. Most of what I talked about still holds if we have data UserAtLeast (minRole :: Role) = User { username :: String, role :: Role } and type User = UserAtLeast 'Normal.

If someone has the interest and the time, it'd be great to turn all those comments into a cookbook that discusses authorization/roles at length, illustrating both approaches ideally.

[DeepakKapiswe]

Thanks a lot @alpmestan for your detailed and swift answer, really helpful.
here I'm attaching my concrete minimal implementation based on your advice, for others if they find it useful,
It uses servant-auth JWT token for Auth and Role Based Authorization :

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric  #-}
{-# LANGUAGE KindSignatures  #-}
{-# LANGUAGE DataKinds  #-}
{-# LANGUAGE ScopedTypeVariables #-}


module Types where
    
import Data.Aeson
import Database.PostgreSQL.Simple (FromRow, ToRow)
import GHC.Generics (Generic)
import Servant.Auth.Server
import Data.Proxy
import Data.Text

-- client facing User Info
data UserAuth = UserAuth {
    userId   :: String
  , password :: String
} deriving (Show, Eq, Generic, FromRow, ToRow)

instance FromJSON UserAuth
instance ToJSON UserAuth

data Role = Normal | Moderator | Admin
  deriving (Eq, Show, Ord, Generic)

instance FromJSON Role
instance ToJSON Role

class KnownRole (r :: Role) where
  knownRole :: Proxy r -> Role

instance KnownRole 'Normal where
  knownRole _ = Normal

instance KnownRole 'Moderator where
  knownRole _ = Moderator

instance KnownRole 'Admin where
  knownRole _ = Admin

data User = User { username :: String, role :: Role }
  deriving (Eq, Show, Generic)

instance FromJSON User
instance ToJSON User  
instance FromJWT User
instance ToJWT User  

newtype UserAtLeast (r :: Role) = UAL User
  deriving (Eq, Show, Generic)

userAtLeast :: forall (r :: Role). KnownRole r => User -> Maybe (UserAtLeast r)
userAtLeast usr
  | minRole <= role usr = Just (UAL usr)
  | otherwise = Nothing

  where minRole = knownRole (Proxy :: Proxy r)

instance FromJSON (UserAtLeast a)
instance ToJSON (UserAtLeast a)

-- use of userAtLeast for deciding whether a user 
-- have enough permissions in decodeJWT 
instance ToJWT (UserAtLeast a)
instance KnownRole a => FromJWT (UserAtLeast a) where
  decodeJWT val = case (decodeJWT val :: Either Text User) of 
    Left x -> Left x
    Right usr -> case (userAtLeast usr :: Maybe (UserAtLeast a)) of
      Nothing -> Left $ pack "Not Enough Permission"
      Just (UAL u) -> Right (UAL u)

-- API change your API to include Authorization roles types
type API auths =
  "api" :> 
    ((Auth auths (UserAtLeast 'Moderator) :> ProtectedAPIForModerator)
     (Auth auths (UserAtLeast 'Admin) :> ProtectedAPIForAdmin)
     (Auth auths (UserAtLeast 'Normal) :> ProtectedAPIForNormal)
    :<|> UnProtectedAPI)


-- server code
-- here is how I implement AuthCheck
checkCreds :: CookieSettings
           -> JWTSettings
           -> UserAuth
           -> Handler (Headers '[ Header "Set-Cookie" SetCookie
                                , Header "Set-Cookie" SetCookie]
                               User)
checkCreds cookieSettings jwtSettings usr@(UserAuth name pass) = do
  let userRole = case pass of -- this should come from a db lookup
                   "admin" -> Admin
                   "m" -> Moderator
                   _ -> Normal 
  mApplyCookies <- liftIO $ acceptLogin cookieSettings jwtSettings (UAL (User name userRole))
  case mApplyCookies of
    Nothing           -> 
      throwError err401
    Just applyCookies ->
      return $ applyCookies (User name userRole)
checkCreds _ _ _ = do
  throwError err401

[DeepakKapiswe]

If someone wants to specify the permission on API not only based on ordering but specifically for particular user types / roles
then we can also have something like

class KnownUserRoles (rs :: [UserRole]) where
  knownUserRoles :: Proxy rs -> [UserRole]

instance KnownUserRoles '[] where
  knownUserRoles _ = []

instance (KnownUserRole r, KnownUserRoles rs) => KnownUserRoles ( r ': rs) where
  knownUserRoles _ = (knownUserRole (Proxy :: Proxy r)) : (knownUserRoles (Proxy :: Proxy rs))


newtype AllowedUserRoles (ur :: [UserRole]) = AllowedUser User
  deriving (Eq, Show, Generic)

isAllowedUserRole :: forall (uRoles :: [UserRole]). KnownUserRoles uRoles => User -> Maybe (AllowedUserRoles uRoles)
isAllowedUserRole usr
  | elem (uType usr) allowedUserRoles = Just (AllowedUser usr)
  | otherwise = Nothing
  where allowedUserRoles = knownUserRoles (Proxy :: Proxy uRoles)

and then we can write our API as:
Auth (AllowedUserRoles '[Normal, Admin]) :> ProtectedAPIForNormalAndAdminUsers