diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index c073c0d..ed2c5e4 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -4848,6 +4848,218 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do Just () -> done "Saw the removal attempt, just waiting for the Revoke" +-- Meaning: An actor is revoking Grant activities +-- Behavior: +-- * For each revoked activity: +-- * If it's a parent revoking a delegator-Grant it gave me: +-- * Delete the whole Dest record +-- * Forward the Revoke to my followers +-- * Send Accept to parent+followers & my followers +-- * If it's a child revoking a Grant it had extended to me: +-- * Delete that extension from my Source record +-- * For each further extension I did on that Grant (to a +-- parent/collab/team), send a Revoke +projectRevoke + :: UTCTime + -> ProjectId + -> Verse + -> AP.Revoke URIMode + -> ActE (Text, Act (), Next) +projectRevoke now projectID (Verse authorIdMsig body) (AP.Revoke (luFirst :| lusRest)) = do + + ObjURI h _ <- lift $ getActorURI authorIdMsig + parseRevoked <- do + hl <- hostIsLocal h + return $ + \ lu -> + if hl + then + Left . (\ (a, _, i) -> (a, i)) <$> + parseLocalActivityURI' lu + else pure $ Right lu + revokedFirst <- parseRevoked luFirst + revokedRest <- traverse parseRevoked lusRest + + mode <- withDBExcept $ do + + revokedFirstDB <- do + a <- getActivity $ second (ObjURI h) revokedFirst + fromMaybeE a "Can't find revoked in DB" + + let adapt = maybe (Right Nothing) (either Left (Right . Just)) + maybeMode <- + ExceptT $ fmap adapt $ runMaybeT $ + runExceptT (Left <$> tryParent revokedFirstDB) <|> + runExceptT (Right <$> lift mzero) + fromMaybeE + maybeMode + "Revoked activity isn't a relevant Grant I'm aware of" + + case mode of + Left p -> revokeParent revokedRest p + Right () -> error "revokeChild c" + + where + + verifyDestHolder :: DestId -> ActDBE () + verifyDestHolder destID = do + mh <- lift $ getValBy $ UniqueDestHolderProject destID + case mh of + Just (DestHolderProject _ j) | j == projectID -> pure () + _ -> throwE "Revoke object is a Grant for some other project/team" + + tryParent' usAcceptID send = do + DestUsAccept destID _ <- lift $ lift $ getJust usAcceptID + ExceptT $ lift $ runExceptT $ verifyDestHolder destID + topic <- do + t <- lift . lift $ getDestTopic destID + bitraverse + (\ (l, k) -> + case k of + Left j -> pure (l, j) + Right _ -> error "Project Dest topic is a Group, impossible" + ) + pure + t + return (destID, usAcceptID, topic, send) + + tryParent (Left (_actorByKey, _actorEntity, itemID)) = do + Entity sendID (DestThemSendDelegatorLocal usAcceptID _localID _) <- + lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorLocalGrant itemID + tryParent' usAcceptID (Left sendID) --(Left localID) + tryParent (Right remoteActivityID) = do + Entity sendID (DestThemSendDelegatorRemote usAcceptID _remoteID _) <- + lift $ MaybeT $ getBy $ UniqueDestThemSendDelegatorRemoteGrant remoteActivityID + tryParent' usAcceptID (Right sendID) --(Right remoteID) + + revokeParent revokedRest (destID, usAcceptID, parent, send) = do + + let author = bimap (view _1) (remoteAuthorId . view _1) authorIdMsig + unless (author == bimap (LocalActorProject . snd) snd parent) $ + throwE "Sender isn't the parent Project he revoked Grant came from" + + unless (null revokedRest) $ + throwE "Parent revoking the delegator-Grant and something more" + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + maybeRevokeDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRevokeDB $ \ _revokeDB -> do + + -- Delete uses of this Dest from my Component records + case send of + Left sendID -> + deleteWhere [ComponentGatherLocalParent ==. sendID] + Right sendID -> + deleteWhere [ComponentGatherRemoteParent ==. sendID] + + -- Delete uses of this Dest from my Source records + case send of + Left sendID -> do + gatherIDs <- + map (sourceUsGatherToLocalGather . entityVal) <$> + selectList [SourceUsGatherToLocalTo ==. sendID] [] + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherToLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + Right sendID -> do + gatherIDs <- + map (sourceUsGatherToRemoteGather . entityVal) <$> + selectList [SourceUsGatherToRemoteTo ==. sendID] [] + deleteWhere [SourceUsGatherFromLocalGather <-. gatherIDs] + deleteWhere [SourceUsGatherFromRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherToRemoteGather <-. gatherIDs] + deleteWhere [SourceUsGatherId <-. gatherIDs] + + -- Delete the whole Dest record + case send of + Left sendID -> delete sendID + Right sendID -> delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueDestOriginUs destID) + (getKeyBy $ UniqueDestOriginThem destID) + "Neither us nor them" + "Both us and them" + deleteBy $ UniqueDestUsGestureLocal destID + deleteBy $ UniqueDestUsGestureRemote destID + case origin of + Left usID -> delete usID + Right themID -> do + deleteBy $ UniqueDestThemAcceptLocal themID + deleteBy $ UniqueDestThemAcceptRemote themID + deleteBy $ UniqueDestThemGestureLocal themID + deleteBy $ UniqueDestThemGestureRemote themID + delete themID + delete usAcceptID + case parent of + Left (l, _j) -> do + deleteBy $ UniqueDestTopicProjectTopic l + delete l + Right (r, _) -> delete r + deleteBy $ UniqueDestHolderProject destID + delete destID + + -- Prepare forwarding Remove to my followers + sieve <- lift $ do + topicHash <- encodeKeyHashid projectID + let topicByHash = + LocalActorProject topicHash + return $ makeRecipientSet [] [localActorFollowers topicByHash] + + -- Prepare Accept activity + accept@(actionAccept, _, _, _) <- prepareAccept + let recipByKey = LocalActorProject projectID + acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + + return (projectActor project, sieve, acceptID, accept) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept)) -> do + let topicByID = LocalActorProject projectID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ + sendActivity + topicByID topicActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + done "Deleted the Parent/Dest, forwarded Revoke, sent Accept" + + where + + prepareAccept = do + encodeRouteHome <- getEncodeRouteHome + + audParent <- makeAudSenderWithFollowers authorIdMsig + audMe <- + AudLocal [] . pure . LocalStageProjectFollowers <$> + encodeKeyHashid projectID + uRevoke <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audParent, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRevoke] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uRevoke + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + -- Meaning: An actor is undoing some previous action -- Behavior: -- * If they're undoing their Following of me: @@ -4983,6 +5195,7 @@ projectBehavior now projectID (Left verse@(Verse _authorIdMsig body)) = AP.JoinActivity join -> projectJoin now projectID verse join AP.RejectActivity reject -> projectReject now projectID verse reject AP.RemoveActivity remove -> projectRemove now projectID verse remove + AP.RevokeActivity revoke -> projectRevoke now projectID verse revoke AP.UndoActivity undo -> projectUndo now projectID verse undo _ -> throwE "Unsupported activity type for Project" projectBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Project"