diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs
index 242c95f..a02a28c 100644
--- a/src/Vervis/Actor/Common.hs
+++ b/src/Vervis/Actor/Common.hs
@@ -22,7 +22,7 @@ module Vervis.Actor.Common
, topicAccept
, topicReject
, componentInvite
- , topicRemove
+ , componentRemove
, topicJoin
, topicCreateMe
, componentGrant
@@ -89,6 +89,7 @@ import Vervis.Persist.Discussion
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
import Vervis.RemoteActorStore
import Vervis.Ticket
+import Vervis.Web.Collab
actorFollow
:: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
@@ -1235,228 +1236,485 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
return (action, recipientSet, remoteActors, fwdHosts)
-topicRemove
- :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
- => (topic -> ResourceId)
- -> (forall f. f topic -> LocalResourceBy f)
+-- Meaning: An actor A is removing actor B from a collection C
+-- Behavior:
+-- * 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 projects collection
+-- * Verify A's request is authorized
+-- * Verify B is an enabled project of mine
+-- * Remove the whole Stem record from DB
+-- * Forward to followers
+-- * Publish a Revoke on the start-Grant I'd sent to B
+-- * To: Actor B
+-- * CC: Actor A, B's followers, my followers
+--
+-- * If I'm B, and C is some project's components collection
+-- * Just forward to my followers
+componentRemove
+ :: forall topic.
+ (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+ => (topic -> KomponentId)
+ -> (forall f. f topic -> ComponentBy f)
-> UTCTime
-> Key topic
-> Verse
-> AP.Remove URIMode
-> ActE (Text, Act (), Next)
-topicRemove grabResource topicResource now topicKey (Verse authorIdMsig body) remove = do
+componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig body) remove = do
- -- Check capability
- capability <- do
+ let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+ (collection, item) <- parseRemove author remove
+ case (collection, item) of
+ (Left (Left lr), _)
+ | lr == topicResource topicKey ->
+ removeCollab item
+ (Left (Right target), _)
+ | addTargetComponentProjects target == Just (topicComponent topicKey) ->
+ removeProjectActive item
+ (_, Left la) | la == resourceToActor (topicResource topicKey) ->
+ case collection of
+ Left (Right (ATProjectComponents j)) ->
+ removeProjectPassive $ 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"
+ rwc <- AP.fetchRWC_T manager h lu
+ AP.Actor l d <-
+ case AP.rwcResource rwc of
+ AP.ResourceActor a -> pure a
+ AP.ResourceChild _ _ -> throwE "Remove.target remote ResourceChild"
+ let typ = AP.actorType d
+ if typ == AP.ActorTypeProject && Just luColl == AP.rwcComponents rwc
+ then removeProjectPassive $ Right $ ObjURI h lu
+ else throwE "Weird collection situation"
+ _ -> throwE "I'm being removed from somewhere irrelevant"
+ _ -> throwE "This Remove isn't for me"
- -- Verify that a capability is provided
+ where
+
+ topicResource :: forall f. f topic -> LocalResourceBy f
+ topicResource = componentResource . topicComponent
+
+ removeCollab item = do
+
+ memberByKey <-
+ bitraverse
+ (\case
+ LocalActorPerson p -> pure p
+ _ -> throwE "Not accepting non-person actors as collabs"
+ )
+ pure
+ item
+
+ -- Check capability
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 "Remove.capability" $ parseActivityURI' uCap
+ -- Verify the specified capability gives relevant access
+ verifyCapability'' uCap authorIdMsig (topicResource topicKey) AP.RoleAdmin
- -- Verify the capability is local
- case cap of
- Left (actorByKey, _, outboxItemID) ->
- return (actorByKey, outboxItemID)
- _ -> throwE "Capability is remote i.e. definitely not by me"
+ maybeNew <- withDBExcept $ do
- -- Check remove
- memberByKey <- do
- let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
- (resource, memberOrComp) <- parseRemove author remove
- unless (Left (Left $ topicResource topicKey) == 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
+ -- 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
- maybeNew <- withDBExcept $ do
+ -- Grab me from DB
+ komponentID <- lift $ grabKomponent <$> getJust topicKey
+ Komponent resourceID <- lift $ getJust komponentID
+ Resource topicActorID <- lift $ getJust resourceID
+ topicActor <- lift $ getJust topicActorID
- -- Find member in our DB
- memberDB <-
+ -- Find the collab that the member already has for me
+ existingCollabIDs <-
+ lift $ case memberDB of
+ Left (Entity personID _) ->
+ fmap (map $ over _1 Left) $
+ E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
+ E.on $
+ collab E.^. CollabId E.==.
+ recipl E.^. CollabRecipLocalCollab
+ E.where_ $
+ collab E.^. CollabTopic E.==. E.val resourceID E.&&.
+ recipl E.^. CollabRecipLocalPerson E.==. E.val personID
+ return
+ ( recipl E.^. persistIdField
+ , recipl E.^. CollabRecipLocalCollab
+ )
+ Right (Entity remoteActorID _, _) ->
+ fmap (map $ over _1 Right) $
+ E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
+ E.on $
+ collab E.^. CollabId E.==.
+ recipr E.^. CollabRecipRemoteCollab
+ E.where_ $
+ collab E.^. CollabTopic E.==. E.val resourceID E.&&.
+ recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
+ return
+ ( recipr E.^. persistIdField
+ , recipr E.^. CollabRecipRemoteCollab
+ )
+ (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 $ \ (collab `E.InnerJoin` enable) -> do
+ E.on $
+ collab E.^. CollabId E.==.
+ enable E.^. CollabEnableCollab
+ E.where_ $
+ collab E.^. CollabTopic E.==. E.val resourceID E.&&.
+ collab E.^. CollabId E.!=. E.val collabID
+ return $ collab E.^. CollabId
+ when (null otherCollabIDs) $
+ throwE "No other admins exist, can't remove"
+
+ maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+ lift $ for maybeRemoveDB $ \ (inboxItemID, _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
+ 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 topicKey
+ let topicByHash = resourceToActor $ topicResource topicHash
+ return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+ -- Prepare a Revoke activity and insert to my outbox
+ revoke@(actionRevoke, _, _, _) <-
+ lift $ prepareRevoke memberDB grantID
+ let recipByKey = resourceToActor $ topicResource topicKey
+ revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
+ _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
+
+ return (topicActorID, sieve, revokeID, revoke, inboxItemID)
+
+ case maybeNew of
+ Nothing -> done "I already have this activity in my inbox"
+ Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do
+ let topicByID = resourceToActor $ topicResource topicKey
+ forwardActivity authorIdMsig body topicByID topicActorID sieve
+ lift $ sendActivity
+ topicByID topicActorID localRecipsRevoke
+ remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
+ doneDB inboxItemID "[Collab] Deleted the Grant/Collab, forwarded Remove, sent Revoke"
+
+ where
+
+ prepareRevoke member grantID = do
+ encodeRouteHome <- getEncodeRouteHome
+ encodeRouteLocal <- getEncodeRouteLocal
+
+ recipHash <- encodeKeyHashid topicKey
+ let topicByHash = resourceToActor $ topicResource 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)
+
+ removeProjectActive item = do
+
+ project <-
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"
+ (\case
+ LocalActorProject j -> pure j
+ _ -> throwE "Local object isn't a Project"
)
- memberByKey
+ pure
+ item
- -- Grab me from DB
- resourceID <- lift $ grabResource <$> getJust topicKey
- Resource topicActorID <- lift $ getJust resourceID
- topicActor <- lift $ getJust topicActorID
+ -- Check capability
+ uCap <- do
+ let muCap = AP.activityCapability $ actbActivity body
+ fromMaybeE muCap "No capability provided"
-- Verify the specified capability gives relevant access
- verifyCapability'
- capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
+ verifyCapability'' uCap authorIdMsig (topicResource topicKey) AP.RoleAdmin
- -- Find the collab that the member already has for me
- existingCollabIDs <-
- lift $ case memberDB of
- Left (Entity personID _) ->
- fmap (map $ over _1 Left) $
- E.select $ E.from $ \ (collab `E.InnerJoin` recipl) -> do
- E.on $
- collab E.^. CollabId E.==.
- recipl E.^. CollabRecipLocalCollab
- E.where_ $
- collab E.^. CollabTopic E.==. E.val resourceID E.&&.
- recipl E.^. CollabRecipLocalPerson E.==. E.val personID
- return
- ( recipl E.^. persistIdField
- , recipl E.^. CollabRecipLocalCollab
- )
- Right (Entity remoteActorID _, _) ->
- fmap (map $ over _1 Right) $
- E.select $ E.from $ \ (collab `E.InnerJoin` recipr) -> do
- E.on $
- collab E.^. CollabId E.==.
- recipr E.^. CollabRecipRemoteCollab
- E.where_ $
- collab E.^. CollabTopic E.==. E.val resourceID E.&&.
- recipr E.^. CollabRecipRemoteActor E.==. E.val remoteActorID
- return
- ( recipr E.^. persistIdField
- , recipr E.^. CollabRecipRemoteCollab
- )
- (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"
+ maybeNew <- withDBExcept $ do
- -- 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"
+ -- Find project in our DB
+ projectDB <-
+ 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"
+ )
+ project
- -- Verify that at least 1 more enabled Admin collab for me exists
- otherCollabIDs <-
- lift $ E.select $ E.from $ \ (collab `E.InnerJoin` enable) -> do
- E.on $
- collab E.^. CollabId E.==.
- enable E.^. CollabEnableCollab
- E.where_ $
- collab E.^. CollabTopic E.==. E.val resourceID E.&&.
- collab E.^. CollabId E.!=. E.val collabID
- return $ collab E.^. CollabId
- when (null otherCollabIDs) $
- throwE "No other admins exist, can't remove"
+ -- Grab me from DB
+ komponentID <- lift $ grabKomponent <$> getJust topicKey
+ Komponent resourceID <- lift $ getJust komponentID
+ Resource topicActorID <- lift $ getJust resourceID
+ topicActor <- lift $ getJust topicActorID
- maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
- lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
+ -- Find my Stem record for this project
+ existingStemIDs <-
+ lift $ case projectDB of
+ Left (Entity projectID _) ->
+ fmap (map $ over _1 Left) $
+ E.select $ E.from $ \ (stem `E.InnerJoin` project) -> do
+ E.on $ stem E.^. StemId E.==. project E.^. StemProjectLocalStem
+ E.where_ $
+ project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
+ stem E.^. StemHolder E.==. E.val komponentID
+ return
+ ( project E.^. StemProjectLocalId
+ , project E.^. StemProjectLocalStem
+ )
+ Right (Entity remoteActorID _, _) ->
+ fmap (map $ over _1 Right) $
+ E.select $ E.from $ \ (stem `E.InnerJoin` project) -> do
+ E.on $ stem E.^. StemId E.==. project E.^. StemProjectRemoteStem
+ E.where_ $
+ project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
+ stem E.^. StemHolder E.==. E.val komponentID
+ return
+ ( project E.^. StemProjectRemoteId
+ , project E.^. StemProjectRemoteStem
+ )
+ (recipID, E.Value stemID) <-
+ case existingStemIDs of
+ [] -> throwE "Remove object isn't a project of mine"
+ [stem] -> return stem
+ _ -> error "Multiple Stems found for removee"
- -- 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
- 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
+ -- Verify the Stem is enabled
+ maybeDelegatorGrant <-
+ lift $
+ case recipID of
+ Left (E.Value localID) -> fmap Left <$> getBy (UniqueStemProjectGrantLocalProject localID)
+ Right (E.Value remoteID) -> fmap Right <$> getBy (UniqueStemProjectGrantRemoteProject remoteID)
+ delegatorGrant <- fromMaybeE maybeDelegatorGrant "Stem not enabled yet"
- -- Prepare forwarding Remove to my followers
- sieve <- lift $ do
- topicHash <- encodeKeyHashid topicKey
- let topicByHash = resourceToActor $ topicResource topicHash
- return $ makeRecipientSet [] [localActorFollowers topicByHash]
+ -- Grab start-Grant that I'm going to revoke
+ let componentAcceptID =
+ case delegatorGrant of
+ Left (Entity _ (StemProjectGrantLocal ca _ _)) -> ca
+ Right (Entity _ (StemProjectGrantRemote ca _ _)) -> ca
+ Entity startID (StemDelegateLocal _ grantID) <- do
+ maybeStart <-
+ lift $ getBy $ UniqueStemDelegateLocal componentAcceptID
+ fromMaybeE maybeStart "Start-Grant not sent yet"
- -- Prepare a Revoke activity and insert to my outbox
- revoke@(actionRevoke, _, _, _) <-
- lift $ prepareRevoke memberDB grantID
- let recipByKey = resourceToActor $ topicResource topicKey
- revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
- _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
+ maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+ lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
- return (topicActorID, sieve, revokeID, revoke, inboxItemID)
+ -- Delete the whole Stem record
+ usOrThem <-
+ requireEitherAlt
+ (getKeyBy $ UniqueStemOriginAdd stemID)
+ (getKeyBy $ UniqueStemOriginInvite stemID)
+ "Neither us nor them"
+ "Both us and them"
- case maybeNew of
- Nothing -> done "I already have this activity in my inbox"
- Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do
- let topicByID = resourceToActor $ topicResource topicKey
- forwardActivity authorIdMsig body topicByID topicActorID sieve
- lift $ sendActivity
- topicByID topicActorID localRecipsRevoke
- remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
- doneDB inboxItemID "Deleted the Grant/Collab, forwarded Remove, sent Revoke"
+ delete startID
+ case delegatorGrant of
+ Left (Entity localID _) -> delete localID
+ Right (Entity remoteID _) -> delete remoteID
+ case usOrThem of
+ Left usID -> delete usID
+ Right themID -> do
+ deleteBy $ UniqueStemProjectAcceptLocal themID
+ deleteBy $ UniqueStemProjectGestureRemote themID
+ deleteBy $ UniqueStemProjectGestureLocal themID
+ delete themID
+ delete componentAcceptID
+ deleteBy $ UniqueStemComponentGestureLocal stemID
+ deleteBy $ UniqueStemComponentGestureRemote stemID
+ case recipID of
+ Left (E.Value localID) -> delete localID
+ Right (E.Value remoteID) -> delete remoteID
+ delete stemID
- where
+ -- Prepare forwarding Remove to my followers
+ sieve <- lift $ do
+ topicHash <- encodeKeyHashid topicKey
+ let topicByHash = resourceToActor $ topicResource topicHash
+ return $ makeRecipientSet [] [localActorFollowers topicByHash]
- prepareRevoke member grantID = do
- encodeRouteHome <- getEncodeRouteHome
- encodeRouteLocal <- getEncodeRouteLocal
+ -- Prepare a Revoke activity and insert to my outbox
+ revoke@(actionRevoke, _, _, _) <-
+ lift $ prepareRevoke projectDB grantID
+ let recipByKey = resourceToActor $ topicResource topicKey
+ revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
+ _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
- recipHash <- encodeKeyHashid topicKey
- let topicByHash = resourceToActor $ topicResource recipHash
+ return (topicActorID, sieve, revokeID, revoke, inboxItemID)
- memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member
+ case maybeNew of
+ Nothing -> done "I already have this activity in my inbox"
+ Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do
+ let topicByID = resourceToActor $ topicResource topicKey
+ forwardActivity authorIdMsig body topicByID topicActorID sieve
+ lift $ sendActivity
+ topicByID topicActorID localRecipsRevoke
+ remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
+ doneDB inboxItemID "[Project-active] Deleted the Stem, forwarded Remove, sent Revoke"
- 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]
+ where
- (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
- collectAudience audience
+ prepareRevoke project grantID = do
+ encodeRouteHome <- getEncodeRouteHome
+ encodeRouteLocal <- getEncodeRouteLocal
- 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 :| []
+ recipHash <- encodeKeyHashid topicKey
+ let topicByHash = resourceToActor $ topicResource recipHash
+
+ projectHash <- bitraverse (encodeKeyHashid . entityKey) pure project
+
+ audRemover <- makeAudSenderOnly authorIdMsig
+ let audience =
+ let audProject =
+ case projectHash of
+ Left j ->
+ AudLocal [LocalActorProject j] [LocalStageProjectFollowers j]
+ Right (Entity _ actor, ObjURI h lu) ->
+ AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
+ audMe = AudLocal [] [localActorFollowers topicByHash]
+ in [audRemover, audProject, audMe]
+
+ (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)
+
+ removeProjectPassive _project = do
+
+ maybeNew <- withDBExcept $ do
+
+ -- Grab me from DB
+ komponentID <- lift $ grabKomponent <$> getJust topicKey
+ Komponent resourceID <- lift $ getJust komponentID
+ Resource topicActorID <- lift $ getJust resourceID
+ topicActor <- lift $ getJust topicActorID
+
+ maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+ lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
+
+ -- Prepare forwarding Remove to my followers
+ sieve <- lift $ do
+ topicHash <- encodeKeyHashid topicKey
+ let topicByHash = resourceToActor $ topicResource topicHash
+ return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+ return (topicActorID, sieve, inboxItemID)
+
+ case maybeNew of
+ Nothing -> done "I already have this activity in my inbox"
+ Just (topicActorID, sieve, inboxItemID) -> do
+ let topicByID = resourceToActor $ topicResource topicKey
+ forwardActivity authorIdMsig body topicByID topicActorID sieve
+ doneDB inboxItemID "[Project-passive] Just forwarded Remove"
topicJoin
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs
index 66d3707..0283ecc 100644
--- a/src/Vervis/Actor/Deck.hs
+++ b/src/Vervis/Actor/Deck.hs
@@ -627,24 +627,13 @@ deckInvite
-> ActE (Text, Act (), Next)
deckInvite = componentInvite deckKomponent ComponentDeck
--- Meaning: An actor A is removing actor B from a resource
--- 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
deckRemove
:: UTCTime
-> DeckId
-> Verse
-> AP.Remove URIMode
-> ActE (Text, Act (), Next)
-deckRemove = topicRemove deckResource LocalResourceDeck
+deckRemove = componentRemove deckKomponent ComponentDeck
-- Meaning: An actor A asked to join a resource
-- Behavior: