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
|
, topicAccept
|
||||||
, topicReject
|
, topicReject
|
||||||
, componentInvite
|
, componentInvite
|
||||||
, topicRemove
|
, componentRemove
|
||||||
, topicJoin
|
, topicJoin
|
||||||
, topicCreateMe
|
, topicCreateMe
|
||||||
, componentGrant
|
, componentGrant
|
||||||
|
|
@ -89,6 +89,7 @@ import Vervis.Persist.Discussion
|
||||||
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
|
||||||
import Vervis.RemoteActorStore
|
import Vervis.RemoteActorStore
|
||||||
import Vervis.Ticket
|
import Vervis.Ticket
|
||||||
|
import Vervis.Web.Collab
|
||||||
|
|
||||||
actorFollow
|
actorFollow
|
||||||
:: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
|
:: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
|
||||||
|
|
@ -1235,228 +1236,485 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
|
||||||
|
|
||||||
return (action, recipientSet, remoteActors, fwdHosts)
|
return (action, recipientSet, remoteActors, fwdHosts)
|
||||||
|
|
||||||
topicRemove
|
-- Meaning: An actor A is removing actor B from a collection C
|
||||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
-- Behavior:
|
||||||
=> (topic -> ResourceId)
|
-- * If C is my collaborators collection
|
||||||
-> (forall f. f topic -> LocalResourceBy f)
|
-- * 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
|
-> UTCTime
|
||||||
-> Key topic
|
-> Key topic
|
||||||
-> Verse
|
-> Verse
|
||||||
-> AP.Remove URIMode
|
-> AP.Remove URIMode
|
||||||
-> ActE (Text, Act (), Next)
|
-> 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
|
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
||||||
capability <- do
|
(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
|
uCap <- do
|
||||||
let muCap = AP.activityCapability $ actbActivity body
|
let muCap = AP.activityCapability $ actbActivity body
|
||||||
fromMaybeE muCap "No capability provided"
|
fromMaybeE muCap "No capability provided"
|
||||||
|
|
||||||
-- Verify the capability URI is one of:
|
-- Verify the specified capability gives relevant access
|
||||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
verifyCapability'' uCap authorIdMsig (topicResource topicKey) AP.RoleAdmin
|
||||||
-- * A remote URI
|
|
||||||
cap <- nameExceptT "Remove.capability" $ parseActivityURI' uCap
|
|
||||||
|
|
||||||
-- Verify the capability is local
|
maybeNew <- withDBExcept $ do
|
||||||
case cap of
|
|
||||||
Left (actorByKey, _, outboxItemID) ->
|
|
||||||
return (actorByKey, outboxItemID)
|
|
||||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
|
||||||
|
|
||||||
-- Check remove
|
-- Find member in our DB
|
||||||
memberByKey <- do
|
memberDB <-
|
||||||
let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
|
bitraverse
|
||||||
(resource, memberOrComp) <- parseRemove author remove
|
(flip getEntityE "Member not found in DB")
|
||||||
unless (Left (Left $ topicResource topicKey) == resource) $
|
(\ u@(ObjURI h lu) -> (,u) <$> do
|
||||||
throwE "Remove topic isn't my collabs URI"
|
maybeActor <- lift $ runMaybeT $ do
|
||||||
bitraverse
|
iid <- MaybeT $ getKeyBy $ UniqueInstance h
|
||||||
(\case
|
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu
|
||||||
LocalActorPerson p -> pure p
|
MaybeT $ getBy $ UniqueRemoteActor roid
|
||||||
_ -> throwE "Not accepting non-person actors as collabs"
|
fromMaybeE maybeActor "Remote removee not found in DB"
|
||||||
)
|
)
|
||||||
pure
|
memberByKey
|
||||||
memberOrComp
|
|
||||||
|
|
||||||
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
|
-- Find the collab that the member already has for me
|
||||||
memberDB <-
|
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
|
bitraverse
|
||||||
(flip getEntityE "Member not found in DB")
|
(\case
|
||||||
(\ u@(ObjURI h lu) -> (,u) <$> do
|
LocalActorProject j -> pure j
|
||||||
maybeActor <- lift $ runMaybeT $ do
|
_ -> throwE "Local object isn't a Project"
|
||||||
iid <- MaybeT $ getKeyBy $ UniqueInstance h
|
|
||||||
roid <- MaybeT $ getKeyBy $ UniqueRemoteObject iid lu
|
|
||||||
MaybeT $ getBy $ UniqueRemoteActor roid
|
|
||||||
fromMaybeE maybeActor "Remote removee not found in DB"
|
|
||||||
)
|
)
|
||||||
memberByKey
|
pure
|
||||||
|
item
|
||||||
|
|
||||||
-- Grab me from DB
|
-- Check capability
|
||||||
resourceID <- lift $ grabResource <$> getJust topicKey
|
uCap <- do
|
||||||
Resource topicActorID <- lift $ getJust resourceID
|
let muCap = AP.activityCapability $ actbActivity body
|
||||||
topicActor <- lift $ getJust topicActorID
|
fromMaybeE muCap "No capability provided"
|
||||||
|
|
||||||
-- Verify the specified capability gives relevant access
|
-- Verify the specified capability gives relevant access
|
||||||
verifyCapability'
|
verifyCapability'' uCap authorIdMsig (topicResource topicKey) AP.RoleAdmin
|
||||||
capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
|
|
||||||
|
|
||||||
-- Find the collab that the member already has for me
|
maybeNew <- withDBExcept $ do
|
||||||
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
|
-- Find project in our DB
|
||||||
maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID
|
projectDB <-
|
||||||
Entity enableID (CollabEnable _ grantID) <-
|
bitraverse
|
||||||
fromMaybeE maybeEnabled "Remove object isn't a member of me yet"
|
(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
|
-- Grab me from DB
|
||||||
otherCollabIDs <-
|
komponentID <- lift $ grabKomponent <$> getJust topicKey
|
||||||
lift $ E.select $ E.from $ \ (collab `E.InnerJoin` enable) -> do
|
Komponent resourceID <- lift $ getJust komponentID
|
||||||
E.on $
|
Resource topicActorID <- lift $ getJust resourceID
|
||||||
collab E.^. CollabId E.==.
|
topicActor <- lift $ getJust topicActorID
|
||||||
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
|
-- Find my Stem record for this project
|
||||||
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
|
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
|
-- Verify the Stem is enabled
|
||||||
deleteBy $ UniqueCollabDelegLocal enableID
|
maybeDelegatorGrant <-
|
||||||
deleteBy $ UniqueCollabDelegRemote enableID
|
lift $
|
||||||
delete enableID
|
case recipID of
|
||||||
case recipID of
|
Left (E.Value localID) -> fmap Left <$> getBy (UniqueStemProjectGrantLocalProject localID)
|
||||||
Left (E.Value l) -> do
|
Right (E.Value remoteID) -> fmap Right <$> getBy (UniqueStemProjectGrantRemoteProject remoteID)
|
||||||
deleteBy $ UniqueCollabRecipLocalJoinCollab l
|
delegatorGrant <- fromMaybeE maybeDelegatorGrant "Stem not enabled yet"
|
||||||
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
|
-- Grab start-Grant that I'm going to revoke
|
||||||
sieve <- lift $ do
|
let componentAcceptID =
|
||||||
topicHash <- encodeKeyHashid topicKey
|
case delegatorGrant of
|
||||||
let topicByHash = resourceToActor $ topicResource topicHash
|
Left (Entity _ (StemProjectGrantLocal ca _ _)) -> ca
|
||||||
return $ makeRecipientSet [] [localActorFollowers topicByHash]
|
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
|
maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
|
||||||
revoke@(actionRevoke, _, _, _) <-
|
lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
|
||||||
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)
|
-- Delete the whole Stem record
|
||||||
|
usOrThem <-
|
||||||
|
requireEitherAlt
|
||||||
|
(getKeyBy $ UniqueStemOriginAdd stemID)
|
||||||
|
(getKeyBy $ UniqueStemOriginInvite stemID)
|
||||||
|
"Neither us nor them"
|
||||||
|
"Both us and them"
|
||||||
|
|
||||||
case maybeNew of
|
delete startID
|
||||||
Nothing -> done "I already have this activity in my inbox"
|
case delegatorGrant of
|
||||||
Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do
|
Left (Entity localID _) -> delete localID
|
||||||
let topicByID = resourceToActor $ topicResource topicKey
|
Right (Entity remoteID _) -> delete remoteID
|
||||||
forwardActivity authorIdMsig body topicByID topicActorID sieve
|
case usOrThem of
|
||||||
lift $ sendActivity
|
Left usID -> delete usID
|
||||||
topicByID topicActorID localRecipsRevoke
|
Right themID -> do
|
||||||
remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
|
deleteBy $ UniqueStemProjectAcceptLocal themID
|
||||||
doneDB inboxItemID "Deleted the Grant/Collab, forwarded Remove, sent Revoke"
|
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
|
-- Prepare a Revoke activity and insert to my outbox
|
||||||
encodeRouteHome <- getEncodeRouteHome
|
revoke@(actionRevoke, _, _, _) <-
|
||||||
encodeRouteLocal <- getEncodeRouteLocal
|
lift $ prepareRevoke projectDB grantID
|
||||||
|
let recipByKey = resourceToActor $ topicResource topicKey
|
||||||
|
revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
|
||||||
|
_luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
|
||||||
|
|
||||||
recipHash <- encodeKeyHashid topicKey
|
return (topicActorID, sieve, revokeID, revoke, inboxItemID)
|
||||||
let topicByHash = resourceToActor $ topicResource recipHash
|
|
||||||
|
|
||||||
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
|
where
|
||||||
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) =
|
prepareRevoke project grantID = do
|
||||||
collectAudience audience
|
encodeRouteHome <- getEncodeRouteHome
|
||||||
|
encodeRouteLocal <- getEncodeRouteLocal
|
||||||
|
|
||||||
recips = map encodeRouteHome audLocal ++ audRemote
|
recipHash <- encodeKeyHashid topicKey
|
||||||
uRemove <- getActivityURI authorIdMsig
|
let topicByHash = resourceToActor $ topicResource recipHash
|
||||||
luGrant <- do
|
|
||||||
grantHash <- encodeKeyHashid grantID
|
projectHash <- bitraverse (encodeKeyHashid . entityKey) pure project
|
||||||
return $ encodeRouteLocal $ activityRoute topicByHash grantHash
|
|
||||||
let action = AP.Action
|
audRemover <- makeAudSenderOnly authorIdMsig
|
||||||
{ AP.actionCapability = Nothing
|
let audience =
|
||||||
, AP.actionSummary = Nothing
|
let audProject =
|
||||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
case projectHash of
|
||||||
, AP.actionFulfills = [uRemove]
|
Left j ->
|
||||||
, AP.actionSpecific = AP.RevokeActivity AP.Revoke
|
AudLocal [LocalActorProject j] [LocalStageProjectFollowers j]
|
||||||
{ AP.revokeObject = luGrant :| []
|
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
|
topicJoin
|
||||||
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
:: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
|
||||||
|
|
|
||||||
|
|
@ -627,24 +627,13 @@ deckInvite
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
deckInvite = componentInvite deckKomponent ComponentDeck
|
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
|
deckRemove
|
||||||
:: UTCTime
|
:: UTCTime
|
||||||
-> DeckId
|
-> DeckId
|
||||||
-> Verse
|
-> Verse
|
||||||
-> AP.Remove URIMode
|
-> AP.Remove URIMode
|
||||||
-> ActE (Text, Act (), Next)
|
-> ActE (Text, Act (), Next)
|
||||||
deckRemove = topicRemove deckResource LocalResourceDeck
|
deckRemove = componentRemove deckKomponent ComponentDeck
|
||||||
|
|
||||||
-- Meaning: An actor A asked to join a resource
|
-- Meaning: An actor A asked to join a resource
|
||||||
-- Behavior:
|
-- Behavior:
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue