From 83590ba6ff54a456066d536da4f40fe47b1341dc Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sat, 15 Jun 2024 15:51:31 +0300 Subject: [PATCH] S2S: Group: Add: Implement resource-passive mode --- src/Vervis/Actor/Group.hs | 96 +++++++++++++++++++++++++++++++ src/Vervis/Actor/Person.hs | 2 +- src/Vervis/Actor/Person/Client.hs | 8 +-- src/Vervis/Client.hs | 6 +- src/Vervis/Data/Collab.hs | 8 +++ src/Vervis/Migration/Model2022.hs | 5 -- src/Web/ActivityPub.hs | 5 +- 7 files changed, 116 insertions(+), 14 deletions(-) diff --git a/src/Vervis/Actor/Group.hs b/src/Vervis/Actor/Group.hs index 0a03d9c..ac4d6d3 100644 --- a/src/Vervis/Actor/Group.hs +++ b/src/Vervis/Actor/Group.hs @@ -147,6 +147,17 @@ import Vervis.Web.Collab -- * Create a Source/Dest record in DB -- * Forward the Add to my followers -- +-- * If I'm the object, being added to some resource's teams list: +-- * Verify the target is a non-team resource's teams list, find in DB/HTTP +-- * Verify it's not already an active resource of mine +-- * Verify it's not already in an Origin-Us process where I saw the Add +-- and sent my Accept +-- * Verify it's not already in an Origin-Them process, where I saw the +-- Add and the potential resource's Accept +-- * Insert the Add to my inbox +-- * Create an Effort record in DB +-- * Forward the Add to my followers +-- -- * Otherwise, error groupAdd :: UTCTime @@ -173,6 +184,8 @@ groupAdd now groupID (Verse authorIdMsig body) add = do addChildPassive $ Left j Left (ATGroupChildren j) | j /= groupID -> addParentPassive $ Left j + Left at | isJust $ addTargetResourceTeams at -> + addResourcePassive $ Left $ fromJust $ addTargetResourceTeams at Right (ObjURI h luColl) -> do -- NOTE this is HTTP GET done synchronously in the activity -- handler @@ -189,6 +202,8 @@ groupAdd now groupID (Verse authorIdMsig body) add = do then addParentPassive $ Right $ ObjURI h lu else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcParentsOrProjects rwc then addChildPassive $ Right $ ObjURI h lu + else if AP.actorTypeIsResourceNT typ && Just luColl == AP.rwcTeams rwc + then addResourcePassive $ Right $ ObjURI h lu else throwE "Weird collection situation" _ -> throwE "I'm being added somewhere irrelevant" _ -> throwE "This Add isn't for me" @@ -755,6 +770,87 @@ groupAdd now groupID (Verse authorIdMsig body) add = do return (action, recipientSet, remoteActors, fwdHosts) + addResourcePassive resource = do + + -- If resource is local, find it in our DB + -- If resource is remote, HTTP GET it, verify it's an actor of Group + -- type, 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 handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result would be sent later in a separate (e.g. Accept) activity. + -- But for the PoC level, the current situation will hopefully do. + resourceDB <- + bitraverse + (\ ng -> + withDBExcept $ + getLocalResourceEntityE (resourceFromNG ng) "Resource not found in DB" + ) + (\ u@(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 "Resource @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Resource isn't an actor" + Right (Just actor) -> do + if AP.actorTypeIsResourceNT $ remoteActorType $ entityVal actor + then pure () + else throwE "Remote resource type isn't a resource" + return (u, actor) + ) + resource + let resourceDB' = bimap localResourceID (entityKey . snd) resourceDB + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (group, actorRecip) <- lift $ do + p <- getJust groupID + (p,) <$> getJust (groupActor p) + + -- Verify the target isn't already a resource of mine, and that no + -- Effort record is already in Add-Accept state + verifyNoStartedGroupResources groupID resourceDB' + + -- Insert the Add to my inbox + mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for mractid $ \ (inboxItemID, addDB) -> do + + -- Create an Effort record in DB + insertEffort resourceDB' addDB + + -- Prepare forwarding the Add to my followers + sieve <- do + groupHash <- encodeKeyHashid groupID + return $ makeRecipientSet [] [LocalStageGroupFollowers groupHash] + + return (groupActor group, sieve, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (groupActorID, sieve, inboxItemID) -> do + forwardActivity + authorIdMsig body (LocalActorGroup groupID) groupActorID sieve + doneDB inboxItemID "[Resource-passive] Recorded a resource-in-progress, forwarded the Add" + + where + + insertEffort topicDB addDB = do + effortID <- insert $ Effort AP.RoleAdmin groupID + case topicDB of + Left r -> insert_ $ EffortTopicLocal effortID r + Right a -> insert_ $ EffortTopicRemote effortID a + themID <- insert $ EffortOriginThem effortID + case addDB of + Left (_, _, addID) -> + insert_ $ EffortThemGestureLocal themID addID + Right (author, _, addID) -> + insert_ $ EffortThemGestureRemote themID (remoteAuthorId author) addID + -- Meaning: An actor accepted something -- Behavior: -- * Check if I know the activity that's being Accepted: diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 981600d..448e2ec 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 a501423..31bd4f3 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 _ _ _ _ _ _ _ <- 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 ) resource diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 0f2f220..44992d8 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -1150,7 +1150,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 @@ -1241,7 +1241,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 @@ -1327,7 +1327,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/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 4424ff5..d41c248 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -32,6 +32,7 @@ module Vervis.Data.Collab , AddTarget (..) , addTargetResource , addTargetComponentProjects + , addTargetResourceTeams , parseAdd , ComponentBy (..) @@ -478,6 +479,13 @@ addTargetComponentProjects = \case ATLoomProjects l -> Just $ ComponentLoom l _ -> Nothing +addTargetResourceTeams = \case + ATProjectTeams j -> Just $ LocalResourceProject' j + ATRepoTeams r -> Just $ LocalResourceRepo' r + ATDeckTeams d -> Just $ LocalResourceDeck' d + ATLoomTeams l -> Just $ LocalResourceLoom' l + _ -> Nothing + parseAdd :: StageRoute Env ~ Route App => Either (LocalActorBy Key) FedURI diff --git a/src/Vervis/Migration/Model2022.hs b/src/Vervis/Migration/Model2022.hs index 9141846..43769f8 100644 --- a/src/Vervis/Migration/Model2022.hs +++ b/src/Vervis/Migration/Model2022.hs @@ -80,13 +80,8 @@ import Vervis.Model.TH import Vervis.Model.Ticket import Vervis.Model.Workflow --- For migrations 77, 114 - import Data.Int - import Database.Persist.JSON -import Network.FedURI -import Web.ActivityPub makeEntitiesMigration "285" $(modelFile "migrations/2022_06_14_collab_mig.model") diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index fb54938..c4763f3 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -903,6 +903,7 @@ data ResourceWithCollections u = ResourceWithCollections , rwcParentsOrProjects :: Maybe LocalURI , rwcSubprojects :: Maybe LocalURI , rwcSubteams :: Maybe LocalURI + , rwcTeams :: Maybe LocalURI } instance ActivityPub ResourceWithCollections where @@ -916,7 +917,8 @@ instance ActivityPub ResourceWithCollections where <*> withAuthorityMaybeO h (o .:? "context") <*> withAuthorityMaybeO h (o .:? "subprojects") <*> withAuthorityMaybeO h (o .:? "subteams") - toSeries h (ResourceWithCollections r collabs comps members ctx subj subt) + <*> withAuthorityMaybeO h (o .:? "teams") + toSeries h (ResourceWithCollections r collabs comps members ctx subj subt teams) = toSeries h r <> "collaborators" .=? (ObjURI h <$> collabs) <> "components" .=? (ObjURI h <$> comps) @@ -924,6 +926,7 @@ instance ActivityPub ResourceWithCollections where <> "context" .=? (ObjURI h <$> ctx) <> "subprojects" .=? (ObjURI h <$> subj) <> "subteams" .=? (ObjURI h <$> subt) + <> "teams" .=? (ObjURI h <$> teams) data Project u = Project { projectActor :: Actor u