diff --git a/config/models b/config/models index d14d0d4..4035f5f 100644 --- a/config/models +++ b/config/models @@ -86,6 +86,12 @@ ProjectRole UniqueProjectRole sharer ident +ProjectRoleInherit + parent ProjectRoleId + child ProjectRoleId + + UniqueProjectRoleInherit parent child + ProjectAccess role ProjectRoleId op ProjectOperation @@ -99,12 +105,6 @@ ProjectCollab UniqueProjectCollab project person -ProjectRoleInherit - parent ProjectRoleId - child ProjectRoleId - - UniqueProjectRoleInherit parent child - ------------------------------------------------------------------------------- -- Projects ------------------------------------------------------------------------------- diff --git a/src/Vervis/Model.hs b/src/Vervis/Model.hs index 5e04d66..255e114 100644 --- a/src/Vervis/Model.hs +++ b/src/Vervis/Model.hs @@ -43,3 +43,13 @@ instance HashDBUser Person where instance Hashable MessageId where hashWithSalt salt = hashWithSalt salt . fromSqlKey hash = hash . fromSqlKey + +-- "Vervis.Role" uses a 'HashMap' where the key type is 'RepoRoleId' +instance Hashable RepoRoleId where + hashWithSalt salt = hashWithSalt salt . fromSqlKey + hash = hash . fromSqlKey + +-- "Vervis.Role" uses a 'HashMap' where the key type is 'ProjectRoleId' +instance Hashable ProjectRoleId where + hashWithSalt salt = hashWithSalt salt . fromSqlKey + hash = hash . fromSqlKey diff --git a/src/Vervis/Role.hs b/src/Vervis/Role.hs new file mode 100644 index 0000000..b08dfc6 --- /dev/null +++ b/src/Vervis/Role.hs @@ -0,0 +1,90 @@ +{- 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 Vervis.Role + ( getRepoRoleGraph + , getProjectRoleGraph + ) +where + +import Prelude + +import Control.Arrow (second, (&&&), (***)) +import Data.Graph.Inductive.Graph (mkGraph) +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Tuple (swap) +import Database.Esqueleto +import Yesod.Persist.Core (runDB) + +import qualified Data.HashMap.Lazy as M (fromList, lookup) +import qualified Database.Persist as P + +import Vervis.Foundation +import Vervis.Model +import Vervis.Model.Ident + +getRepoRoleGraph :: AppDB SharerId -> Handler (Gr RlIdent ()) +getRepoRoleGraph getsid = do + (roles, inhs) <- runDB $ do + sid <- getsid + rrs <- P.selectList [RepoRoleSharer P.==. sid] [] + rrhs <- select $ from $ \ (rr `InnerJoin` rrh) -> do + on $ rr ^. RepoRoleId ==. rrh ^. RepoRoleInheritParent + where_ $ rr ^. RepoRoleSharer ==. val sid + return rrh + return (rrs, rrhs) + let numbered = zip [1..] roles + nodes = map (second $ repoRoleIdent . entityVal) numbered + nodeMap = M.fromList $ map (swap . second entityKey) numbered + rridToNode rrid = + case M.lookup rrid nodeMap of + Nothing -> error "Role graph: Node not found in node map" + Just n -> n + edges = + map + ( (\ (c, p) -> (c, p, ())) + . (rridToNode *** rridToNode) + . (repoRoleInheritChild &&& repoRoleInheritParent) + . entityVal + ) + inhs + return $ mkGraph nodes edges + +getProjectRoleGraph :: AppDB SharerId -> Handler (Gr RlIdent ()) +getProjectRoleGraph getsid = do + (roles, inhs) <- runDB $ do + sid <- getsid + prs <- P.selectList [ProjectRoleSharer P.==. sid] [] + prhs <- select $ from $ \ (pr `InnerJoin` prh) -> do + on $ pr ^. ProjectRoleId ==. prh ^. ProjectRoleInheritParent + where_ $ pr ^. ProjectRoleSharer ==. val sid + return prh + return (prs, prhs) + let numbered = zip [1..] roles + nodes = map (second $ projectRoleIdent . entityVal) numbered + nodeMap = M.fromList $ map (swap . second entityKey) numbered + pridToNode prid = + case M.lookup prid nodeMap of + Nothing -> error "Role graph: Node not found in node map" + Just n -> n + edges = + map + ( (\ (c, p) -> (c, p, ())) + . (pridToNode *** pridToNode) + . (projectRoleInheritChild &&& projectRoleInheritParent) + . entityVal + ) + inhs + return $ mkGraph nodes edges diff --git a/vervis.cabal b/vervis.cabal index d8d4f3e..ac256c3 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -135,6 +135,7 @@ library Vervis.Query Vervis.Readme Vervis.Render + Vervis.Role Vervis.Settings Vervis.Settings.StaticFiles Vervis.SourceTree