From f6dda396dd9e87041990f10ba385680f3373b799 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sun, 12 May 2024 17:50:18 +0300 Subject: [PATCH] S2S: Project: Add: Implement Add-based version of projectInvite --- src/Vervis/Actor/Person.hs | 2 +- src/Vervis/Actor/Person/Client.hs | 8 +- src/Vervis/Actor/Project.hs | 205 +++++++++++++++++++++++++++--- src/Vervis/Client.hs | 6 +- src/Vervis/Handler/Deck.hs | 2 +- src/Web/ActivityPub.hs | 25 +++- 6 files changed, 220 insertions(+), 28 deletions(-) diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 66df3ef..981600d 100644 --- a/src/Vervis/Actor/Person.hs +++ b/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 <- diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 5c7a4b4..9413c3c 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/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 diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index bea46fd..9accd5f 100644 --- a/src/Vervis/Actor/Project.hs +++ b/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 it's not already an active component of mine --- * Verify it's not already in a Add-Accept process waiting for project --- collab to accept too --- * Verify it's not 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 +-- * Verify sender is authorized by me to add components to me +-- * Verify B isn't already an active component of mine +-- * Verify B isn't already in a Add-Accept process waiting for +-- project collab to accept too +-- * 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 - case (luColl == AP.projectChildren j, luColl == AP.projectParents j) of - (True, False) -> - addParentPassive $ Right $ ObjURI h lu - (False, True) -> - addChildPassive $ Right $ ObjURI h lu - _ -> throwE "Weird collection situation" + rwc <- AP.fetchRWC_T manager h lu + AP.Actor l d <- + case AP.rwcResource rwc of + AP.ResourceActor a -> pure a + AP.ResourceChild _ _ -> throwE "Add.target remote ResourceChild" + let typ = AP.actorType d + 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 diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 94f505e..6a8ea76 100644 --- a/src/Vervis/Client.hs +++ b/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 diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index 602b200..f9fb527 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index d5df4c3..32634d1 100644 --- a/src/Web/ActivityPub.hs +++ b/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