Project role inheritance and graph queries with some raw SQL

config/models

@@ -60,6 +60,12 @@ RepoRole
 
     UniqueRepoRole sharer ident
 
+RepoRoleInherit
+    parent RepoRoleId
+    child  RepoRoleId
+
+    UniqueRepoRoleInherit parent child
+
 RepoAccess
     role RepoRoleId
     op   RepoOperation
@@ -93,6 +99,12 @@ ProjectCollab
 
     UniqueProjectCollab project person
 
+ProjectRoleInherit
+    parent ProjectRoleId
+    child  ProjectRoleId
+
+    UniqueProjectRoleInherit parent child
+
 -------------------------------------------------------------------------------
 -- Projects
 -------------------------------------------------------------------------------

src/Database/Persist/Local/RecursionDoc.hs

@@ -130,4 +130,31 @@
 -- Before you can use the graph approach you should define an instance of the
 -- 'PersistEntityGraph' class. That class creates a relation between the two
 -- entities (@Language@ and @LanguageOrigin@ in the example).
+--
+-- The queries in the graph approach conceptually run 2 steps.
+--
+-- In the first step, build a set of edge-node pairs. It contains all the
+-- relevant edges found, and the parent of child side of the edge, depending on
+-- the recursion direction. If you query for ancestors, the node is the
+-- parent-side of the edge. If you query for decendants, the node is the
+-- child-side of the edge.
+--
+-- In the second step, run a query on the resulting set of pairs. The functions
+-- take 2 separate lists of filters, one for the nodes and one for the edges,
+-- and apply both, i.e. they AND the filters. Mixing and ORing of node and edge
+-- filters is currently not supported because it requires complicating
+-- persistent's filters a bit (or adding something on top), but it's certainly
+-- possible to add that.
+--
+-- - The read operations return pairs after optional filtering and ordering.
+--   The default ordering depends on the backend.
+-- - The update operations take an update list for nodes and an update list for
+--   edges. If you want to update just nodes or just edges, pass an empty list.
+-- - The deletion operations take a 'GraphDeleteMode' parameter which specifies
+--   whether to delete just the selected edges, or also the nodes selected with
+--   them
+--
+-- Note that unlike in the forest approach, here the queries don't return the
+-- root node whose key is passed to them. If you want the record of the root,
+-- obtain it the usual way, using 'get'.
 module Database.Persist.Local.RecursionDoc () where

src/Database/Persist/Local/Sql.hs

@@ -0,0 +1,105 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 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/>.
+ -}
+
+module Database.Persist.Local.Sql
+    ( dummyFromField
+    , rawSqlWithGraph
+    )
+where
+
+import Prelude
+
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Reader (ReaderT, ask)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import Database.Persist
+import Database.Persist.Sql
+import Database.Persist.Sql.Util
+
+import qualified Data.Text as T (intercalate)
+
+import Database.Persist.Local.Class.PersistQueryForest
+import Database.Persist.Local.Sql.Orphan.Common
+
+dummyFromKey :: Key val -> Maybe val
+dummyFromKey _ = Nothing
+
+dummyFromField :: EntityField val t -> Maybe val
+dummyFromField _ = Nothing
+
+rawSqlWithGraph
+    :: ( RawSql a
+       , MonadIO m
+       , PersistEntity node
+       , PersistEntity edge
+       , SqlBackend ~ PersistEntityBackend node
+       , SqlBackend ~ PersistEntityBackend edge
+       )
+    => RecursionDirection
+    -> Key node
+    -> EntityField edge (Key node)
+    -> EntityField edge (Key node)
+    -> (DBName -> Text)
+    -> [PersistValue]
+    -> ReaderT SqlBackend m [a]
+rawSqlWithGraph dir root parent child sub vals = do
+    conn <- ask
+    let tNode = entityDef $ dummyFromKey root
+        tEdge = entityDef $ dummyFromField parent
+        temp = DBName "temp_hierarchy_cte"
+        dbname = connEscapeName conn
+        immediate =
+            case dir of
+                Ancestors  -> child ==. root
+                Decendants -> parent ==. root
+        cols = T.intercalate "," $ entityColumnNames tEdge conn
+        qcols name =
+            T.intercalate ", " $
+            map ((dbname name <>) . ("." <>)) $
+            entityColumnNames tEdge conn
+        sqlWith = mconcat
+            [ "WITH RECURSIVE "
+            , dbname temp
+            , " ("
+            , cols
+            , ") AS ( SELECT "
+                , cols
+                , " FROM "
+                , dbname $ entityDB tEdge
+                , filterClause False conn [immediate]
+            , " UNION SELECT "
+                , qcols $ entityDB tEdge
+                , " FROM "
+                , dbname $ entityDB tEdge
+                , ", "
+                , dbname temp
+                , " WHERE "
+                , dbname $ entityDB tEdge
+                , "."
+                , dbname $ fieldDB $ persistFieldDef $ case dir of
+                    Ancestors  -> child
+                    Decendants -> parent
+                , " = "
+                , dbname temp
+                , "."
+                , dbname $ fieldDB $ persistFieldDef $ case dir of
+                    Ancestors  -> parent
+                    Decendants -> child
+            , " ) "
+            ]
+        sql = sqlWith <> sub temp
+        vals' = toPersistValue root : vals
+    rawSql sql vals'

src/Vervis/Foundation.hs

@@ -36,6 +36,7 @@ import Vervis.Import.NoFoundation hiding (last)
 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
@@ -251,7 +252,9 @@ instance Yesod App where
                 Entity jid _j <- MaybeT $ getBy $ UniqueProject prj sid
                 Entity _cid c <- MaybeT $ getBy $ UniqueProjectCollab jid pid
                 let role = projectCollabRole c
-                MaybeT $ getBy $ UniqueProjectAccess role op
+                    roleHas = getBy $ UniqueProjectAccess role op
+                    ancestorHas = getProjectRoleAncestorWithOpQ op role
+                MaybeT roleHas <|> MaybeT ancestorHas
             return $ case ma of
                 Nothing ->
                     Unauthorized

src/Vervis/Query.hs

@@ -0,0 +1,86 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2016 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/>.
+ -}
+
+-- | DB actions for long, complicated or unsafe queries. All the non-trivial
+-- usage of raw SQL and so on goes into this module. Hopefully, this module
+-- helps identify patterns and commonly needed but missing tools, which can
+-- then be implemented and simplify the queries.
+module Vervis.Query
+    ( getProjectRoleAncestorWithOpQ
+    )
+where
+
+import Prelude
+
+import Control.Monad.IO.Class (MonadIO)
+import Control.Monad.Trans.Reader (ReaderT, ask)
+import Data.Maybe (listToMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text)
+import Database.Persist
+import Database.Persist.Sql
+import Database.Persist.Sql.Util
+
+import qualified Data.Text as T (intercalate)
+
+import Database.Persist.Local.Class.PersistQueryForest
+import Database.Persist.Local.Sql
+import Vervis.Model
+import Vervis.Model.Role
+
+-- utils to place in a common module:
+--
+-- * dummyFrom*
+-- * eEdge ^* ProjectRoleInheritParent
+-- * x ^* y ==* z ^* w
+
+-- | Given a project role and a project operation, find an ancestor role which
+-- has access to the operation.
+getProjectRoleAncestorWithOpQ
+    :: MonadIO m
+    => ProjectOperation
+    -> ProjectRoleId
+    -> ReaderT SqlBackend m (Maybe (Entity ProjectAccess))
+getProjectRoleAncestorWithOpQ op role = do
+    conn <- ask
+    let dbname = connEscapeName conn
+        eAcc = entityDef $ dummyFromField ProjectAccessId
+        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
+            ProjectRoleInheritParent
+            ProjectRoleInheritChild
+            (\ temp -> mconcat
+                [ "SELECT ", qcols
+                , " FROM ", dbname temp, ", ", tAcc
+                , " WHERE "
+                , dbname temp, ".", field ProjectRoleInheritParent
+                , " = "
+                , tAcc, ".", field ProjectAccessRole
+                , " AND "
+                , tAcc, ".", field ProjectAccessOp
+                , " = ? "
+                , " LIMIT TO 1"
+                ]
+            )
+            [toPersistValue op]

vervis.cabal

@@ -66,6 +66,7 @@ library
                        Database.Persist.Sql.Local
                        Database.Persist.Local.Class.PersistQueryForest
                        Database.Persist.Local.RecursionDoc
+                       Database.Persist.Local.Sql
                        Database.Persist.Local.Sql.Orphan.Common
                        Database.Persist.Local.Sql.Orphan.PersistQueryForest
                        Development.DarcsRev
@@ -129,6 +130,7 @@ library
                        Vervis.Model.Role
                        Vervis.Paginate
                        Vervis.Path
+                       Vervis.Query
                        Vervis.Readme
                        Vervis.Render
                        Vervis.Settings