Client: Project UI for adding a component

src/Vervis/Client.hs

@@ -40,6 +40,7 @@ module Vervis.Client
     , createProject
     , invite
     , remove
+    , inviteComponent
     )
 where
 
@@ -84,6 +85,7 @@ import Vervis.ActivityPub
 import Vervis.Actor
 import Vervis.Actor2
 import Vervis.Cloth
+import Vervis.Data.Actor
 import Vervis.Data.Collab
 import Vervis.Data.Ticket
 import Vervis.FedURI
@@ -1198,3 +1200,74 @@ remove personID uRecipient uResourceCollabs = do
         audience = [audResource, audRecipient, audAuthor]
 
     return (Nothing, audience, activity)
+
+inviteComponent
+    :: PersonId
+    -> ProjectId
+    -> FedURI
+    -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Invite URIMode)
+inviteComponent personID projectID uComp = do
+
+    encodeRouteHome <- getEncodeRouteHome
+    theater <- asksSite appTheater
+    env <- asksSite appEnv
+    projectHash <- encodeKeyHashid projectID
+
+    let uComps = encodeRouteHome $ ProjectComponentsR projectHash
+        activity = AP.Invite AP.RoleAdmin uComp uComps
+
+    -- If component is remote, get it via HTTP/DB to determine its followers
+    -- collection
+    comp <- parseComp uComp
+    compDB <-
+        bitraverse
+            (runActE . hashComponent)
+            (\ u@(ObjURI h lu) -> do
+                instanceID <-
+                    lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
+                result <-
+                    ExceptT $ first (T.pack . displayException) <$>
+                        fetchRemoteActor instanceID h lu
+                case result of
+                    Left Nothing -> throwE "Recipient @id mismatch"
+                    Left (Just err) -> throwE $ T.pack $ displayException err
+                    Right Nothing -> throwE "Recipient isn't an actor"
+                    Right (Just actor) -> return (entityVal actor, u)
+            )
+            comp
+
+    senderHash <- encodeKeyHashid personID
+
+    let audComp =
+            case compDB of
+                Left (ComponentRepo r) ->
+                    AudLocal [LocalActorRepo r] [LocalStageRepoFollowers r]
+                Left (ComponentDeck d) ->
+                    AudLocal [LocalActorDeck d] [LocalStageDeckFollowers d]
+                Left (ComponentLoom l) ->
+                    AudLocal [LocalActorLoom l] [LocalStageLoomFollowers l]
+                Right (remoteActor, ObjURI h lu) ->
+                    AudRemote h
+                        [lu]
+                        (maybeToList $ remoteActorFollowers remoteActor)
+        audProject =
+            AudLocal [LocalActorProject projectHash] [LocalStageProjectFollowers projectHash]
+        audAuthor =
+            AudLocal [] [LocalStagePersonFollowers senderHash]
+
+        audience = [audComp, audProject, audAuthor]
+
+    return (Nothing, audience, activity)
+    where
+    parseComp u = do
+        routeOrRemote <- parseFedURIOld u
+        bitraverse
+            (\ route -> do
+                c <-
+                    fromMaybeE
+                        (parseComponent route)
+                        "Not a component route"
+                runActE $ unhashComponentE c "Contains invalid keyhashid"
+            )
+            pure
+            routeOrRemote

src/Vervis/Data/Collab.hs

@@ -48,7 +48,9 @@ module Vervis.Data.Collab
     , grantResourceLocalActor
 
     , ComponentBy (..)
+    , parseComponent
     , hashComponent
+    , unhashComponentE
     , componentActor
     , resourceToComponent
 

src/Vervis/Form/Tracker.hs

@@ -24,6 +24,7 @@ module Vervis.Form.Tracker
     , deckInviteForm
     , ProjectInvite (..)
     , projectInviteForm
+    , projectInviteCompForm
     --, NewProjectCollab (..)
     --, newProjectCollabForm
     --, editProjectForm
@@ -46,6 +47,8 @@ import Yesod.Hashids
 
 import qualified Web.ActivityPub as AP
 
+import Vervis.FedURI
+import Vervis.Form.Ticket
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
@@ -161,6 +164,9 @@ projectInviteForm projectID = renderDivs $ ProjectInvite
             l
     selectRole = selectField optionsEnum
 
+projectInviteCompForm :: Form FedURI
+projectInviteCompForm = renderDivs $ areq fedUriField "Component URI*" Nothing
+
 {-
 editProjectAForm :: SharerId -> Entity Project -> AForm Handler Project
 editProjectAForm sid (Entity jid project) = Project

src/Vervis/Foundation.hs

@@ -1010,3 +1010,5 @@ instance YesodBreadcrumbs App where
 
         ProjectComponentsR j -> ("Components", Just $ ProjectR j)
         ProjectCollabLiveR j c -> (keyHashidText c, Just $ ProjectCollabsR j)
+
+        ProjectInviteCompR d  -> ("Invite", Just $ ProjectComponentsR d)

src/Vervis/Handler/Project.hs

@@ -35,6 +35,9 @@ module Vervis.Handler.Project
 
     , getProjectComponentsR
     , getProjectCollabLiveR
+
+    , getProjectInviteCompR
+    , postProjectInviteCompR
     )
 where
 
@@ -522,3 +525,42 @@ getProjectCollabLiveR projectHash enableHash = do
         CollabTopicProject _ j <-
             getValBy404 $ UniqueCollabTopicProject collabID
         unless (j == projectID) notFound
+
+getProjectInviteCompR :: KeyHashid Project -> Handler Html
+getProjectInviteCompR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    ((_result, widget), enctype) <- runFormPost projectInviteCompForm
+    defaultLayout $(widgetFile "project/component-new")
+
+postProjectInviteCompR :: KeyHashid Project -> Handler Html
+postProjectInviteCompR projectHash = do
+    projectID <- decodeKeyHashid404 projectHash
+    uComp <-
+        runFormPostRedirect (ProjectInviteCompR projectHash) projectInviteCompForm
+
+    personEntity@(Entity personID person) <- requireAuth
+    personHash <- encodeKeyHashid personID
+    encodeRouteHome <- getEncodeRouteHome
+
+    result <- runExceptT $ do
+        (maybeSummary, audience, invite) <-
+            C.inviteComponent personID projectID uComp
+        grantID <- do
+            maybeItem <- lift $ runDB $ getGrant CollabTopicProjectCollab CollabTopicProjectProject projectID personID
+            fromMaybeE maybeItem "You need to be a collaborator in the Project to invite people"
+        grantHash <- encodeKeyHashid grantID
+        let uCap = encodeRouteHome $ ProjectOutboxItemR projectHash grantHash
+        (localRecips, remoteRecips, fwdHosts, action) <-
+            C.makeServerInput (Just uCap) maybeSummary audience $ AP.InviteActivity invite
+        let cap =
+                Left (LocalActorProject projectID, LocalActorProject projectHash, grantID)
+        handleViaActor
+            personID (Just cap) localRecips remoteRecips fwdHosts action
+
+    case result of
+        Left e -> do
+            setMessage $ toHtml e
+            redirect $ ProjectInviteCompR projectHash
+        Right inviteID -> do
+            setMessage "Invite sent"
+            redirect $ ProjectComponentsR projectHash

templates/project/component-new.hamlet

@@ -0,0 +1,18 @@
+$# This file is part of Vervis.
+$#
+$# Written in 2016, 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/>.
+
+<form method=POST action=@{ProjectInviteCompR projectHash} enctype=#{enctype}>
+  ^{widget}
+  <div class="submit">
+    <input type="submit">

templates/project/components.hamlet

@@ -39,4 +39,4 @@ $#    <td>^{buttonW POST "Remove" (ProjectRemoveR projectHash ctID)}
       <td>#{show role}
       <td>^{componentLinkFedW comp}
 
-$#<a href=@{ProjectInviteR projectHash}>Invite…
+<a href=@{ProjectInviteCompR projectHash}>Invite…

th/routes

@@ -330,3 +330,5 @@
 
 /projects/#ProjectKeyHashid/components                   ProjectComponentsR GET
 /projects/#ProjectKeyHashid/collabs/#CollabEnableKeyHashid/live ProjectCollabLiveR    GET
+
+/projects/#ProjectKeyHashid/invite-component             ProjectInviteCompR     GET POST