diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 00fe01e..1222ab9 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -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: