Determine operation access in Vervis.Access, reuse it everywhere it's needed

src/Vervis/Access.hs

@@ -0,0 +1,161 @@
+{- 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 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
+
+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
+            mpa <- runMaybeT $ do
+                rlid <- do
+                    case mpid of
+                        Just pid ->
+                                MaybeT (asCollab jid pid)
+                            <|> MaybeT (asUser jid)
+                            <|> MaybeT (asAnon jid)
+                        Nothing -> MaybeT $ asAnon jid
+                MaybeT (roleHas rlid op) <|> MaybeT (ancestorHas rlid op)
+            return $
+                case mpa of
+                    Nothing -> ObjectAccessDenied
+                    Just _  -> ObjectAccessAllowed
+    where
+    asCollab jid pid =
+        fmap (projectCollabRole . entityVal) <$>
+            getBy (UniqueProjectCollab jid pid)
+    asUser jid =
+        fmap (projectCollabUserRole . entityVal) <$>
+            getBy (UniqueProjectCollabUser jid)
+    asAnon jid =
+        fmap (projectCollabAnonRole . entityVal) <$>
+            getBy (UniqueProjectCollabAnon jid)
+    roleHas role operation = getBy $ UniqueProjectAccess role operation
+    ancestorHas = flip getProjectRoleAncestorWithOpQ

src/Vervis/Foundation.hs

@@ -60,12 +60,12 @@ import Web.ActivityPub
 import Text.Email.Local
 import Text.Jasmine.Local (discardm)
 
+import Vervis.Access
 import Vervis.ActorKey (ActorKey)
 import Vervis.Import.NoFoundation hiding (Handler, Day, last, init, logWarn)
 import Vervis.Model.Group
 import Vervis.Model.Ident
 import Vervis.Model.Role
-import Vervis.Query (getProjectRoleAncestorWithOpQ)
 import Vervis.Widget (breadcrumbsW, revisionW)
 
 -- | The foundation datatype for your application. This can be a good place to
@@ -365,27 +365,15 @@ instance Yesod App where
 
         projOp
             :: ProjectOperation -> ShrIdent -> PrjIdent -> Handler AuthResult
-        projOp op shr prj = personAnd $ \ (Entity pid _p) -> do
-            ma <- runDB $ runMaybeT $ do
-                Entity sid _s <- MaybeT $ getBy $ UniqueSharer shr
-                Entity jid _j <- MaybeT $ getBy $ UniqueProject prj sid
-                let asCollab = do
-                        Entity _cid c <-
-                            MaybeT $ getBy $ UniqueProjectCollab jid pid
-                        return $ projectCollabRole c
-                    asUser = do
-                        Entity _cuid cu <-
-                            MaybeT $ getBy $ UniqueProjectCollabUser jid
-                        return $ projectCollabUserRole cu
-                role <- asCollab <|> asUser
-                let roleHas = getBy $ UniqueProjectAccess role op
-                    ancestorHas = getProjectRoleAncestorWithOpQ op role
-                MaybeT roleHas <|> MaybeT ancestorHas
-            return $ case ma of
-                Nothing ->
-                    Unauthorized
-                    "You need a project role with that operation enabled"
-                Just _  -> Authorized
+        projOp op shr prj = do
+            mpid <- maybeAuthId
+            oas <- runDB $ checkProjectAccess mpid op shr prj
+            return $
+                case oas of
+                    ObjectAccessAllowed -> Authorized
+                    _ ->
+                        Unauthorized
+                        "You need a project role with that operation enabled"
 
     -- This function creates static content files in the static folder
     -- and names them based on a hash of their content. This allows

src/Vervis/Query.hs

@@ -18,7 +18,8 @@
 -- helps identify patterns and commonly needed but missing tools, which can
 -- then be implemented and simplify the queries.
 module Vervis.Query
-    ( getProjectRoleAncestorWithOpQ
+    ( getRepoRoleAncestorWithOpQ
+    , getProjectRoleAncestorWithOpQ
     )
 where
 
@@ -40,11 +41,44 @@ import Database.Persist.Graph.SQL
 import Vervis.Model
 import Vervis.Model.Role
 
--- utils to place in a common module:
---
--- * dummyFrom*
--- * eEdge ^* ProjectRoleInheritParent
--- * x ^* y ==* z ^* w
+-- | Given a repo role and a repo operation, find an ancestor role which
+-- has access to the operation.
+getRepoRoleAncestorWithOpQ
+    :: MonadIO m
+    => RepoOperation
+    -> RepoRoleId
+    -> ReaderT SqlBackend m (Maybe (Entity RepoAccess))
+getRepoRoleAncestorWithOpQ op role = do
+    conn <- ask
+    let dbname = connEscapeName conn
+        eAcc = entityDef $ dummyFromField RepoAccessId
+        tAcc = dbname $ entityDB eAcc
+        qcols =
+            T.intercalate ", " $
+            map ((tAcc <>) . ("." <>)) $
+            entityColumnNames eAcc conn
+        field :: PersistEntity record => EntityField record typ -> Text
+        field = dbname . fieldDB . persistFieldDef
+    listToMaybe <$>
+        rawSqlWithGraph
+            Ancestors
+            role
+            RepoRoleInheritParent
+            RepoRoleInheritChild
+            (\ temp -> mconcat
+                [ "SELECT ??"
+                , " FROM ", dbname temp, " INNER JOIN ", tAcc
+                , " ON "
+                , dbname temp, ".", field RepoRoleInheritParent
+                , " = "
+                , tAcc, ".", field RepoAccessRole
+                , " WHERE "
+                , tAcc, ".", field RepoAccessOp
+                , " = ?"
+                , " LIMIT 1"
+                ]
+            )
+            [toPersistValue op]
 
 -- | Given a project role and a project operation, find an ancestor role which
 -- has access to the operation.

src/Vervis/Ssh.hs

@@ -50,6 +50,7 @@ import System.Process (CreateProcess (..), StdStream (..), createProcess, proc)
 import qualified Data.Text as T
 import qualified Formatting as F
 
+import Vervis.Access
 import Vervis.Model
 import Vervis.Model.Ident
 import Vervis.Model.Role
@@ -232,18 +233,11 @@ whenGitRepoExists = whenRepoExists "Git" $ isRepo . fromString
 canPushTo :: ShrIdent -> RpIdent -> Channel Bool
 canPushTo shr rp = do
     pid <- authId <$> askAuthDetails
-    ma <- runChanDB $ runMaybeT $ do
-        Entity sid _sharer <- MaybeT $ getBy $ UniqueSharer shr
-        Entity rid _repo <- MaybeT $ getBy $ UniqueRepo rp sid
-        let asCollab = do
-                Entity _ c <- MaybeT $ getBy $ UniqueRepoCollab rid pid
-                return $ repoCollabRole c
-            asUser = do
-                Entity _ cu <- MaybeT $ getBy $ UniqueRepoCollabUser rid
-                return $ repoCollabUserRole cu
-        role <- asCollab <|> asUser
-        MaybeT $ getBy $ UniqueRepoAccess role RepoOpPush
-    return $ isJust ma
+    oas <- runChanDB $ checkRepoAccess (Just pid) RepoOpPush shr rp
+    return $
+        case oas of
+            ObjectAccessAllowed -> True
+            _                   -> False
 
 runAction :: FilePath -> Bool -> Action -> Channel ActionResult
 runAction repoDir _wantReply action =

vervis.cabal

@@ -89,6 +89,7 @@ library
                        Yesod.Paginate.Local
                        Yesod.SessionEntity
 
+                       Vervis.Access
                        Vervis.ActivityStreams
                        Vervis.ActorKey
                        Vervis.Application