Replace project role HTML flat list with an SVG diagram

src/Vervis/Handler/Role.hs

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

src/Vervis/Role.hs

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

templates/project/role/graph.hamlet

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