From 048c429def90ef29bf0ddc1b0a63c50d087df282 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Thu, 4 Apr 2024 11:54:13 +0300 Subject: [PATCH] S2S: Project: Remove: Implement child/parent mode --- migrations/578_2024-04-03_source_remove.model | 6 + src/Control/Monad/Trans/Except/Local.hs | 9 +- src/Vervis/Actor/Project.hs | 1147 ++++++++++++++--- src/Vervis/Federation/Util.hs | 70 +- src/Vervis/Migration.hs | 4 +- src/Vervis/Migration/Entities.hs | 4 + th/models | 12 + 7 files changed, 1021 insertions(+), 231 deletions(-) create mode 100644 migrations/578_2024-04-03_source_remove.model diff --git a/migrations/578_2024-04-03_source_remove.model b/migrations/578_2024-04-03_source_remove.model new file mode 100644 index 0000000..e8dca93 --- /dev/null +++ b/migrations/578_2024-04-03_source_remove.model @@ -0,0 +1,6 @@ +SourceRemove + send SourceUsSendDelegatorId + activity InboxItemId + + UniqueSourceRemove send + UniqueSourceRemoveActivity activity diff --git a/src/Control/Monad/Trans/Except/Local.hs b/src/Control/Monad/Trans/Except/Local.hs index 47bf0a4..0fda22c 100644 --- a/src/Control/Monad/Trans/Except/Local.hs +++ b/src/Control/Monad/Trans/Except/Local.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2022 by fr33domlover . + - Written in 2019, 2022, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -17,6 +17,7 @@ module Control.Monad.Trans.Except.Local ( fromMaybeE , verifyNothingE , nameExceptT + , verifySingleE ) where @@ -33,3 +34,9 @@ verifyNothingE (Just _) e = throwE e nameExceptT :: Functor m => Text -> ExceptT Text m a -> ExceptT Text m a nameExceptT title = withExceptT $ \ e -> title <> ": " <> e + +verifySingleE list none several = + case list of + [] -> throwE none + [x] -> pure x + _ -> throwE several diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 6174e5e..f91a607 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -1445,7 +1445,7 @@ projectAdd now projectID (Verse authorIdMsig body) add = do uCap authorIdMsig (LocalActorProject projectID) - AP.RoleTriage + AP.RoleAdmin maybeNew <- withDBExcept $ do @@ -3580,17 +3580,45 @@ projectReject -> ActE (Text, Act (), Next) projectReject = topicReject projectActor LocalActorProject --- Meaning: An actor A is removing actor B from a resource +-- Meaning: An actor A is removing actor B from collection C -- Behavior: --- * Verify the resource is me --- * Verify A isn't removing themselves --- * Verify A is authorized by me to remove actors from me --- * Verify B already has a Grant for me --- * Remove the whole Collab record from DB --- * Forward the Remove to my followers --- * Send a Revoke: --- * To: Actor B --- * CC: Actor A, B's followers, my followers +-- * If C is my collaborators collection: +-- * Verify A isn't removing themselves +-- * Verify A is authorized by me to remove actors from me +-- * Verify B already has a Grant for me +-- * Remove the whole Collab record from DB +-- * Forward the Remove to my followers +-- * Send a Revoke: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +-- * If C is my children collection: +-- * Verify A isn't removing themselves +-- * Verify A is authorized by me to remove actors from me +-- * Verify B is an active child of mine +-- * Remove the whole Source record from DB +-- * Forward the Remove to my followers +-- * Send a Revoke on the delegator-Grant I had for B: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +-- * Send a Revoke on every extention-Grant I extended on every +-- delegation Grant I got from B +-- * To: The parent/collaborator/team to whom I'd sent the Grant +-- * CC: - +-- * If C is my parents collection: +-- * Verify A isn't removing themselves +-- * Verify A is authorized by me to remove actors from me +-- * Verify B is an active parent of mine +-- * Remove the whole Dest record from DB +-- * Forward the Remove to my followers +-- * Send an Accept on the Remove: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +-- * If I'm B, being removed from the parents of a child of mine: +-- * Record this Remove in the Source record +-- * Forward to followers +-- * If I'm B, being removed from the children of a parent of mine: +-- * Do nothing, just waiting for parent to send a Revoke on the +-- delegator-Grant projectRemove :: UTCTime -> ProjectId @@ -3599,209 +3627,920 @@ projectRemove -> ActE (Text, Act (), Next) projectRemove now projectID (Verse authorIdMsig body) remove = do - -- Check remove - memberByKey <- do - let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig - (resource, memberOrComp) <- parseRemove author remove - unless (Left (Left $ LocalActorProject projectID) == resource) $ - throwE "Remove topic isn't my collabs URI" - bitraverse - (\case - LocalActorPerson p -> pure p - _ -> throwE "Not accepting non-person actors as collabs" - ) - pure - memberOrComp - - -- Verify the specified capability gives relevant access - uCap <- do - let muCap = AP.activityCapability $ actbActivity body - fromMaybeE muCap "No capability provided" - verifyCapability'' - uCap - authorIdMsig - (LocalActorProject projectID) - AP.RoleAdmin - - maybeNew <- withDBExcept $ do - - -- Find member in our DB - memberDB <- - bitraverse - (flip getEntityE "Member not found in DB") - (\ u@(ObjURI h lu) -> (,u) <$> do - maybeActor <- lift $ runMaybeT $ do - iid <- MaybeT $ getKeyBy $ UniqueInstance h - roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu - MaybeT $ getBy $ UniqueRemoteActor roid - fromMaybeE maybeActor "Remote removee not found in DB" - ) - memberByKey - - -- Grab me from DB - (topicActorID, topicActor) <- lift $ do - recip <- getJust projectID - let actorID = projectActor recip - (actorID,) <$> getJust actorID - - -- Find the collab that the member already has for me - existingCollabIDs <- - lift $ case memberDB of - Left (Entity personID _) -> - fmap (map $ over _2 Left) $ - E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do - E.on $ - topic E.^. CollabTopicProjectCollab E.==. - recipl E.^. CollabRecipLocalCollab - E.where_ $ - topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. - recipl E.^. CollabRecipLocalPerson E.==. E.val personID - return - ( topic E.^. persistIdField - , recipl E.^. persistIdField - , recipl E.^. CollabRecipLocalCollab - ) - Right (Entity remoteActorID _, _) -> - fmap (map $ over _2 Right) $ - E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do - E.on $ - topic E.^. CollabTopicProjectCollab E.==. - recipr E.^. CollabRecipRemoteCollab - E.where_ $ - topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. - recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID - return - ( topic E.^. persistIdField - , recipr E.^. persistIdField - , recipr E.^. CollabRecipRemoteCollab - ) - (E.Value topicID, recipID, E.Value collabID) <- - case existingCollabIDs of - [] -> throwE "Remove object isn't a member of me" - [collab] -> return collab - _ -> error "Multiple collabs found for removee" - - -- Verify the Collab is enabled - maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID - Entity enableID (CollabEnable _ grantID) <- - fromMaybeE maybeEnabled "Remove object isn't a member of me yet" - - -- Verify that at least 1 more enabled Admin collab for me exists - otherCollabIDs <- - lift $ E.select $ E.from $ \ (topic `E.InnerJoin` enable) -> do - E.on $ - topic E.^. CollabTopicProjectCollab E.==. - enable E.^. CollabEnableCollab - E.where_ $ - topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. - topic E.^. CollabTopicProjectCollab E.!=. E.val collabID - return $ topic E.^. CollabTopicProjectCollab - when (null otherCollabIDs) $ - throwE "No other admins exist, can't remove" - - maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False - lift $ for maybeRemoveDB $ \ _removeDB -> do - - -- Delete the whole Collab record - deleteBy $ UniqueCollabDelegLocal enableID - deleteBy $ UniqueCollabDelegRemote enableID - delete enableID - case recipID of - Left (E.Value l) -> do - deleteBy $ UniqueCollabRecipLocalJoinCollab l - deleteBy $ UniqueCollabRecipLocalAcceptCollab l - delete l - Right (E.Value r) -> do - deleteBy $ UniqueCollabRecipRemoteJoinCollab r - deleteBy $ UniqueCollabRecipRemoteAcceptCollab r - delete r - delete topicID - fulfills <- do - mf <- runMaybeT $ asum - [ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID) - , Right . Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsInvite collabID) - , Right . Right <$> MaybeT (getKeyBy $ UniqueCollabFulfillsJoin collabID) - ] - maybe (error $ "No fulfills for collabID#" ++ show collabID) pure mf - case fulfills of - Left fc -> delete fc - Right (Left fi) -> do - deleteBy $ UniqueCollabInviterLocal fi - deleteBy $ UniqueCollabInviterRemote fi - delete fi - Right (Right fj) -> do - deleteBy $ UniqueCollabApproverLocal fj - deleteBy $ UniqueCollabApproverRemote fj - delete fj - delete collabID - - -- Prepare forwarding Remove to my followers - sieve <- lift $ do - topicHash <- encodeKeyHashid projectID - let topicByHash = - LocalActorProject topicHash - return $ makeRecipientSet [] [localActorFollowers topicByHash] - - -- Prepare a Revoke activity and insert to my outbox - revoke@(actionRevoke, _, _, _) <- - lift $ prepareRevoke memberDB grantID - let recipByKey = LocalActorProject projectID - revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now - _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke - - return (topicActorID, sieve, revokeID, revoke) - - case maybeNew of - Nothing -> done "I already have this activity in my inbox" - Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) -> do - let topicByID = LocalActorProject projectID - forwardActivity authorIdMsig body topicByID topicActorID sieve - lift $ sendActivity - topicByID topicActorID localRecipsRevoke - remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke - done "Deleted the Grant/Collab, forwarded Remove, sent Revoke" + let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig + (collection, item) <- parseRemove author remove + case (collection, item) of + (Left (Left (LocalActorProject j)), _) | j == projectID -> + removeCollab item + (Left (Right (ATProjectChildren j)), _) | j == projectID -> + removeChildActive item + (Left (Right (ATProjectParents j)), _) | j == projectID -> + removeParentActive item + (_, Left (LocalActorProject j)) | j == projectID -> + case collection of + Left (Right (ATProjectParents j)) | j /= projectID -> + removeChildPassive $ Left j + Left (Right (ATProjectChildren j)) | j /= projectID -> + removeParentPassive $ Left j + 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) -> + removeParentPassive $ Right $ ObjURI h lu + (False, True) -> + removeChildPassive $ Right $ ObjURI h lu + _ -> throwE "Weird collection situation" + _ -> throwE "I'm being removed from somewhere irrelevant" + _ -> throwE "This Remove isn't for me" where - prepareRevoke member grantID = do - encodeRouteHome <- getEncodeRouteHome - encodeRouteLocal <- getEncodeRouteLocal + removeCollab member = do - recipHash <- encodeKeyHashid projectID - let topicByHash = LocalActorProject recipHash + -- Check remove + memberByKey <- + bitraverse + (\case + LocalActorPerson p -> pure p + _ -> throwE "Not accepting non-person actors as collabs" + ) + pure + member - memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member + -- Verify the specified capability gives relevant access + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + verifyCapability'' + uCap + authorIdMsig + (LocalActorProject projectID) + AP.RoleAdmin - audRemover <- makeAudSenderOnly authorIdMsig - let audience = - let audMember = - case memberHash of - Left p -> - AudLocal [LocalActorPerson p] [LocalStagePersonFollowers p] - Right (Entity _ actor, ObjURI h lu) -> - AudRemote h [lu] (maybeToList $ remoteActorFollowers actor) - audTopic = AudLocal [] [localActorFollowers topicByHash] - in [audRemover, audMember, audTopic] + maybeNew <- withDBExcept $ do - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience audience + -- Find member in our DB + memberDB <- + bitraverse + (flip getEntityE "Member not found in DB") + (\ u@(ObjURI h lu) -> (,u) <$> do + maybeActor <- lift $ runMaybeT $ do + iid <- MaybeT $ getKeyBy $ UniqueInstance h + roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu + MaybeT $ getBy $ UniqueRemoteActor roid + fromMaybeE maybeActor "Remote removee not found in DB" + ) + memberByKey - recips = map encodeRouteHome audLocal ++ audRemote - uRemove <- getActivityURI authorIdMsig - luGrant <- do - grantHash <- encodeKeyHashid grantID - return $ encodeRouteLocal $ activityRoute topicByHash grantHash - let action = AP.Action - { AP.actionCapability = Nothing - , AP.actionSummary = Nothing - , AP.actionAudience = AP.Audience recips [] [] [] [] [] - , AP.actionFulfills = [uRemove] - , AP.actionSpecific = AP.RevokeActivity AP.Revoke - { AP.revokeObject = luGrant :| [] + -- Grab me from DB + (topicActorID, topicActor) <- lift $ do + recip <- getJust projectID + let actorID = projectActor recip + (actorID,) <$> getJust actorID + + -- Find the collab that the member already has for me + existingCollabIDs <- + lift $ case memberDB of + Left (Entity personID _) -> + fmap (map $ over _2 Left) $ + E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do + E.on $ + topic E.^. CollabTopicProjectCollab E.==. + recipl E.^. CollabRecipLocalCollab + E.where_ $ + topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. + recipl E.^. CollabRecipLocalPerson E.==. E.val personID + return + ( topic E.^. persistIdField + , recipl E.^. persistIdField + , recipl E.^. CollabRecipLocalCollab + ) + Right (Entity remoteActorID _, _) -> + fmap (map $ over _2 Right) $ + E.select $ E.from $ \ (topic `E.InnerJoin` recipr) -> do + E.on $ + topic E.^. CollabTopicProjectCollab E.==. + recipr E.^. CollabRecipRemoteCollab + E.where_ $ + topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. + recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID + return + ( topic E.^. persistIdField + , recipr E.^. persistIdField + , recipr E.^. CollabRecipRemoteCollab + ) + (E.Value topicID, recipID, E.Value collabID) <- + case existingCollabIDs of + [] -> throwE "Remove object isn't a member of me" + [collab] -> return collab + _ -> error "Multiple collabs found for removee" + + -- Verify the Collab is enabled + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + Entity enableID (CollabEnable _ grantID) <- + fromMaybeE maybeEnabled "Remove object isn't a member of me yet" + + -- Verify that at least 1 more enabled Admin collab for me exists + otherCollabIDs <- + lift $ E.select $ E.from $ \ (topic `E.InnerJoin` enable) -> do + E.on $ + topic E.^. CollabTopicProjectCollab E.==. + enable E.^. CollabEnableCollab + E.where_ $ + topic E.^. CollabTopicProjectProject E.==. E.val projectID E.&&. + topic E.^. CollabTopicProjectCollab E.!=. E.val collabID + return $ topic E.^. CollabTopicProjectCollab + when (null otherCollabIDs) $ + throwE "No other admins exist, can't remove" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False + lift $ for maybeRemoveDB $ \ _removeDB -> do + + -- Delete the whole Collab record + deleteBy $ UniqueCollabDelegLocal enableID + deleteBy $ UniqueCollabDelegRemote enableID + delete enableID + case recipID of + Left (E.Value l) -> do + deleteBy $ UniqueCollabRecipLocalJoinCollab l + deleteBy $ UniqueCollabRecipLocalAcceptCollab l + delete l + Right (E.Value r) -> do + deleteBy $ UniqueCollabRecipRemoteJoinCollab r + deleteBy $ UniqueCollabRecipRemoteAcceptCollab r + delete r + delete topicID + fulfills <- do + mf <- runMaybeT $ asum + [ Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsLocalTopicCreation collabID) + , Right . Left <$> MaybeT (getKeyBy $ UniqueCollabFulfillsInvite collabID) + , Right . Right <$> MaybeT (getKeyBy $ UniqueCollabFulfillsJoin collabID) + ] + maybe (error $ "No fulfills for collabID#" ++ show collabID) pure mf + case fulfills of + Left fc -> delete fc + Right (Left fi) -> do + deleteBy $ UniqueCollabInviterLocal fi + deleteBy $ UniqueCollabInviterRemote fi + delete fi + Right (Right fj) -> do + deleteBy $ UniqueCollabApproverLocal fj + deleteBy $ UniqueCollabApproverRemote fj + delete fj + delete collabID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid projectID + let topicByHash = + LocalActorProject topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + -- Prepare a Revoke activity and insert to my outbox + revoke@(actionRevoke, _, _, _) <- + lift $ prepareRevoke memberDB grantID + let recipByKey = LocalActorProject projectID + revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now + _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke + + return (topicActorID, sieve, revokeID, revoke) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke)) -> do + let topicByID = LocalActorProject projectID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ sendActivity + topicByID topicActorID localRecipsRevoke + remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke + done "Deleted the Grant/Collab, forwarded Remove, sent Revoke" + + where + + prepareRevoke member grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + recipHash <- encodeKeyHashid projectID + let topicByHash = LocalActorProject recipHash + + memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member + + audRemover <- makeAudSenderOnly authorIdMsig + let audience = + let audMember = + case memberHash of + Left p -> + AudLocal [LocalActorPerson p] [LocalStagePersonFollowers p] + Right (Entity _ actor, ObjURI h lu) -> + AudRemote h [lu] (maybeToList $ remoteActorFollowers actor) + audTopic = AudLocal [] [localActorFollowers topicByHash] + in [audRemover, audMember, audTopic] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience audience + + recips = map encodeRouteHome audLocal ++ audRemote + uRemove <- getActivityURI authorIdMsig + luGrant <- do + grantHash <- encodeKeyHashid grantID + return $ encodeRouteLocal $ activityRoute topicByHash grantHash + let action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.RevokeActivity AP.Revoke + { AP.revokeObject = luGrant :| [] + } } - } - return (action, recipientSet, remoteActors, fwdHosts) + return (action, recipientSet, remoteActors, fwdHosts) + + removeChildActive child = do + + -- If child is local, find it in our DB + -- If child is remote, HTTP GET it, verify it's an actor of Project + -- 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. + childDB <- + bitraverse + (\case + LocalActorProject j -> withDBExcept $ getEntityE j "Child not found in DB" + _ -> throwE "Local proposed child of non-project type" + ) + (\ 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 "Child @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Child isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeProject -> pure () + _ -> throwE "Remote child type isn't Project" + return (u, actor) + ) + child + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the sender is authorized by me to remove a child + verifyCapability'' + uCap + authorIdMsig + (LocalActorProject projectID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + -- Verify it's an active child of mine + sources <- lift $ case childDB of + Left (Entity j _) -> + fmap (map $ \ (s, h, d, E.Value a, E.Value t, E.Value i) -> (s, h, d, Left (a, t, i))) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicProjectTopic E.==. accept E.^. SourceThemAcceptLocalTopic + E.on $ holder E.^. SourceHolderProjectId E.==. topic E.^. SourceTopicProjectHolder + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource + E.where_ $ + holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&. + topic E.^. SourceTopicProjectChild E.==. E.val j + return + ( source E.^. SourceId + , holder E.^. SourceHolderProjectId + , send + , accept E.^. SourceThemAcceptLocalId + , topic E.^. SourceTopicProjectTopic + , topic E.^. SourceTopicProjectId + ) + Right (_, Entity a _) -> + fmap (map $ \ (s, h, d, E.Value a, E.Value t) -> (s, h, d, Right (a, t))) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic + E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource + E.where_ $ + holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&. + topic E.^. SourceTopicRemoteTopic E.==. E.val a + return + ( source E.^. SourceId + , holder E.^. SourceHolderProjectId + , send + , accept E.^. SourceThemAcceptRemoteId + , topic E.^. SourceTopicRemoteId + ) + (E.Value sourceID, E.Value holderID, Entity sendID (SourceUsSendDelegator _ grantID), topic) <- + verifySingleE sources "No source" "Multiple sources" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRemoveDB $ \ _removeDB -> do + + -- Grab extension-Grants that I'm about to revoke + gathers <- selectList [SourceUsGatherSource ==. sendID] [] + leafs <- selectList [SourceUsLeafSource ==. sendID] [] + + -- Delete the whole Source record + deleteWhere [SourceRemoveSend ==. sendID] + let gatherIDs = map entityKey gathers + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherToLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + let leafIDs = map entityKey leafs + deleteWhere [SourceUsLeafFromLocalLeaf <-. leafIDs] + deleteWhere [SourceUsLeafFromRemoteLeaf <-. leafIDs] + deleteWhere [SourceUsLeafToLocalLeaf <-. leafIDs] + deleteWhere [SourceUsLeafToRemoteLeaf <-. leafIDs] + case topic of + Left (localID, _, _) -> do + deleteWhere [SourceThemDelegateLocalSource ==. localID] + delete localID + Right (remoteID, _) -> do + deleteWhere [SourceThemDelegateRemoteSource ==. remoteID] + delete remoteID + delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueSourceOriginUs sourceID) + (getKeyBy $ UniqueSourceOriginThem sourceID) + "Neither us nor them" + "Both us and them" + case origin of + Left usID -> do + deleteBy $ UniqueSourceUsAccept usID + deleteBy $ UniqueSourceUsGestureLocal usID + deleteBy $ UniqueSourceUsGestureRemote usID + delete usID + Right themID -> do + deleteBy $ UniqueSourceThemGestureLocal themID + deleteBy $ UniqueSourceThemGestureRemote themID + delete themID + case topic of + Left (_, l, j) -> delete j >> delete l + Right (_, r) -> delete r + delete holderID + delete sourceID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid projectID + let topicByHash = + LocalActorProject topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + -- Prepare main Revoke activity and insert to my outbox + revoke@(actionRevoke, _, _, _) <- + lift $ prepareMainRevoke childDB grantID + let recipByKey = LocalActorProject projectID + revokeID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke + + -- Prepare and insert Revokes on all the extension-Grants + revokesG <- for gathers $ \ (Entity _ (SourceUsGather _ acceptID grantID)) -> do + DestUsAccept destID _ <- getJust acceptID + parent <- do + p <- getDestTopic destID + bitraverse + (\case + Left j -> pure $ LocalActorProject j + Right _ -> error "I'm a project but I have a parent who is a Group" + ) + pure + (bimap snd snd p) + return (parent, grantID) + revokesL <- for leafs $ \ (Entity _ (SourceUsLeaf _ enableID grantID)) -> do + CollabEnable collabID _ <- getJust enableID + recip <- getCollabRecip collabID + return + ( bimap + (LocalActorPerson . collabRecipLocalPerson . entityVal) + (collabRecipRemoteActor . entityVal) + recip + , grantID + ) + revokes <- for (revokesG ++ revokesL) $ \ (actor, grantID) -> do + ext@(actionExt, _, _, _) <- prepareExtRevoke actor grantID + let recipByKey = LocalActorProject projectID + extID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luExt <- updateOutboxItem' recipByKey extID actionExt + return (extID, ext) + + return (projectActor project, sieve, revokeID, revoke, revokes) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), revokes) -> do + let topicByID = LocalActorProject projectID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ do + sendActivity + topicByID topicActorID localRecipsRevoke + remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke + for_ revokes $ \ (extID, (actionExt, localRecipsExt, remoteRecipsExt, fwdHostsExt)) -> + sendActivity + topicByID topicActorID localRecipsExt + remoteRecipsExt fwdHostsExt extID actionExt + done "Deleted the Child/Source, forwarded Remove, sent Revokes" + + where + + prepareMainRevoke child grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + recipHash <- encodeKeyHashid projectID + let topicByHash = LocalActorProject recipHash + + childHash <- bitraverse (encodeKeyHashid . entityKey) pure child + + audRemover <- makeAudSenderOnly authorIdMsig + let audChild = + case childHash of + Left j -> + AudLocal [LocalActorProject j] [LocalStageProjectFollowers j] + Right (ObjURI h lu, Entity _ actor) -> + AudRemote h [lu] (maybeToList $ remoteActorFollowers actor) + audMe = AudLocal [] [localActorFollowers topicByHash] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audRemover, audChild, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + + uRemove <- getActivityURI authorIdMsig + luGrant <- do + grantHash <- encodeKeyHashid grantID + return $ encodeRouteLocal $ activityRoute topicByHash grantHash + let action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.RevokeActivity AP.Revoke + { AP.revokeObject = luGrant :| [] + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + prepareExtRevoke recipient grantID = do + encodeRouteHome <- getEncodeRouteHome + encodeRouteLocal <- getEncodeRouteLocal + + projectHash <- encodeKeyHashid projectID + let topicByHash = LocalActorProject projectHash + + audRecip <- + case recipient of + Left a -> do + h <- hashLocalActor a + return $ AudLocal [h] [localActorFollowers h] + Right actorID -> do + actor <- getJust actorID + ObjURI h lu <- getRemoteActorURI actor + return $ + AudRemote h [lu] (maybeToList $ remoteActorFollowers actor) + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audRecip] + + recips = map encodeRouteHome audLocal ++ audRemote + + uRemove <- lift $ getActivityURI authorIdMsig + luGrant <- do + grantHash <- encodeKeyHashid grantID + return $ encodeRouteLocal $ activityRoute topicByHash grantHash + let action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.RevokeActivity AP.Revoke + { AP.revokeObject = luGrant :| [] + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + removeParentActive parent = do + + -- If parent is local, find it in our DB + -- If parent is remote, HTTP GET it, verify it's an actor of Project + -- 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. + parentDB <- + bitraverse + (\case + LocalActorProject j -> withDBExcept $ getEntityE j "Parent not found in DB" + _ -> throwE "Local proposed parent of non-project type" + ) + (\ 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 "Parent @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Parent isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeProject -> pure () + _ -> throwE "Remote parent type isn't Project" + return (u, actor) + ) + parent + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the sender is authorized by me to remove a parent + verifyCapability'' + uCap + authorIdMsig + (LocalActorProject projectID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + -- Verify it's an active child of mine + dests <- lift $ case parentDB of + Left (Entity j _) -> + fmap (map $ \ (d, h, a, E.Value l, E.Value t, E.Value s) -> (d, h, a, Left (l, t, s))) $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do + E.on $ topic E.^. DestTopicProjectTopic E.==. send E.^. DestThemSendDelegatorLocalTopic + E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest + E.where_ $ + holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&. + topic E.^. DestTopicProjectParent E.==. E.val j + return + ( dest E.^. DestId + , holder E.^. DestHolderProjectId + , send E.^. DestThemSendDelegatorLocalDest + , topic E.^. DestTopicProjectTopic + , topic E.^. DestTopicProjectId + , send E.^. DestThemSendDelegatorLocalId + ) + Right (_, Entity a _) -> + fmap (map $ \ (d, h, a, E.Value t, E.Value s) -> (d, h, a, Right (t, s))) $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do + E.on $ topic E.^. DestTopicRemoteId E.==. send E.^. DestThemSendDelegatorRemoteTopic + E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest + E.where_ $ + holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&. + topic E.^. DestTopicRemoteTopic E.==. E.val a + return + ( dest E.^. DestId + , holder E.^. DestHolderProjectId + , send E.^. DestThemSendDelegatorRemoteDest + , topic E.^. DestTopicRemoteId + , send E.^. DestThemSendDelegatorRemoteId + ) + + (E.Value destID, E.Value holderID, E.Value usAcceptID, topic) <- + verifySingleE dests "No dest" "Multiple dests" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRemoveDB $ \ _removeDB -> do + + -- Delete uses of this Dest from my Component records + case topic of + Left (_, _, sendID) -> + deleteWhere [ComponentGatherLocalParent ==. sendID] + Right (_, sendID) -> + deleteWhere [ComponentGatherRemoteParent ==. sendID] + + -- Delete uses of this Dest from my Source records + case topic of + Left (_, _, sendID) -> do + gatherIDs <- + map (sourceUsGatherToLocalGather . entityVal) <$> + selectList [SourceUsGatherToLocalTo ==. sendID] [] + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherToLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + Right (_, sendID) -> do + gatherIDs <- + map (sourceUsGatherToRemoteGather . entityVal) <$> + selectList [SourceUsGatherToRemoteTo ==. sendID] [] + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + + -- Delete the whole Dest record + case topic of + Left (_, _, sendID) -> delete sendID + Right (_, sendID) -> delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueDestOriginUs destID) + (getKeyBy $ UniqueDestOriginThem destID) + "Neither us nor them" + "Both us and them" + deleteBy $ UniqueDestUsGestureLocal destID + deleteBy $ UniqueDestUsGestureRemote destID + case origin of + Left usID -> delete usID + Right themID -> do + deleteBy $ UniqueDestThemAcceptLocal themID + deleteBy $ UniqueDestThemAcceptRemote themID + deleteBy $ UniqueDestThemGestureLocal themID + deleteBy $ UniqueDestThemGestureRemote themID + delete themID + delete usAcceptID + case topic of + Left (l, j, _) -> delete j >> delete l + Right (r, _) -> delete r + delete holderID + delete destID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid projectID + let topicByHash = + LocalActorProject topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + -- Prepare Accept activity + accept@(actionAccept, _, _, _) <- prepareAccept parentDB + let recipByKey = LocalActorProject projectID + acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + + return (projectActor project, sieve, acceptID, accept) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + let topicByID = LocalActorProject projectID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ + sendActivity + topicByID topicActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + done "Deleted the Parent/Dest, forwarded Remove, sent Accept" + + where + + prepareAccept parentDB = do + encodeRouteHome <- getEncodeRouteHome + + audRemover <- lift $ makeAudSenderOnly authorIdMsig + audParent <- + case parentDB of + Left (Entity j _) -> do + h <- encodeKeyHashid j + return $ AudLocal [LocalActorProject h] [LocalStageProjectFollowers h] + Right (ObjURI h lu, Entity _ ra) -> + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audMe <- + AudLocal [] . pure . LocalStageProjectFollowers <$> + encodeKeyHashid projectID + uRemove <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audRemover, audParent, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uRemove + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + removeChildPassive child = do + + -- If child is local, find it in our DB + -- If child is remote, HTTP GET it, verify it's an actor of Project + -- 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. + childDB <- + bitraverse + (\ j -> withDBExcept $ getEntityE j "Child 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 "Child @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Child isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeProject -> pure () + _ -> throwE "Remote child type isn't Project" + return (u, actor) + ) + child + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + -- Verify it's an active child of mine + sources <- lift $ case childDB of + Left (Entity j _) -> + fmap (map $ \ (s, h, d, E.Value a, E.Value t, E.Value i) -> (s, h, d, Left (a, t, i))) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicProjectTopic E.==. accept E.^. SourceThemAcceptLocalTopic + E.on $ holder E.^. SourceHolderProjectId E.==. topic E.^. SourceTopicProjectHolder + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource + E.where_ $ + holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&. + topic E.^. SourceTopicProjectChild E.==. E.val j + return + ( source E.^. SourceId + , holder E.^. SourceHolderProjectId + , send + , accept E.^. SourceThemAcceptLocalId + , topic E.^. SourceTopicProjectTopic + , topic E.^. SourceTopicProjectId + ) + Right (_, Entity a _) -> + fmap (map $ \ (s, h, d, E.Value a, E.Value t) -> (s, h, d, Right (a, t))) $ + E.select $ E.from $ \ (source `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` accept `E.InnerJoin` send) -> do + E.on $ source E.^. SourceId E.==. send E.^. SourceUsSendDelegatorSource + E.on $ topic E.^. SourceTopicRemoteId E.==. accept E.^. SourceThemAcceptRemoteTopic + E.on $ source E.^. SourceId E.==. topic E.^. SourceTopicRemoteSource + E.on $ source E.^. SourceId E.==. holder E.^. SourceHolderProjectSource + E.where_ $ + holder E.^. SourceHolderProjectProject E.==. E.val projectID E.&&. + topic E.^. SourceTopicRemoteTopic E.==. E.val a + return + ( source E.^. SourceId + , holder E.^. SourceHolderProjectId + , send + , accept E.^. SourceThemAcceptRemoteId + , topic E.^. SourceTopicRemoteId + ) + (E.Value sourceID, E.Value holderID, Entity sendID (SourceUsSendDelegator _ grantID), topic) <- + verifySingleE sources "No source" "Multiple sources" + + maybeRemoveDB <- lift $ insertToInbox' now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRemoveDB $ \ (removeID, _) -> do + + -- Record the removal attempt + insert_ $ SourceRemove sendID removeID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid projectID + let topicByHash = + LocalActorProject topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + return (projectActor project, sieve) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve) -> do + let topicByID = LocalActorProject projectID + forwardActivity authorIdMsig body topicByID topicActorID sieve + done "Recorded removal attempt, forwarded Remove" + + removeParentPassive parent = do + + -- If parent is local, find it in our DB + -- If parent is remote, HTTP GET it, verify it's an actor of Project + -- 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. + parentDB <- + bitraverse + (\ j -> withDBExcept $ getEntityE j "Parent 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 "Parent @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Parent isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeProject -> pure () + _ -> throwE "Remote parent type isn't Project" + return (u, actor) + ) + parent + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + -- Verify it's an active parent of mine + dests <- lift $ case parentDB of + Left (Entity j _) -> + fmap (map $ \ (d, h, a, E.Value l, E.Value t, E.Value s) -> (d, h, a, Left (l, t, s))) $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do + E.on $ topic E.^. DestTopicProjectTopic E.==. send E.^. DestThemSendDelegatorLocalTopic + E.on $ holder E.^. DestHolderProjectId E.==. topic E.^. DestTopicProjectHolder + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest + E.where_ $ + holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&. + topic E.^. DestTopicProjectParent E.==. E.val j + return + ( dest E.^. DestId + , holder E.^. DestHolderProjectId + , send E.^. DestThemSendDelegatorLocalDest + , topic E.^. DestTopicProjectTopic + , topic E.^. DestTopicProjectId + , send E.^. DestThemSendDelegatorLocalId + ) + Right (_, Entity a _) -> + fmap (map $ \ (d, h, a, E.Value t, E.Value s) -> (d, h, a, Right (t, s))) $ + E.select $ E.from $ \ (dest `E.InnerJoin` holder `E.InnerJoin` topic `E.InnerJoin` send) -> do + E.on $ topic E.^. DestTopicRemoteId E.==. send E.^. DestThemSendDelegatorRemoteTopic + E.on $ dest E.^. DestId E.==. topic E.^. DestTopicRemoteDest + E.on $ dest E.^. DestId E.==. holder E.^. DestHolderProjectDest + E.where_ $ + holder E.^. DestHolderProjectProject E.==. E.val projectID E.&&. + topic E.^. DestTopicRemoteTopic E.==. E.val a + return + ( dest E.^. DestId + , holder E.^. DestHolderProjectId + , send E.^. DestThemSendDelegatorRemoteDest + , topic E.^. DestTopicRemoteId + , send E.^. DestThemSendDelegatorRemoteId + ) + + (E.Value destID, E.Value holderID, E.Value usAcceptID, topic) <- + verifySingleE dests "No dest" "Multiple dests" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRemoveDB $ \ _removeDB -> do + + return () + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just () -> + done "Saw the removal attempt, just waiting for the Revoke" -- Meaning: An actor is undoing some previous action -- Behavior: diff --git a/src/Vervis/Federation/Util.hs b/src/Vervis/Federation/Util.hs index 8045df0..954b032 100644 --- a/src/Vervis/Federation/Util.hs +++ b/src/Vervis/Federation/Util.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2023 by fr33domlover . + - Written in 2019, 2020, 2023, 2024 by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. - @@ -15,6 +15,7 @@ module Vervis.Federation.Util ( insertToInbox + , insertToInbox' ) where @@ -38,6 +39,47 @@ import Vervis.Model -- | Insert an activity delivered to us into our inbox. Return its -- database ID if the activity wasn't already in our inbox. +insertToInbox' + :: UTCTime + -> Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) + -> ActivityBody + -> InboxId + -> Bool + -> ActDB + (Maybe + ( InboxItemId + , Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, RemoteActivityId) + ) + ) +insertToInbox' now (Left a@(_, _, outboxItemID)) _body inboxID unread = do + inboxItemID <- insert $ InboxItem unread now + maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID + case maybeItem of + Nothing -> do + delete inboxItemID + return Nothing + Just _ -> return $ Just (inboxItemID, Left a) +insertToInbox' now (Right (author, luAct, _)) body inboxID unread = do + let iidAuthor = remoteAuthorInstance author + roid <- + either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct) + ractid <- either entityKey id <$> insertBy' RemoteActivity + { remoteActivityIdent = roid + , remoteActivityContent = persistJSONFromBL $ actbBL body + , remoteActivityReceived = now + } + ibiid <- insert $ InboxItem unread now + mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid + case mibrid of + Nothing -> do + delete ibiid + return Nothing + Just _ -> return $ Just (ibiid, Right (author, luAct, ractid)) + insertToInbox :: UTCTime -> Either @@ -53,27 +95,5 @@ insertToInbox (RemoteAuthor, LocalURI, RemoteActivityId) ) ) -insertToInbox now (Left a@(_, _, outboxItemID)) _body inboxID unread = do - inboxItemID <- insert $ InboxItem unread now - maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID - case maybeItem of - Nothing -> do - delete inboxItemID - return Nothing - Just _ -> return $ Just $ Left a -insertToInbox now (Right (author, luAct, _)) body inboxID unread = do - let iidAuthor = remoteAuthorInstance author - roid <- - either entityKey id <$> insertBy' (RemoteObject iidAuthor luAct) - ractid <- either entityKey id <$> insertBy' RemoteActivity - { remoteActivityIdent = roid - , remoteActivityContent = persistJSONFromBL $ actbBL body - , remoteActivityReceived = now - } - ibiid <- insert $ InboxItem unread now - mibrid <- insertUnique $ InboxItemRemote inboxID ractid ibiid - case mibrid of - Nothing -> do - delete ibiid - return Nothing - Just _ -> return $ Just $ Right (author, luAct, ractid) +insertToInbox now act body inbox unread = + fmap snd <$> insertToInbox' now act body inbox unread diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 58ddbe0..ded9455 100644 --- a/src/Vervis/Migration.hs +++ b/src/Vervis/Migration.hs @@ -1,6 +1,6 @@ {- This file is part of Vervis. - - - Written in 2016, 2018, 2019, 2020, 2021, 2022, 2023 + - Written in 2016, 2018, 2019, 2020, 2021, 2022, 2023, 2024 - by fr33domlover . - - ♡ Copying is an act of love. Please copy, reuse and share. @@ -3212,6 +3212,8 @@ changes hLocal ctx = , addUnique' "SourceThemDelegateRemote" "" ["source", "grant"] -- 577 , addEntities model_577_component_gather + -- 578 + , addEntities model_578_source_remove ] migrateDB diff --git a/src/Vervis/Migration/Entities.hs b/src/Vervis/Migration/Entities.hs index f4b2a2a..50daa12 100644 --- a/src/Vervis/Migration/Entities.hs +++ b/src/Vervis/Migration/Entities.hs @@ -69,6 +69,7 @@ module Vervis.Migration.Entities , model_564_permit , model_570_source_dest , model_577_component_gather + , model_578_source_remove ) where @@ -268,3 +269,6 @@ model_570_source_dest = $(schema "570_2023-12-09_source_dest") model_577_component_gather :: [Entity SqlBackend] model_577_component_gather = $(schema "577_2024-03-13_component_gather") + +model_578_source_remove :: [Entity SqlBackend] +model_578_source_remove = $(schema "578_2024-04-03_source_remove") diff --git a/th/models b/th/models index 4ac34c2..1204576 100644 --- a/th/models +++ b/th/models @@ -1510,6 +1510,18 @@ SourceUsLeafToRemote UniqueSourceUsLeafToRemote leaf +-------------------------------- Source remove ------------------------------- + +-- Witnesses there's a removal request from the child's side, and I'm waiting +-- for the child project/team to Accept, which is when I'll do the removal on +-- my side + +SourceRemove + send SourceUsSendDelegatorId + activity InboxItemId + + UniqueSourceRemove activity + ------------------------------------------------------------------------------ -- Inheritance - Giver tracking her receivers -- (Project tracking its parents)