From 3c0a3d13170cbc61bc6eecffc453a61f44c40d95 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Wed, 22 Nov 2023 19:30:33 +0200 Subject: [PATCH] S2S: Person: Update Invite handler to create a Permit record --- src/Vervis/Actor/Person.hs | 116 ++++++++++++++++++++++++++------ src/Vervis/Persist/Collab.hs | 125 +++++++++++++++++++++++++++++++++++ 2 files changed, 221 insertions(+), 20 deletions(-) diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index b815b41..4be32b2 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -26,6 +26,7 @@ import Control.Monad.Trans.Class import Control.Monad.Trans.Except import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader +import Data.Barbie import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) @@ -535,7 +536,17 @@ personAdd now recipPersonID (Verse authorIdMsig body) add = do -- Meaning: Someone invited someone to a resource -- Behavior: -- * Insert to my inbox --- * If I'm the target, forward the Invite to my followers +-- * If I'm being invited to the resource's collaborators/members +-- collection: +-- * 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 +-- * Forward the Invite to my followers personInvite :: UTCTime -> PersonId @@ -545,10 +556,42 @@ personInvite personInvite now recipPersonID (Verse authorIdMsig body) invite = do -- Check input - recipientOrComp <- do + maybeRoleAndResourceDB <- do let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (_role, _resource, target) <- parseInvite author invite - return target + (role, resource, recip) <- parseInvite author invite + let recipIsMe = + case recip of + Left (Left (GrantRecipPerson p)) | p == recipPersonID -> True + _ -> False + if not recipIsMe + then pure Nothing + else + -- 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. + case resource of + Left r -> + case r of + Left la -> withDBExcept $ Just . (role,) . Left <$> getLocalActorEntityE la "Invite resource not found in DB" + Right _j -> pure Nothing + Right 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 + if mluCollabs == Just luColl || mluMembers == Just luColl + then Just . (role,) . Right <$> do + 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) + Right (objectID, luManager, (Entity actorID _)) -> + return (objectID, actorID, ObjURI h luManager) + else pure Nothing maybeNew <- withDBExcept $ do @@ -558,31 +601,64 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do (p,) <$> getJust (personActor p) maybeInviteDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True - for maybeInviteDB $ \ _inviteDB -> - return $ personActor personRecip + for maybeInviteDB $ \ inviteDB -> do + + maybePermit <- for maybeRoleAndResourceDB $ \ (role, resourceDB) -> do + + -- Find existing Permit records I have for this topic + -- Make sure none are enabled / in Join mode / in Invite-Accept + -- mode + checkExistingPermits + recipPersonID + (bimap (bmap entityKey) (view _2) resourceDB) + + -- Prepare forwarding Invite to my followers + recipPersonHash <- encodeKeyHashid recipPersonID + let sieve = makeRecipientSet [] [LocalStagePersonFollowers recipPersonHash] + + -- Insert Collab or Stem record to DB + insertPermit resourceDB inviteDB role + + return sieve + + return (personActor personRecip, maybePermit) case maybeNew of Nothing -> done "I already have this activity in my inbox" - Just actorID -> do - let targetIsRecip = - case recipientOrComp of - Left (Left (GrantRecipPerson p)) -> p == recipPersonID - _ -> False - if not targetIsRecip - then done "I'm not the target; Inserted to inbox" - else do - recipHash <- encodeKeyHashid recipPersonID - let sieve = - makeRecipientSet - [] - [LocalStagePersonFollowers recipHash] + Just (actorID, maybePermit) -> + case maybePermit of + Nothing -> done "I'm not the target; Inserted to inbox" + Just sieve -> do forwardActivity authorIdMsig body (LocalActorPerson recipPersonID) actorID sieve done - "I'm the target; Inserted to inbox; \ + "I'm the target; Inserted to inbox; Inserted Permit; \ \Forwarded to followers if addressed" + where + + insertPermit resourceDB inviteDB role = do + permitID <- lift $ insert $ Permit recipPersonID 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 + fulfillsID <- insert $ PermitFulfillsInvite permitID + case inviteDB of + Left (_, _, inviteID) -> + insert_ $ PermitTopicGestureLocal fulfillsID inviteID + Right (author, _, inviteID) -> + insert_ $ PermitTopicGestureRemote fulfillsID (remoteAuthorId author) inviteID + -- Meaning: Someone removed someone from a resource -- Behavior: -- * Insert to my inbox diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs index 01f481a..9b1320e 100644 --- a/src/Vervis/Persist/Collab.hs +++ b/src/Vervis/Persist/Collab.hs @@ -33,6 +33,7 @@ module Vervis.Persist.Collab , getComponentIdent , checkExistingStems + , checkExistingPermits ) where @@ -508,3 +509,127 @@ checkExistingStems componentByID projectDB = do const () <$> MaybeT (getBy $ UniqueStemProjectAcceptLocalProject localID) Right remoteID -> const () <$> MaybeT (getBy $ UniqueStemProjectAcceptRemoteProject remoteID) + +checkExistingPermits + :: PersonId -> Either (LocalActorBy Key) RemoteActorId -> ActDBE () +checkExistingPermits personID topicDB = do + + -- Find existing Permit records I have for this topic + permitIDs <- lift $ getExistingPermits topicDB + + -- Grab all the enabled ones, make sure none are enabled, and even if + -- any are enabled, make sure there's at most one (otherwise it's a + -- bug) + byEnabled <- + lift $ for permitIDs $ \ (_, permit) -> + isJust <$> runMaybeT (tryPermitEnabled permit) + case length $ filter id byEnabled of + 0 -> return () + 1 -> throwE "I already have a PermitTopicEnable* for this topic" + _ -> error "Multiple PermitTopicEnable* for a topic" + + -- Verify none of the Permit records are already in Join or + -- Invite-and-Accept state + anyStarted <- + lift $ runMaybeT $ asum $ + map (\ (permitID, topic) -> + tryPermitJoin permitID <|> + tryPermitInviteAccept permitID topic + ) + permitIDs + unless (isNothing anyStarted) $ + throwE + "One of the Permit records is already in Join or Invite-Accept \ + \state" + + where + + getExistingPermits (Left (LocalActorPerson _)) = pure [] + getExistingPermits (Left (LocalActorRepo repoID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicRepoPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicRepoRepo E.==. E.val repoID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Left (LocalActorDeck deckID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicDeckPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicDeckDeck E.==. E.val deckID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Left (LocalActorLoom loomID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicLoomPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicLoomLoom E.==. E.val loomID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Left (LocalActorProject projectID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicProjectPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicProjectProject E.==. E.val projectID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Left (LocalActorGroup groupID)) = + fmap (map $ bimap E.unValue (Left . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` local `E.InnerJoin` topic) -> do + E.on $ local E.^. PermitTopicLocalId E.==. topic E.^. PermitTopicGroupPermit + E.on $ permit E.^. PermitId E.==. local E.^. PermitTopicLocalPermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + topic E.^. PermitTopicGroupGroup E.==. E.val groupID + return + ( permit E.^. PermitId + , local E.^. PermitTopicLocalId + ) + getExistingPermits (Right remoteActorID) = + fmap (map $ bimap E.unValue (Right . E.unValue)) $ + E.select $ E.from $ \ (permit `E.InnerJoin` remote) -> do + E.on $ permit E.^. PermitId E.==. remote E.^. PermitTopicRemotePermit + E.where_ $ + permit E.^. PermitPerson E.==. E.val personID E.&&. + remote E.^. PermitTopicRemoteActor E.==. E.val remoteActorID + return + ( permit E.^. PermitId + , remote E.^. PermitTopicRemoteId + ) + + tryPermitEnabled (Left localID) = + const () <$> MaybeT (getBy $ UniquePermitTopicEnableLocalTopic localID) + tryPermitEnabled (Right remoteID) = + const () <$> MaybeT (getBy $ UniquePermitTopicEnableRemoteTopic remoteID) + + tryPermitJoin permitID = do + _ <- MaybeT $ getBy $ UniquePermitFulfillsJoin permitID + pure () + + tryPermitInviteAccept permitID topic = do + _fulfillsID <- MaybeT $ getKeyBy $ UniquePermitFulfillsInvite permitID + case topic of + Left localID -> + const () <$> MaybeT (getBy $ UniquePermitTopicAcceptLocalTopic localID) + Right remoteID -> + const () <$> MaybeT (getBy $ UniquePermitTopicAcceptRemoteTopic remoteID)