vervis/src/Vervis/Access.hs

{- This file is part of Vervis.
 -
 - Written in 2019 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

-- | In this module I'd like to collect all the operation access checks. When a
-- given user asks to perform a certain operation, do we accept the request and
-- perform the changes to our database etc.? The functions here should provide
-- the answer.
--
-- Vervis uses a role-based access control system (RBAC) with role inheritance.
-- In order to determine access to a given operation, conceptually the
-- following two steps happen:
--
--     (1) Determine the actor's role
--     (2) Determine whether that role has access to the operation
--
-- There are 3 mechanisms for assigning a role to actors:
--
--     (1) Local:
--         A given project or repo may keep a list of users on the same server.
--         to which they are assigning roles.
--     (2) Capability:
--         For users from other instances, we provide signed capability
--         documents when they get assigned a role, and we verify them when the
--         user requests to perform an operation. We keep a token for each
--         capability we grant, so that we can revoke it, and so that we can
--         have a list of remote project/repo members.
--     (3) Public:
--         If an actor doesn't have a role through one of the previous twp
--         methods, we may still assign a role to them using automatic
--         assignment. It's called _Public_ because it's generally meant for
--         assigning to the general public, people who aren't listed in our
--         role assignment lists, and to give public access to resources. A
--         project or repo may define a role to be assigned automatically
--         depending on the status of the actor. For example, assign a certain
--         role if it's a local logged-in user, or if it's an anonymous
--         not-logged-in client POSTing some operation, or if it's a remote
--         user from another instance, verified with a valid signature approved
--         by their server.
--
-- Conceptually, the default if none of these methods assign a role, is to
-- assume a "null role" i.e. a hypothetical role that can't access any
-- operations.
module Vervis.Access
    ( ObjectAccessStatus (..)
    , checkRepoAccess
    , checkProjectAccess
    )
where

import Prelude

import Control.Applicative ((<|>))
import Control.Monad.IO.Class
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Maybe (fromMaybe, isJust)
import Database.Persist.Class (getBy)
import Database.Persist.Sql (SqlBackend)
import Database.Persist.Types (Entity (..))

import Vervis.Model
import Vervis.Model.Ident
import Vervis.Model.Role
import Vervis.Query

data ObjectAccessStatus =
    NoSuchObject | ObjectAccessDenied | ObjectAccessAllowed
        deriving Eq

checkRepoAccess
    :: MonadIO m
    => Maybe PersonId
    -> RepoOperation
    -> ShrIdent
    -> RpIdent
    -> ReaderT SqlBackend m ObjectAccessStatus
checkRepoAccess mpid op shr rp = do
    mrid <- runMaybeT $ do
        Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
        Entity rid _repo <- MaybeT $ getBy $ UniqueRepo rp sid
        return rid
    case mrid of
        Nothing -> return NoSuchObject
        Just rid -> do
            mra <- runMaybeT $ do
                rlid <- do
                    case mpid of
                        Just pid ->
                                MaybeT (asCollab rid pid)
                            <|> MaybeT (asUser rid)
                            <|> MaybeT (asAnon rid)
                        Nothing -> MaybeT $ asAnon rid
                MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
            return $
                case mra of
                    Nothing -> ObjectAccessDenied
                    Just _  -> ObjectAccessAllowed
    where
    asCollab rid pid =
        fmap (repoCollabRole . entityVal) <$>
            getBy (UniqueRepoCollab rid pid)
    asUser rid =
        fmap (repoCollabUserRole . entityVal) <$>
            getBy (UniqueRepoCollabUser rid)
    asAnon rid =
        fmap (repoCollabAnonRole . entityVal) <$>
            getBy (UniqueRepoCollabAnon rid)
    roleHas role operation = getBy $ UniqueRepoAccess role operation
    ancestorHas = flip getRepoRoleAncestorWithOpQ

data PersonRole = Developer | User | Guest | RoleID ProjectRoleId

checkProjectAccess
    :: MonadIO m
    => Maybe PersonId
    -> ProjectOperation
    -> ShrIdent
    -> PrjIdent
    -> ReaderT SqlBackend m ObjectAccessStatus
checkProjectAccess mpid op shr prj = do
    mjid <- runMaybeT $ do
        Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
        Entity jid _project <- MaybeT $ getBy $ UniqueProject prj sid
        return jid
    case mjid of
        Nothing -> return NoSuchObject
        Just jid -> do
            role <- do
                case mpid of
                    Just pid -> fmap (fromMaybe User) $ runMaybeT
                        $   MaybeT (asCollab jid pid)
                        <|> MaybeT (asUser jid)
                        <|> MaybeT (asAnon jid)
                    Nothing -> fromMaybe Guest <$> asAnon jid
            status <$> hasAccess role op
    where
    asCollab jid pid =
        fmap (maybe Developer RoleID . projectCollabRole . entityVal) <$>
            getBy (UniqueProjectCollab jid pid)
    asUser jid =
        fmap (RoleID . projectCollabUserRole . entityVal) <$>
            getBy (UniqueProjectCollabUser jid)
    asAnon jid =
        fmap (RoleID . projectCollabAnonRole . entityVal) <$>
            getBy (UniqueProjectCollabAnon jid)
    roleHas role operation = getBy $ UniqueProjectAccess role operation
    ancestorHas = flip getProjectRoleAncestorWithOpQ
    userAccess ProjOpOpenTicket      = True
    userAccess ProjOpAcceptTicket    = False
    userAccess ProjOpCloseTicket     = False
    userAccess ProjOpReopenTicket    = False
    userAccess ProjOpRequestTicket   = True
    userAccess ProjOpClaimTicket     = False
    userAccess ProjOpUnclaimTicket   = True
    userAccess ProjOpAssignTicket    = False
    userAccess ProjOpUnassignTicket  = False
    userAccess ProjOpAddTicketDep    = False
    userAccess ProjOpRemoveTicketDep = False
    hasAccess Developer     _  = pure True
    hasAccess User          op = pure $ userAccess op
    hasAccess Guest         _  = pure False
    hasAccess (RoleID rlid) op =
        fmap isJust . runMaybeT $
            MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
    status True  = ObjectAccessAllowed
    status False = ObjectAccessDenied