forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Replace project role HTML flat list with an SVG diagram

Browse source
This commit is contained in:
fr33domlover 2016-07-02 09:45:29 +00:00
parent 1191a3c5cd
commit 13afd17a40
3 changed files with 22 additions and 17 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
src/Vervis/Handler/Role.hs
View file

@ -50,7 +50,9 @@ import Vervis.Form.Role
import Vervis.Foundation import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident (ShrIdent, RlIdent, rl2text) import Vervis.Model.Ident (ShrIdent, RlIdent, rl2text)
import Vervis.Role
import Vervis.Settings (widgetFile) import Vervis.Settings (widgetFile)
import Vervis.Widget.Role
getRepoRolesR :: ShrIdent -> Handler Html getRepoRolesR :: ShrIdent -> Handler Html
getRepoRolesR shr = do getRepoRolesR shr = do
@ -151,10 +153,13 @@ getRepoRoleOpNewR shr rl = do
getProjectRolesR :: ShrIdent -> Handler Html getProjectRolesR :: ShrIdent -> Handler Html
getProjectRolesR shr = do getProjectRolesR shr = do
roles <- runDB $ do --roles <- runDB $ do
Entity sid _ <- getBy404 $ UniqueSharer shr -- Entity sid _ <- getBy404 $ UniqueSharer shr
selectList [ProjectRoleSharer ==. sid] [] -- selectList [ProjectRoleSharer ==. sid] []
defaultLayout $(widgetFile "project/role/list") graph <- runDB $ do
Entity sid _s <- getBy404 $ UniqueSharer shr
getProjectRoleGraph sid
defaultLayout $(widgetFile "project/role/graph")
postProjectRolesR :: ShrIdent -> Handler Html postProjectRolesR :: ShrIdent -> Handler Html
postProjectRolesR shr = do postProjectRolesR shr = do

14
src/Vervis/Role.hs
View file

@ -35,10 +35,9 @@ import Vervis.Foundation
import Vervis.Model import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
getRepoRoleGraph :: AppDB SharerId -> Handler (Gr RlIdent ()) getRepoRoleGraph :: SharerId -> AppDB (Gr RlIdent ())
getRepoRoleGraph getsid = do getRepoRoleGraph sid = do
(roles, inhs) <- runDB $ do (roles, inhs) <- do
sid <- getsid
rrs <- P.selectList [RepoRoleSharer P.==. sid] [] rrs <- P.selectList [RepoRoleSharer P.==. sid] []
rrhs <- select $ from $ \ (rr `InnerJoin` rrh) -> do rrhs <- select $ from $ \ (rr `InnerJoin` rrh) -> do
on $ rr ^. RepoRoleId ==. rrh ^. RepoRoleInheritParent on $ rr ^. RepoRoleId ==. rrh ^. RepoRoleInheritParent
@ -62,10 +61,9 @@ getRepoRoleGraph getsid = do
inhs inhs
return $ mkGraph nodes edges return $ mkGraph nodes edges
getProjectRoleGraph :: AppDB SharerId -> Handler (Gr RlIdent ()) getProjectRoleGraph :: SharerId -> AppDB (Gr RlIdent ())
getProjectRoleGraph getsid = do getProjectRoleGraph sid = do
(roles, inhs) <- runDB $ do (roles, inhs) <- do
sid <- getsid
prs <- P.selectList [ProjectRoleSharer P.==. sid] [] prs <- P.selectList [ProjectRoleSharer P.==. sid] []
prhs <- select $ from $ \ (pr `InnerJoin` prh) -> do prhs <- select $ from $ \ (pr `InnerJoin` prh) -> do
on $ pr ^. ProjectRoleId ==. prh ^. ProjectRoleInheritParent on $ pr ^. ProjectRoleId ==. prh ^. ProjectRoleInheritParent

12
templates/project/role/list.hamlet → templates/project/role/graph.hamlet
View file

@ -15,8 +15,10 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
<p> <p>
<a href=@{ProjectRoleNewR shr}>New… <a href=@{ProjectRoleNewR shr}>New…
<ul> ^{projectRoleGraphW shr graph}
$forall Entity _rid role <- roles
<li> $#<ul>
<a href=@{ProjectRoleR shr $ projectRoleIdent role}> $# $forall Entity _rid role <- roles
#{rl2text $ projectRoleIdent role} $# <li>
$# <a href=@{ProjectRoleR shr $ projectRoleIdent role}>
$# #{rl2text $ projectRoleIdent role}