S2S: Project: Remove: Copy topicRemove code to Project, preparing for new code
This commit is contained in:
Pere Lev
parent
a1df4b3bdb
commit
e4ea55ee15
1 changed files with 219 additions and 4 deletions
|
|
@ -34,6 +34,7 @@ import Data.Bitraversable
|
|||
import Data.ByteString (ByteString)
|
||||
import Data.Either
|
||||
import Data.Foldable
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Clock
|
||||
|
|
@ -3596,10 +3597,224 @@ projectRemove
|
|||
-> Verse
|
||||
-> AP.Remove URIMode
|
||||
-> ActE (Text, Act (), Next)
|
||||
projectRemove =
|
||||
topicRemove
|
||||
projectActor LocalActorProject
|
||||
CollabTopicProjectProject CollabTopicProjectCollab
|
||||
projectRemove now projectID (Verse authorIdMsig body) remove = do
|
||||
|
||||
-- Check capability
|
||||
capability <- do
|
||||
|
||||
-- Verify that a capability is provided
|
||||
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 capability is local
|
||||
case cap of
|
||||
Left (actorByKey, _, outboxItemID) ->
|
||||
return (actorByKey, outboxItemID)
|
||||
_ -> throwE "Capability is remote i.e. definitely not by me"
|
||||
|
||||
-- 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
|
||||
|
||||
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
|
||||
|
||||
-- Verify the specified capability gives relevant access
|
||||
verifyCapability'
|
||||
capability authorIdMsig (LocalActorProject projectID) AP.RoleAdmin
|
||||
|
||||
-- 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)
|
||||
|
||||
-- Meaning: An actor is undoing some previous action
|
||||
-- Behavior:
|
||||
|
|
|
|||
Loading…
Reference in a new issue