Project role inheritance and graph queries with some raw SQL
This commit is contained in:
parent
5e2e7f806a
commit
5340cf23f1
6 changed files with 236 additions and 1 deletions
|
@ -60,6 +60,12 @@ RepoRole
|
||||||
|
|
||||||
UniqueRepoRole sharer ident
|
UniqueRepoRole sharer ident
|
||||||
|
|
||||||
|
RepoRoleInherit
|
||||||
|
parent RepoRoleId
|
||||||
|
child RepoRoleId
|
||||||
|
|
||||||
|
UniqueRepoRoleInherit parent child
|
||||||
|
|
||||||
RepoAccess
|
RepoAccess
|
||||||
role RepoRoleId
|
role RepoRoleId
|
||||||
op RepoOperation
|
op RepoOperation
|
||||||
|
@ -93,6 +99,12 @@ ProjectCollab
|
||||||
|
|
||||||
UniqueProjectCollab project person
|
UniqueProjectCollab project person
|
||||||
|
|
||||||
|
ProjectRoleInherit
|
||||||
|
parent ProjectRoleId
|
||||||
|
child ProjectRoleId
|
||||||
|
|
||||||
|
UniqueProjectRoleInherit parent child
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- Projects
|
-- Projects
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
|
|
|
@ -130,4 +130,31 @@
|
||||||
-- Before you can use the graph approach you should define an instance of the
|
-- Before you can use the graph approach you should define an instance of the
|
||||||
-- 'PersistEntityGraph' class. That class creates a relation between the two
|
-- 'PersistEntityGraph' class. That class creates a relation between the two
|
||||||
-- entities (@Language@ and @LanguageOrigin@ in the example).
|
-- 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
|
module Database.Persist.Local.RecursionDoc () where
|
||||||
|
|
105
src/Database/Persist/Local/Sql.hs
Normal file
105
src/Database/Persist/Local/Sql.hs
Normal file
|
@ -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'
|
|
@ -36,6 +36,7 @@ import Vervis.Import.NoFoundation hiding (last)
|
||||||
import Vervis.Model.Group
|
import Vervis.Model.Group
|
||||||
import Vervis.Model.Ident
|
import Vervis.Model.Ident
|
||||||
import Vervis.Model.Role
|
import Vervis.Model.Role
|
||||||
|
import Vervis.Query (getProjectRoleAncestorWithOpQ)
|
||||||
import Vervis.Widget (breadcrumbsW, revisionW)
|
import Vervis.Widget (breadcrumbsW, revisionW)
|
||||||
|
|
||||||
-- | The foundation datatype for your application. This can be a good place to
|
-- | 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 jid _j <- MaybeT $ getBy $ UniqueProject prj sid
|
||||||
Entity _cid c <- MaybeT $ getBy $ UniqueProjectCollab jid pid
|
Entity _cid c <- MaybeT $ getBy $ UniqueProjectCollab jid pid
|
||||||
let role = projectCollabRole c
|
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
|
return $ case ma of
|
||||||
Nothing ->
|
Nothing ->
|
||||||
Unauthorized
|
Unauthorized
|
||||||
|
|
86
src/Vervis/Query.hs
Normal file
86
src/Vervis/Query.hs
Normal file
|
@ -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]
|
|
@ -66,6 +66,7 @@ library
|
||||||
Database.Persist.Sql.Local
|
Database.Persist.Sql.Local
|
||||||
Database.Persist.Local.Class.PersistQueryForest
|
Database.Persist.Local.Class.PersistQueryForest
|
||||||
Database.Persist.Local.RecursionDoc
|
Database.Persist.Local.RecursionDoc
|
||||||
|
Database.Persist.Local.Sql
|
||||||
Database.Persist.Local.Sql.Orphan.Common
|
Database.Persist.Local.Sql.Orphan.Common
|
||||||
Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
Database.Persist.Local.Sql.Orphan.PersistQueryForest
|
||||||
Development.DarcsRev
|
Development.DarcsRev
|
||||||
|
@ -129,6 +130,7 @@ library
|
||||||
Vervis.Model.Role
|
Vervis.Model.Role
|
||||||
Vervis.Paginate
|
Vervis.Paginate
|
||||||
Vervis.Path
|
Vervis.Path
|
||||||
|
Vervis.Query
|
||||||
Vervis.Readme
|
Vervis.Readme
|
||||||
Vervis.Render
|
Vervis.Render
|
||||||
Vervis.Settings
|
Vervis.Settings
|
||||||
|
|
Loading…
Reference in a new issue