UI: Deck: Form for adding to a project

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)

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

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

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

templates/deck/projects.hamlet

@@ -1,6 +1,7 @@
 $# This file is part of Vervis.
 $#
-$# Written in 2016, 2019, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
+$# Written in 2016, 2019, 2022, 2023, 2024
+$# by fr33domlover <fr33domlover@riseup.net>.
 $#
 $# ♡ Copying is an act of love. Please copy, reuse and share.
 $#
@@ -34,3 +35,9 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
       $if not gestured
         <td>^{buttonW POST "Approve" (DeckApproveCompR deckHash stemHash)}
 $#    <td>^{buttonW POST "Remove" (DeckRemoveR deckHash ctID)}
+
+$if haveAdmin
+  <p>Add deck to a project:
+  <form method=POST action=@{DeckAddProjectR deckHash} enctype=#{enctypeAP}>
+    ^{widgetAP}
+    <input type="submit">

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 ------------------------------------------------------------------