UI: Deck: Projects list page

src/Vervis/Foundation.hs

@@ -938,6 +938,8 @@ instance YesodBreadcrumbs App where
         DeckInviteR d  -> ("Invite", Just $ DeckR d)
         DeckRemoveR _ _ -> ("", Nothing)
 
+        DeckProjectsR d -> ("Projects", Just $ DeckR d)
+
         TicketR d t            -> ("#" <> keyHashidText t, Just $ DeckTicketsR d)
         TicketDiscussionR d t  -> ("Discussion", Just $ TicketR d t)
         TicketEventsR d t      -> ("Events", Just $ TicketR d t)

src/Vervis/Handler/Deck.hs

@@ -40,6 +40,7 @@ module Vervis.Handler.Deck
     , getDeckInviteR
     , postDeckInviteR
     , postDeckRemoveR
+    , getDeckProjectsR
 
 
 
@@ -69,7 +70,7 @@ import Data.Bitraversable
 import Data.ByteString (ByteString)
 import Data.Default.Class
 import Data.Foldable
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Data.Text (Text)
 import Data.Time.Clock
 import Data.Traversable
@@ -529,6 +530,39 @@ postDeckRemoveR deckHash ctID = do
             setMessage "Remove sent"
     redirect $ DeckCollabsR deckHash
 
+getDeckProjectsR :: KeyHashid Deck -> Handler Html
+getDeckProjectsR deckHash = do
+    deckID <- decodeKeyHashid404 deckHash
+    (deck, actor, stems) <- runDB $ do
+        deck <- get404 deckID
+        actor <- getJust $ deckActor deck
+        stems <-
+            E.select $ E.from $ \ (ident `E.InnerJoin` stem `E.InnerJoin` accept `E.LeftOuterJoin` deleg) -> do
+                E.on $ E.just (accept E.^. StemComponentAcceptId) E.==. deleg E.?. StemDelegateLocalStem
+                E.on $ stem E.^. StemId E.==. accept E.^. StemComponentAcceptStem
+                E.on $ ident E.^. StemIdentDeckStem E.==. stem E.^. StemId
+                E.where_ $ ident E.^. StemIdentDeckDeck E.==. E.val deckID
+                return (stem, deleg)
+        stems' <- for stems $ \ (Entity stemID stem, deleg) -> do
+            j <- getStemProject stemID
+            projectView <-
+                bitraverse
+                    (\ projectID -> do
+                        actorID <- projectActor <$> getJust projectID
+                        actor <- getJust actorID
+                        return (projectID, actor)
+                    )
+                    (\ remoteActorID -> do
+                        remoteActor <- getJust remoteActorID
+                        remoteObject <- getJust $ remoteActorIdent remoteActor
+                        inztance <- getJust $ remoteObjectInstance remoteObject
+                        return (inztance, remoteObject, remoteActor)
+                    )
+                    j
+            return (projectView, stemRole stem, isJust deleg)
+        return (deck, actor, stems')
+    defaultLayout $(widgetFile "deck/projects")
+
 
 
 

src/Vervis/Persist/Collab.hs

@@ -17,6 +17,7 @@ module Vervis.Persist.Collab
     ( getCollabTopic
     , getCollabTopic'
     , getStemIdent
+    , getStemProject
     , getGrantRecip
     , getComponentE
     , getTopicGrants
@@ -121,6 +122,17 @@ getStemIdent stemID = do
             (Nothing, Nothing, Just l) -> ComponentLoom $ stemIdentLoomLoom l
             _ -> error "Found Stem with multiple idents"
 
+getStemProject
+    :: MonadIO m
+    => StemId
+    -> ReaderT SqlBackend m (Either ProjectId RemoteActorId)
+getStemProject stemID =
+    requireEitherAlt
+        (fmap stemProjectLocalProject <$> getValBy (UniqueStemProjectLocal stemID))
+        (fmap stemProjectRemoteProject <$> getValBy (UniqueStemProjectRemote stemID))
+        "Found Stem without project"
+        "Found Stem with multiple projects"
+
 getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e
 
 getComponentE (ComponentRepo k) e = ComponentRepo <$> getEntityE k e

src/Vervis/Widget/Tracker.hs

@@ -18,6 +18,7 @@ module Vervis.Widget.Tracker
     , loomNavW
     , projectNavW
     , componentLinkFedW
+    , projectLinkFedW
     )
 where
 
@@ -83,3 +84,23 @@ componentLinkFedW (Right (inztance, object, actor)) =
     |]
     where
     uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)
+
+projectLinkFedW
+    :: Either (ProjectId, Actor) (Instance, RemoteObject, RemoteActor)
+    -> Widget
+projectLinkFedW (Left (j, actor)) = do
+    h <- encodeKeyHashid j
+    [whamlet|
+        <a href=@{ProjectR h}>
+          \$#{keyHashidText h} #{actorName actor}
+    |]
+projectLinkFedW (Right (inztance, object, actor)) =
+    [whamlet|
+        <a href="#{renderObjURI uActor}">
+          $maybe name <- remoteActorName actor
+            #{name}
+          $nothing
+            #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object}
+    |]
+    where
+    uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object)

templates/deck/projects.hamlet

@@ -0,0 +1,33 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 2019, 2022, 2023 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/>.
+
+^{deckNavW (Entity deckID deck) actor}
+
+<h2>Collaborators
+
+<table>
+  <tr>
+    <th>Role
+    <th>Project
+    <th>Enabled
+  $forall (project, role, enabled) <- stems
+    <tr>
+      <td>#{show role}
+      <td>^{projectLinkFedW project}
+      <td>
+        $if enabled
+          [x]
+        $else
+          [_]
+$#    <td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}

templates/deck/widget/nav.hamlet

@@ -30,6 +30,10 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
   <span>
     <a href=@{DeckCollabsR deckHash}>
       [🤝 Collaborators]
+  <span>
+    <a href=@{DeckProjectsR deckHash}>
+      [🏗 Projects]
+    <a href=@{DeckR deckHash}>
   <span>
     <a href=@{DeckTicketsR deckHash}>
       [🐛 Tickets]

th/routes

@@ -223,6 +223,7 @@
 /decks/#DeckKeyHashid/collabs                     DeckCollabsR    GET
 /decks/#DeckKeyHashid/invite                      DeckInviteR     GET POST
 /decks/#DeckKeyHashid/remove/#CollabTopicDeckId   DeckRemoveR     POST
+/decks/#DeckKeyHashid/projects                    DeckProjectsR   GET
 
 ---- Ticket ------------------------------------------------------------------