S2S: Component: Remove: Implement component mode, updated process
This commit is contained in:
Pere Lev
parent
4838a131b4
commit
185047ecb4
2 changed files with 444 additions and 197 deletions
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue