From fe6f95d4973ddd19092ba1ca9011ae6bf1cff300 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 2 Nov 2023 14:48:22 +0200 Subject: [PATCH] UI: Deck: Projects list page --- src/Vervis/Foundation.hs | 2 ++ src/Vervis/Handler/Deck.hs | 36 +++++++++++++++++++++++++++++++- src/Vervis/Persist/Collab.hs | 12 +++++++++++ src/Vervis/Widget/Tracker.hs | 21 +++++++++++++++++++ templates/deck/projects.hamlet | 33 +++++++++++++++++++++++++++++ templates/deck/widget/nav.hamlet | 4 ++++ th/routes | 1 + 7 files changed, 108 insertions(+), 1 deletion(-) create mode 100644 templates/deck/projects.hamlet diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 7814577..914b357 100644 --- a/src/Vervis/Foundation.hs +++ b/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) diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index d6ffc51..c141c0a 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/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") + diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index cb58b8e..5506727 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/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 diff --git a/src/Vervis/Widget/Tracker.hs b/src/Vervis/Widget/Tracker.hs index 02374a9..7acf220 100644 --- a/src/Vervis/Widget/Tracker.hs +++ b/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| + + \$#{keyHashidText h} #{actorName actor} + |] +projectLinkFedW (Right (inztance, object, actor)) = + [whamlet| + + $maybe name <- remoteActorName actor + #{name} + $nothing + #{renderAuthority $ instanceHost inztance}#{localUriPath $ remoteObjectIdent object} + |] + where + uActor = ObjURI (instanceHost inztance) (remoteObjectIdent object) diff --git a/templates/deck/projects.hamlet b/templates/deck/projects.hamlet new file mode 100644 index 0000000..436f1d9 --- /dev/null +++ b/templates/deck/projects.hamlet @@ -0,0 +1,33 @@ +$# This file is part of Vervis. +$# +$# Written in 2016, 2019, 2022, 2023 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 +$# . + +^{deckNavW (Entity deckID deck) actor} + +

Collaborators + + + + +
Role + Project + Enabled + $forall (project, role, enabled) <- stems +
#{show role} + ^{projectLinkFedW project} + + $if enabled + [x] + $else + [_] +$# ^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)} diff --git a/templates/deck/widget/nav.hamlet b/templates/deck/widget/nav.hamlet index dcc3ad2..37fedf2 100644 --- a/templates/deck/widget/nav.hamlet +++ b/templates/deck/widget/nav.hamlet @@ -30,6 +30,10 @@ $# . [🤝 Collaborators] + + + [🏗 Projects] + [🐛 Tickets] diff --git a/th/routes b/th/routes index b5c81e7..58d55f1 100644 --- a/th/routes +++ b/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 ------------------------------------------------------------------