S2S: Project: Add: Implement Add-based version of projectInvite

src/Vervis/Actor/Person.hs

@@ -652,7 +652,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
                         manager <- asksEnv envHttpManager
                         coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                         lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                        AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                        AP.ResourceWithCollections _ mluCollabs _mluComps mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                         if mluCollabs == Just luColl || mluMembers == Just luColl
                             then Just . (role,) . Right <$> do
                                 instanceID <-

src/Vervis/Actor/Person/Client.hs

@@ -266,7 +266,7 @@ clientAdd now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts a
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luComps
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
 
                 instanceID <-
                     lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
@@ -895,7 +895,7 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 unless (mluCollabs == Just luColl || mluComps == Just luColl || mluMembers == Just luColl) $
                     throwE "Invite target isn't a collabs/components list"
 
@@ -1044,7 +1044,7 @@ clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs mluComps mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 let isCollabs = mluCollabs == Just luColl || mluMembers == Just luColl
                 unless (isCollabs || mluComps == Just luColl) $
                     throwE "Join resource isn't a collabs/components list"
@@ -1249,7 +1249,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Remove origin isn't a collabs list"
                 return $ ObjURI h lu

src/Vervis/Actor/Project.hs

@@ -1454,15 +1454,16 @@ checkExistingComponents projectID componentDB = do
 -- Meaning: An actor is adding some object to some target
 -- Behavior:
 --      * If the target is my components list:
---        * Verify the object is a component, find in DB/HTTP
+--           * Verify sender is authorized by me to add components to me
---        * Verify it's not already an active component of mine
+--           * Verify B isn't already an active component of mine
---        * Verify it's not already in a Add-Accept process waiting for project
+--           * Verify B isn't already in a Add-Accept process waiting for
---          collab to accept too
+--             project collab to accept too
---        * Verify it's not already in an Invite-Accept process waiting for
+--           * Verify B isn't already in an Invite-Accept process waiting for
 --             component (or its collaborator) to accept too
 --           * Insert the Add to my inbox
 --           * Create a Component record in DB
 --           * Forward the Add to my followers
+--           * Send Accept to sender, component+followers, my-followers
 --
 --      * If the target is my children list:
 --        * Verify the object is a project, find in DB/HTTP
@@ -1512,6 +1513,17 @@ checkExistingComponents projectID componentDB = do
 --        * Create a Source/Dest record in DB
 --        * Forward the Add to my followers
 --
+--      * If I'm the object, being added to someone's projects list:
+--        * Verify the object is a component, find in DB/HTTP
+--        * Verify it's not already an active component of mine
+--        * Verify it's not already in a them-Add-Accept process waiting for
+--          project collab to accept too
+--        * Verify it's not already in an us-Invite-Accept process waiting for
+--          component (or its collaborator) to accept too
+--        * Insert the Add to my inbox
+--        * Create a Component record in DB
+--        * Forward the Add to my followers
+--
 --      * Otherwise, error
 projectAdd
     :: UTCTime
@@ -1532,7 +1544,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
                     (\ la -> fromMaybeE (resourceToComponent =<< actorToResource la) "Not a component")
                     pure
                     object
-            addComponent comp
+            addComponentActive comp
         (Left (ATProjectChildren j), _) | j == projectID ->
             addChildActive object
         (Left (ATProjectParents j), _) | j == projectID ->
@@ -1543,25 +1555,182 @@ projectAdd now projectID (Verse authorIdMsig body) add = do
                     addChildPassive $ Left j
                 Left (ATProjectChildren j) | j /= projectID ->
                     addParentPassive $ Left j
+                Left (ATRepoProjects r) ->
+                    addComponentPassive $ Left $ ComponentRepo r
+                Left (ATDeckProjects d) ->
+                    addComponentPassive $ Left $ ComponentDeck d
+                Left (ATLoomProjects l) ->
+                    addComponentPassive $ Left $ ComponentLoom l
                 Right (ObjURI h luColl) -> do
                     -- NOTE this is HTTP GET done synchronously in the activity
                     -- handler
                     manager <- asksEnv envHttpManager
                     c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
                     lu <- fromMaybeE (AP.collectionContext c) "No context"
-                    j <- AP.fetchAPID_T manager (AP.actorId . AP.actorLocal . AP.projectActor) h lu
+                    rwc <- AP.fetchRWC_T manager h lu
-                    case (luColl == AP.projectChildren j, luColl == AP.projectParents j) of
+                    AP.Actor l d <-
-                        (True, False) ->
+                        case AP.rwcResource rwc of
-                            addParentPassive $ Right $ ObjURI h lu
+                            AP.ResourceActor a -> pure a
-                        (False, True) ->
+                            AP.ResourceChild _ _ -> throwE "Add.target remote ResourceChild"
-                            addChildPassive $ Right $ ObjURI h lu
+                    let typ = AP.actorType d
-                        _ -> throwE "Weird collection situation"
+                    if AP.actorTypeIsComponent typ && Just luColl == AP.rwcParentsOrProjects rwc
+                        then addComponentPassive $ Right $ ObjURI h lu
+                    else if typ == AP.ActorTypeProject && Just luColl == AP.rwcSubprojects rwc
+                        then addParentPassive $ Right $ ObjURI h lu
+                    else if typ == AP.ActorTypeProject && Just luColl == AP.rwcParentsOrProjects rwc
+                        then addChildPassive $ Right $ ObjURI h lu
+                    else throwE "Weird collection situation"
                 _ -> throwE "I'm being added somewhere irrelevant"
         _ -> throwE "This Add isn't for me"
 
     where
 
-    addComponent component = do
+    addComponentActive component = do
+
+        -- Check capability
+        capability <- do
+
+            -- Verify that a capability is provided
+            uCap <- do
+                let muCap = AP.activityCapability $ actbActivity body
+                fromMaybeE muCap "No capability provided"
+
+            -- Verify the capability URI is one of:
+            --   * Outbox item URI of a local actor, i.e. a local activity
+            --   * A remote URI
+            cap <- nameExceptT "Invite capability" $ parseActivityURI' uCap
+
+            -- Verify the capability is local
+            case cap of
+                Left (actorByKey, _, outboxItemID) ->
+                    return (actorByKey, outboxItemID)
+                _ -> throwE "Capability is remote i.e. definitely not by me"
+
+        -- If target is local, find it in our DB
+        -- If target is remote, HTTP GET it, verify it's an actor, and store in
+        -- our DB (if it's already there, no need for HTTP)
+        --
+        -- NOTE: This is a blocking HTTP GET done right here in the Invite handler,
+        -- which is NOT a good idea. Ideally, it would be done async, and the
+        -- handler result (approve/disapprove the Invite) would be sent later in a
+        -- separate (e.g. Accept) activity. But for the PoC level, the current
+        -- situation will hopefully do.
+        invitedDB <-
+            bitraverse
+                (withDBExcept . flip getComponentE "Invitee not found in DB")
+                getRemoteActorFromURI
+                component
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            resourceID <- lift $ projectResource <$> getJust projectID
+            Resource topicActorID <- lift $ getJust resourceID
+            topicActor <- lift $ getJust topicActorID
+
+            -- Verify the specified capability gives relevant access
+            verifyCapability'
+                capability authorIdMsig (LocalResourceProject projectID) AP.RoleAdmin
+
+            -- Find existing Component records I have for this component
+            -- Make sure none are enabled / in Add-Accept mode / in
+            -- Invite-Accept mode
+            checkExistingComponents projectID invitedDB
+
+            maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+            lift $ for maybeInviteDB $ \ (inboxItemID, inviteDB) -> do
+
+                -- Insert Collab or Component record to DB
+                acceptID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
+                insertComponent invitedDB inviteDB acceptID
+
+                -- Prepare forwarding Invite to my followers
+                sieve <- do
+                    projectHash <- encodeKeyHashid projectID
+                    return $ makeRecipientSet [] [LocalStageProjectFollowers projectHash]
+
+                -- Prepare an Accept activity and insert to my outbox
+                accept@(actionAccept, _, _, _) <- prepareAccept invitedDB
+                _luAccept <- updateOutboxItem' (LocalActorProject projectID) acceptID actionAccept
+
+                return (topicActorID, sieve, acceptID, accept, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (projectActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do
+                forwardActivity
+                    authorIdMsig body (LocalActorProject projectID) projectActorID sieve
+                lift $ sendActivity
+                    (LocalActorProject projectID) projectActorID localRecipsAccept
+                    remoteRecipsAccept fwdHostsAccept acceptID actionAccept
+                doneDB inboxItemID "[Add-component-active] Recorded and forwarded the Add, sent an Accept"
+
+        where
+
+        getRemoteActorFromURI (ObjURI h lu) = do
+            instanceID <-
+                lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
+            result <-
+                ExceptT $ first (T.pack . displayException) <$>
+                    fetchRemoteActor' instanceID h lu
+            case result of
+                Left Nothing -> throwE "Target @id mismatch"
+                Left (Just err) -> throwE $ T.pack $ displayException err
+                Right Nothing -> throwE "Target isn't an actor"
+                Right (Just actor) -> return $ entityKey actor
+
+        insertComponent componentDB inviteDB acceptID = do
+            componentID <- insert $ Component projectID AP.RoleAdmin
+            originID <- insert $ ComponentOriginInvite componentID
+            case inviteDB of
+                Left (_, _, inviteID) ->
+                    insert_ $ ComponentProjectGestureLocal componentID inviteID
+                Right (author, _, inviteID) ->
+                    insert_ $ ComponentProjectGestureRemote componentID (remoteAuthorId author) inviteID
+            case componentDB of
+                Left l ->
+                    insert_ $ ComponentLocal componentID (localComponentID l)
+                Right remoteActorID ->
+                    insert_ $ ComponentRemote componentID remoteActorID
+            insert_ $ ComponentProjectAccept originID acceptID
+
+        prepareAccept invitedDB = do
+            encodeRouteHome <- getEncodeRouteHome
+
+            audInviter <- lift $ makeAudSenderOnly authorIdMsig
+            audInvited <-
+                case invitedDB of
+                    Left componentByEnt -> do
+                        componentByHash <- hashComponent $ bmap entityKey componentByEnt
+                        let actor = resourceToActor $ componentResource componentByHash
+                        return $ AudLocal [actor] [localActorFollowers actor]
+                    Right remoteActorID -> do
+                        ra <- getJust remoteActorID
+                        ObjURI h lu <- getRemoteActorURI ra
+                        return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra)
+            audTopic <-
+                AudLocal [] . pure . LocalStageProjectFollowers <$>
+                    encodeKeyHashid projectID
+            uInvite <- lift $ getActivityURI authorIdMsig
+
+            let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
+                    collectAudience [audInviter, audInvited, audTopic]
+
+                recips = map encodeRouteHome audLocal ++ audRemote
+                action = AP.Action
+                    { AP.actionCapability = Nothing
+                    , AP.actionSummary    = Nothing
+                    , AP.actionAudience   = AP.Audience recips [] [] [] [] []
+                    , AP.actionFulfills   = [uInvite]
+                    , AP.actionSpecific   = AP.AcceptActivity AP.Accept
+                        { AP.acceptObject   = uInvite
+                        , AP.acceptResult   = Nothing
+                        }
+                    }
+
+            return (action, recipientSet, remoteActors, fwdHosts)
+
+    addComponentPassive component = do
 
         -- If component is local, find it in our DB
         -- If component is remote, HTTP GET it, verify it's an actor of a component

src/Vervis/Client.hs

@@ -1151,7 +1151,7 @@ invite personID uRecipient uResourceCollabs role = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ mluCollabs _ mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ mluCollabs _ mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 unless (mluCollabs == Just luColl || mluMembers == Just luColl) $
                     throwE "Invite target isn't a collabs list"
                 return $ ObjURI h lu
@@ -1242,7 +1242,7 @@ add personID uRecipient uCollection role = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote collection has no 'context'"
-                AP.ResourceWithCollections _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _ _ _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 return $ ObjURI h lu
             )
             target
@@ -1328,7 +1328,7 @@ remove personID uRecipient uCollection = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
-                AP.ResourceWithCollections _ _mluCollabs _ _mluMembers <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                AP.ResourceWithCollections _ _mluCollabs _ _mluMembers _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                 return $ ObjURI h lu
             )
             resource

src/Vervis/Handler/Deck.hs

@@ -624,7 +624,7 @@ postDeckAddProjectR deckHash = do
                     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
+                    AP.ResourceWithCollections _ _ mluComponents _ _ _ _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
                     luComponents <- fromMaybeE mluComponents "No components collection"
                     return $ ObjURI h luComponents
 

src/Web/ActivityPub.hs

@@ -30,6 +30,7 @@ module Web.ActivityPub
       -- ActivityPub actor document including a public key, with a 'FromJSON'
       -- instance for fetching and a 'ToJSON' instance for publishing.
     , ActorType (..)
+    , actorTypeIsComponent
     , parseActorType
     , renderActorType
     --, Algorithm (..)
@@ -132,6 +133,7 @@ module Web.ActivityPub
     , fetchRecipient
     , fetchResource
     , fetchRWC
+    , fetchRWC_T
     , keyListedByActor
     , fetchUnknownKey
     , fetchKnownPersonalKey
@@ -390,6 +392,12 @@ data ActorType
     | ActorTypeOther Text
     deriving Eq
 
+actorTypeIsComponent = \case
+    ActorTypeRepo -> True
+    ActorTypeTicketTracker -> True
+    ActorTypePatchTracker -> True
+    _ -> False
+
 parseActorType :: Text -> ActorType
 parseActorType t
     | t == "Person"        = ActorTypePerson
@@ -871,6 +879,9 @@ data ResourceWithCollections u = ResourceWithCollections
     , rwcCollabs    :: Maybe LocalURI
     , rwcComponents :: Maybe LocalURI
     , rwcMembers    :: Maybe LocalURI
+    , rwcParentsOrProjects :: Maybe LocalURI
+    , rwcSubprojects :: Maybe LocalURI
+    , rwcSubteams :: Maybe LocalURI
     }
 
 instance ActivityPub ResourceWithCollections where
@@ -881,11 +892,17 @@ instance ActivityPub ResourceWithCollections where
             <$> withAuthorityMaybeO h (o .:? "collaborators")
             <*> withAuthorityMaybeO h (o .:? "components")
             <*> withAuthorityMaybeO h (o .:? "members")
-    toSeries h (ResourceWithCollections r collabs comps members)
+            <*> withAuthorityMaybeO h (o .:? "context")
+            <*> withAuthorityMaybeO h (o .:? "subprojects")
+            <*> withAuthorityMaybeO h (o .:? "subteams")
+    toSeries h (ResourceWithCollections r collabs comps members ctx subj subt)
         =  toSeries h r
         <> "collaborators" .=? (ObjURI h <$> collabs)
         <> "components"    .=? (ObjURI h <$> comps)
         <> "members"       .=? (ObjURI h <$> members)
+        <> "context"       .=? (ObjURI h <$> ctx)
+        <> "subprojects"       .=? (ObjURI h <$> subj)
+        <> "subteams"       .=? (ObjURI h <$> subt)
 
 data Project u = Project
     { projectActor      :: Actor u
@@ -2699,6 +2716,12 @@ fetchRWC m = fetchAPID' m (getId . rwcResource)
     getId (ResourceActor a)      = actorId $ actorLocal a
     getId (ResourceChild luId _) = luId
 
+fetchRWC_T :: (MonadIO m, UriMode u) => Manager -> Authority u -> LocalURI -> ExceptT Text m (ResourceWithCollections u)
+fetchRWC_T m h lu = ExceptT $ liftIO $ first showError <$> fetchRWC m h lu
+    where
+    showError Nothing  = "Object @id doesn't match the URI we fetched"
+    showError (Just e) = T.pack $ displayException e
+
 fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u))
 fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
     where