From 5340cf23f17007626e51166bb311f3d2dd9e0f3d Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Fri, 17 Jun 2016 20:17:39 +0000 Subject: [PATCH] Project role inheritance and graph queries with some raw SQL --- config/models | 12 +++ src/Database/Persist/Local/RecursionDoc.hs | 27 ++++++ src/Database/Persist/Local/Sql.hs | 105 +++++++++++++++++++++ src/Vervis/Foundation.hs | 5 +- src/Vervis/Query.hs | 86 +++++++++++++++++ vervis.cabal | 2 + 6 files changed, 236 insertions(+), 1 deletion(-) create mode 100644 src/Database/Persist/Local/Sql.hs create mode 100644 src/Vervis/Query.hs diff --git a/config/models b/config/models index 4051d5f..d14d0d4 100644 --- a/config/models +++ b/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 ------------------------------------------------------------------------------- diff --git a/src/Database/Persist/Local/RecursionDoc.hs b/src/Database/Persist/Local/RecursionDoc.hs index 40c05ac..76185e1 100644 --- a/src/Database/Persist/Local/RecursionDoc.hs +++ b/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 diff --git a/src/Database/Persist/Local/Sql.hs b/src/Database/Persist/Local/Sql.hs new file mode 100644 index 0000000..a9feb24 --- /dev/null +++ b/src/Database/Persist/Local/Sql.hs @@ -0,0 +1,105 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +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' diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index a66f7c5..3217275 100644 --- a/src/Vervis/Foundation.hs +++ b/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 diff --git a/src/Vervis/Query.hs b/src/Vervis/Query.hs new file mode 100644 index 0000000..b726d6c --- /dev/null +++ b/src/Vervis/Query.hs @@ -0,0 +1,86 @@ +{- This file is part of Vervis. + - + - Written in 2016 by fr33domlover . + - + - ♡ 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 + - . + -} + +-- | 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] diff --git a/vervis.cabal b/vervis.cabal index 603762f..4f433d8 100644 --- a/vervis.cabal +++ b/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