From 0c0007c892d1aaa3901124dd8920fad0c779830b Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 22 Nov 2023 23:12:32 +0200 Subject: [PATCH] C2S: Person: Implement Join handler, inserting a Permit record to DB --- src/Vervis/Actor/Person.hs | 2 +- src/Vervis/Actor/Person/Client.hs | 145 ++++++++++++++++++++++++++++++ 2 files changed, 146 insertions(+), 1 deletion(-) diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index 4be32b2..d218eed 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -616,7 +616,7 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do recipPersonHash <- encodeKeyHashid recipPersonID let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash] - -- Insert Collab or Stem record to DB + -- Insert Permit record to DB insertPermit resourceDB inviteDB role return sieve diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index c427a72..be4ecec 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -934,6 +934,150 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost fwdHosts inviteID action return inviteID +-- Meaning: The human wants to join a resource R +-- Behavior: +-- * Some basic sanity checks +-- * Parse the Join +-- * Make sure not joining myself +-- * Verify that a capability isn't specified +-- * If resource is local, verify it exists in DB +-- * Verify the resource R is addressed in the Join +-- * Insert Join to my outbox +-- +-- * If R is referred by a collabs/members collection URI: +-- * For each Permit record I have for this resource: +-- * Verify it's not enabled yet, i.e. I'm not already a +-- collaborator, haven't received a direct-Grant +-- * Verify it's not in Invite-Accept state, already got the +-- resource's Accept and waiting for my approval or for the +-- topic's Grant +-- * Verify it's not a Join +-- * Create a Permit record in DB +-- +-- * Asynchrnously deliver to: +-- * Resource+followers +-- * My followers +clientJoin + :: UTCTime + -> PersonId + -> ClientMsg + -> AP.Join URIMode + -> ActE OutboxItemId +clientJoin now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) join = do + + -- Check input + (role, resource) <- parseJoin join + verifyNothingE maybeCap "Capability provided" + + -- If resource collabs URI is remote, HTTP GET it and its resource and its + -- managing actor, and insert to our DB. If resource is local, find it in + -- our DB. + resourceDB <- + bitraverse + (withDBExcept . flip getLocalActorEntityE "Join resource not found in DB") + (\ u@(ObjURI h luColl) -> 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 + let isCollabs = mluCollabs == Just luColl || mluMembers == Just luColl + unless (isCollabs || mluComps == Just luColl) $ + throwE "Join resource isn't a collabs/components list" + + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . show) <$> + fetchRemoteResource instanceID h lu + case result of + Left (Entity actorID actor) -> + return (remoteActorIdent actor, actorID, u, isCollabs) + Right (objectID, luManager, (Entity actorID _)) -> + return (objectID, actorID, ObjURI h luManager, isCollabs) + ) + resource + + -- Verify that resource is addressed by the Join + bitraverse_ + (verifyActorAddressed localRecips . bmap entityKey) + (\ (_, _, u, _) -> verifyRemoteAddressed remoteRecips u) + resourceDB + + let maybePermit = + case resourceDB of + Left la -> Just $ Left la + Right (_, _, _, False) -> Nothing + Right (objectID, actorID, uActor, True) -> Just $ Right (objectID, actorID, uActor) + + (actorMeID, localRecipsFinal, joinID) <- withDBExcept $ do + + -- Grab me from DB + (personMe, actorMe) <- lift $ do + p <- getJust personMeID + (p,) <$> getJust (personActor p) + + -- Insert the Join activity to my outbox + joinID <- lift $ insertEmptyOutboxItem' (actorOutbox actorMe) now + _luJoin <- lift $ updateOutboxItem' (LocalActorPerson personMeID) joinID action + + for_ maybePermit $ \ topicDB -> do + + -- Find existing Permit records I have for this topic + -- Make sure none are enabled / in Join mode / in Invite-Accept + -- mode + checkExistingPermits + personMeID + (bimap (bmap entityKey) (view _2) topicDB) + + -- Insert Permit record to DB + insertPermit topicDB joinID role + + -- Prepare local recipients for Join delivery + sieve <- lift $ do + resourceHash <- bitraverse hashLocalActor pure resource + senderHash <- encodeKeyHashid personMeID + let sieveActors = catMaybes + [ case resourceHash of + Left a -> Just a + Right _ -> Nothing + ] + sieveStages = catMaybes + [ Just $ LocalStagePersonFollowers senderHash + , case resourceHash of + Left a -> Just $ localActorFollowers a + Right _ -> Nothing + ] + return $ makeRecipientSet sieveActors sieveStages + return + ( personActor personMe + , localRecipSieve sieve False localRecips + , joinID + ) + + lift $ sendActivity + (LocalActorPerson personMeID) actorMeID localRecipsFinal remoteRecips + fwdHosts joinID action + return joinID + + where + + insertPermit resourceDB joinID role = do + permitID <- lift $ insert $ Permit personMeID role + case resourceDB of + Left la -> do + localID <- lift $ insert $ PermitTopicLocal permitID + case bmap entityKey la of + LocalActorPerson _ -> throwE "insertPermit: Person not supported as a PermitTopicLocal type (you can't become a \"collaborator in a person\"" + LocalActorRepo r -> lift $ insert_ $ PermitTopicRepo localID r + LocalActorDeck d -> lift $ insert_ $ PermitTopicDeck localID d + LocalActorLoom l -> lift $ insert_ $ PermitTopicLoom localID l + LocalActorProject j -> lift $ insert_ $ PermitTopicProject localID j + LocalActorGroup g -> lift $ insert_ $ PermitTopicGroup localID g + Right (_, actorID, _) -> lift $ insert_ $ PermitTopicRemote permitID actorID + lift $ do + insert_ $ PermitFulfillsJoin permitID + insert_ $ PermitPersonGesture permitID joinID + -- Meaning: The human wants to open a ticket/MR/dependency -- Behavior: -- * Basics checks on the provided ticket/MR (dependency not allowed) @@ -1218,6 +1362,7 @@ clientBehavior now personID msg = AP.AddActivity add -> clientAdd now personID msg add AP.CreateActivity create -> clientCreate now personID msg create AP.InviteActivity invite -> clientInvite now personID msg invite + AP.JoinActivity join -> clientJoin now personID msg join AP.OfferActivity offer -> clientOffer now personID msg offer AP.RemoveActivity remove -> clientRemove now personID msg remove AP.ResolveActivity resolve -> clientResolve now personID msg resolve