diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 71cade3..6071b3b 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -957,6 +957,7 @@ instance YesodBreadcrumbs App where DeckProjectsR d -> ("Projects", Just $ DeckR d) DeckApproveCompR d c -> ("", Nothing) + DeckAddProjectR d -> ("", Nothing) TicketR d t -> ("#" <> keyHashidText t, Just $ DeckTicketsR d) TicketDiscussionR d t -> ("Discussion", Just $ TicketR d t) diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 4279130..be3d8ea 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -43,6 +43,7 @@ module Vervis.Handler.Deck , postDeckInviteR , postDeckRemoveR , getDeckProjectsR + , postDeckAddProjectR , postDeckApproveCompR @@ -69,6 +70,7 @@ import Control.Monad import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Data.Aeson +import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) import Data.Default.Class @@ -83,11 +85,13 @@ import Text.Blaze.Html (Html) import Yesod.Auth import Yesod.Core import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) +import Yesod.Form import Yesod.Form.Functions (runFormPost, runFormGet) import Yesod.Form.Types (FormResult (..)) import Yesod.Persist.Core (runDB, get404, getBy404) import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T import qualified Database.Esqueleto as E import Database.Persist.JSON @@ -110,6 +114,7 @@ import Yesod.Persist.Local import Vervis.Access import Vervis.API +import Vervis.Data.Actor import Vervis.Federation.Auth import Vervis.Federation.Discussion import Vervis.Federation.Offer @@ -176,12 +181,9 @@ getDeckR deckHash = do , AP.ticketTrackerTeam = Nothing , AP.ticketTrackerCollaborators = encodeRouteLocal $ DeckCollabsR deckHash + , AP.ticketTrackerProjects = + encodeRouteLocal $ DeckProjectsR deckHash } - followButton = - followW - (DeckFollowR deckHash) - (DeckUnfollowR deckHash) - (actorFollowers actor) provideHtmlAndAP deckAP $ redirect $ DeckTicketsR deckHash @@ -581,6 +583,12 @@ postDeckRemoveR deckHash collabID = do getDeckProjectsR :: KeyHashid Deck -> Handler Html getDeckProjectsR deckHash = do deckID <- decodeKeyHashid404 deckHash + mp <- maybeAuthId + haveAdmin <- fmap isJust $ runDB $ runMaybeT $ do + personID <- MaybeT $ pure mp + deck <- lift $ get404 deckID + MaybeT $ getCapability personID (Left $ deckResource deck) AP.RoleAdmin + ((_, widgetAP), enctypeAP) <- runFormPost addProjectForm (deck, actor, stems) <- runDB $ do deck <- get404 deckID actor <- getJust $ deckActor deck @@ -614,6 +622,53 @@ getDeckProjectsR deckHash = do return (deck, actor, stems') defaultLayout $(widgetFile "deck/projects") +addProjectForm = renderDivs $ + areq fedUriField "(URI) Project" Nothing + +postDeckAddProjectR :: KeyHashid Deck -> Handler () +postDeckAddProjectR deckHash = do + deckID <- decodeKeyHashid404 deckHash + uProject <- + runFormPostRedirect (DeckProjectsR deckHash) addProjectForm + + personEntity@(Entity personID person) <- requireAuth + personHash <- encodeKeyHashid personID + encodeRouteHome <- getEncodeRouteHome + + let uDeck = encodeRouteHome $ DeckR deckHash + + result <- runExceptT $ do + uCollection <- do + project <- do + u <- parseFedURIOld uProject + bitraverse parseLocalActorE pure u + case project of + Left la -> + encodeRouteHome . renderLocalActor <$> hashLocalActor la + Right (ObjURI h lu) -> do + manager <- asksSite appHttpManager + AP.ResourceWithCollections _ _ mluComponents _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu + luComponents <- fromMaybeE mluComponents "No components collection" + return $ ObjURI h luComponents + + (maybeSummary, audience, add) <- C.add personID uDeck uCollection AP.RoleAdmin + cap <- do + maybeItem <- lift $ runDB $ do + resourceID <- deckResource <$> get404 deckID + getCapability personID (Left resourceID) AP.RoleAdmin + fromMaybeE maybeItem "You need to be have Admin access to the Deck to add projects" + uCap <- lift $ renderActivityURI cap + (localRecips, remoteRecips, fwdHosts, action) <- + C.makeServerInput (Just uCap) maybeSummary audience $ AP.AddActivity add + let cap' = first (\ (la, i) -> (la, error "lah", i)) cap + handleViaActor + personID (Just cap') localRecips remoteRecips fwdHosts action + + case result of + Left e -> setMessage $ toHtml e + Right inviteID -> setMessage "Add sent" + redirect $ DeckProjectsR deckHash + postDeckApproveCompR :: KeyHashid Deck -> KeyHashid Stem -> Handler Html postDeckApproveCompR deckHash stemHash = do deckID <- decodeKeyHashid404 deckHash diff --git a/src/Vervis/Handler/Project.hs b/src/Vervis/Handler/Project.hs index 9c503c3..2c84687 100644 --- a/src/Vervis/Handler/Project.hs +++ b/src/Vervis/Handler/Project.hs @@ -565,7 +565,7 @@ postProjectInviteCompR :: KeyHashid Project -> Handler Html postProjectInviteCompR projectHash = do projectID <- decodeKeyHashid404 projectHash uComp <- - runFormPostRedirect (ProjectInviteCompR projectHash) projectInviteCompForm + runFormPostRedirect (ProjectComponentsR projectHash) projectInviteCompForm personEntity@(Entity personID person) <- requireAuth personHash <- encodeKeyHashid personID diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 099ebde..eba86ad 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -678,6 +678,7 @@ data TicketTracker u = TicketTracker { ticketTrackerActor :: Actor u , ticketTrackerTeam :: Maybe LocalURI , ticketTrackerCollaborators :: LocalURI + , ticketTrackerProjects :: LocalURI } instance ActivityPub TicketTracker where @@ -690,10 +691,12 @@ instance ActivityPub TicketTracker where TicketTracker a <$> withAuthorityMaybeO h (o .:|? "team") <*> withAuthorityO h (o .: "collaborators") - toSeries h (TicketTracker actor team collabs) + <*> withAuthorityO h (o .: "context") + toSeries h (TicketTracker actor team collabs projects) = toSeries h actor <> "team" .= (ObjURI h <$> team) <> "collaborators" .= ObjURI h collabs + <> "context" .= ObjURI h projects data PatchTracker u = PatchTracker { patchTrackerActor :: Actor u diff --git a/templates/deck/projects.hamlet b/templates/deck/projects.hamlet index 24946f5..c6da0a7 100644 --- a/templates/deck/projects.hamlet +++ b/templates/deck/projects.hamlet @@ -1,6 +1,7 @@ $# This file is part of Vervis. $# -$# Written in 2016, 2019, 2022, 2023 by fr33domlover . +$# Written in 2016, 2019, 2022, 2023, 2024 +$# by fr33domlover . $# $# ♡ Copying is an act of love. Please copy, reuse and share. $# @@ -34,3 +35,9 @@ $# . $if not gestured ^{buttonW POST "Approve" (DeckApproveCompR deckHash stemHash)} $# ^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)} + +$if haveAdmin +

Add deck to a project: +

+ ^{widgetAP} + diff --git a/th/routes b/th/routes index 8de2e1e..c720b7c 100644 --- a/th/routes +++ b/th/routes @@ -249,6 +249,8 @@ /decks/#DeckKeyHashid/remove/#CollabId DeckRemoveR POST /decks/#DeckKeyHashid/projects DeckProjectsR GET +/decks/#DeckKeyHashid/add-project DeckAddProjectR POST + /decks/#DeckKeyHashid/projects/approve/#StemKeyHashid DeckApproveCompR POST ---- Ticket ------------------------------------------------------------------