diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 93c85ea..c9e36ba 100644 --- a/src/Vervis/Actor/Project.hs +++ b/src/Vervis/Actor/Project.hs @@ -5214,6 +5214,15 @@ projectReject = topicReject projectResource LocalResourceProject -- * To: Actor B -- * CC: Actor A, B's followers, my followers -- +-- * If C is my teams collection: +-- * Verify A is authorized by me to remove teams from me +-- * Verify B is an active team of mine +-- * Remove the whole Squad record from DB +-- * Forward the Remove to my followers +-- * Send an Accept on the Remove: +-- * To: Actor B +-- * CC: Actor A, B's followers, my followers +-- -- * If I'm B, being removed from the parents of a child of mine: -- * Record this Remove in the Source record -- * Forward to followers @@ -5225,6 +5234,10 @@ projectReject = topicReject projectResource LocalResourceProject -- * If I'm B, being removed from the projects of a component of mine: -- * Do nothing, just waiting for component to send a Revoke on the -- start-Grant +-- +-- * If I'm B, being removed from the resources of a team of mine: +-- * Do nothing, just waiting for team to send a Revoke on the +-- delegator-Grant projectRemove :: UTCTime -> ProjectId @@ -5244,12 +5257,16 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do removeChildActive item (Left (Right (ATProjectParents j)), _) | j == projectID -> removeParentActive item + (Left (Right (ATProjectTeams j)), _) | j == projectID -> + removeTeamActive item (_, Left (LocalActorProject j)) | j == projectID -> case collection of Left (Right (ATProjectParents j)) | j /= projectID -> removeChildPassive $ Left j Left (Right (ATProjectChildren j)) | j /= projectID -> removeParentPassive $ Left j + Left (Right (ATGroupEfforts g)) -> + removeTeamPassive $ Left g Left (Right at) | isJust (addTargetComponentProjects at) -> removeComponentPassive $ Left $ fromJust $ addTargetComponentProjects at Right (ObjURI h luColl) -> do @@ -5264,16 +5281,14 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do AP.ResourceActor a -> pure a AP.ResourceChild _ _ -> throwE "Remove.origin remote ResourceChild" let typ = AP.actorType d - - - - if typ == AP.ActorTypeProject && Just luColl == AP.rwcSubprojects rwc then removeParentPassive $ Right $ ObjURI h lu else if typ == AP.ActorTypeProject && Just luColl == AP.rwcParentsOrProjects rwc then removeChildPassive $ Right $ ObjURI h lu else if AP.actorTypeIsComponent typ && Just luColl == AP.rwcParentsOrProjects rwc then removeComponentPassive $ Right $ ObjURI h lu + else if typ == AP.ActorTypeTeam && Just luColl == AP.rwcTeamResources rwc + then removeTeamPassive $ Right $ ObjURI h lu else throwE "Weird collection situation" _ -> throwE "I'm being removed from somewhere irrelevant" _ -> throwE "This Remove isn't for me" @@ -6575,6 +6590,287 @@ projectRemove now projectID (Verse authorIdMsig body) remove = do Just inboxItemID -> doneDB inboxItemID "[Component-passive] Saw the removal attempt, just waiting for the Revoke" + removeTeamActive team = do + + -- If team is local, find it in our DB + -- If team is remote, HTTP GET it, verify it's an actor of Project + -- type, and store in our DB (if it's already there, no need for HTTP) + -- + -- NOTE: This is a blocking HTTP GET done right here in the handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result would be sent later in a separate (e.g. Accept) activity. + -- But for the PoC level, the current situation will hopefully do. + teamDB <- + bitraverse + (\case + LocalActorGroup g -> withDBExcept $ getEntityE g "Team not found in DB" + _ -> throwE "Local proposed team of non-Group type" + ) + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor' instanceID h lu + case result of + Left Nothing -> throwE "Team @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Team isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote team type isn't Team" + return (u, actor) + ) + team + + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the sender is authorized by me to remove a team + verifyCapability'' + uCap + authorIdMsig + (LocalResourceProject projectID) + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + -- Verify it's an active team of mine + squads <- lift $ case teamDB of + Left (Entity g _) -> + fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Left (t, s))) $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicLocalId E.==. send E.^. SquadThemSendDelegatorLocalTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad + E.where_ $ + squad E.^. SquadHolder E.==. E.val (projectResource project) E.&&. + topic E.^. SquadTopicLocalGroup E.==. E.val g + return + ( squad E.^. SquadId + , send E.^. SquadThemSendDelegatorLocalSquad + , start E.^. SquadUsStartId + , topic E.^. SquadTopicLocalId + , send E.^. SquadThemSendDelegatorLocalId + ) + Right (_, Entity a _) -> + fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Right (t, s))) $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicRemoteId E.==. send E.^. SquadThemSendDelegatorRemoteTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad + E.where_ $ + squad E.^. SquadHolder E.==. E.val (projectResource project) E.&&. + topic E.^. SquadTopicRemoteTopic E.==. E.val a + return + ( squad E.^. SquadId + , send E.^. SquadThemSendDelegatorRemoteSquad + , start E.^. SquadUsStartId + , topic E.^. SquadTopicRemoteId + , send E.^. SquadThemSendDelegatorRemoteId + ) + + (E.Value squadID, E.Value usAcceptID, E.Value squadStartID, topic) <- + verifySingleE squads "No squad" "Multiple squads" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do + + -- Delete uses of this Squad from my Component records + deleteWhere [ComponentConveyTeam ==. squadStartID] + + -- Delete uses of this Squad from my Source records + conveyIDs <- selectKeysList [SourceUsConveyTeam ==. squadStartID] [] + deleteWhere [SourceUsConveyFromLocalConvey <-. conveyIDs] + deleteWhere [SourceUsConveyFromRemoteConvey <-. conveyIDs] + deleteWhere [SourceUsConveyId <-. conveyIDs] + + -- Delete the whole Squad record + delete squadStartID + case topic of + Left (_, sendID) -> delete sendID + Right (_, sendID) -> delete sendID + origin <- + requireEitherAlt + (getKeyBy $ UniqueSquadOriginUs squadID) + (getKeyBy $ UniqueSquadOriginThem squadID) + "Neither us nor them" + "Both us and them" + deleteBy $ UniqueSquadUsGestureLocal squadID + deleteBy $ UniqueSquadUsGestureRemote squadID + case origin of + Left usID -> delete usID + Right themID -> do + deleteBy $ UniqueSquadThemAcceptLocal themID + deleteBy $ UniqueSquadThemAcceptRemote themID + deleteBy $ UniqueSquadThemGestureLocal themID + deleteBy $ UniqueSquadThemGestureRemote themID + delete themID + delete usAcceptID + case topic of + Left (l, _) -> delete l + Right (r, _) -> delete r + delete squadID + + -- 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 teamDB + let recipByKey = LocalActorProject projectID + acceptID <- insertEmptyOutboxItem' (actorOutbox actorRecip) now + _luAccept <- updateOutboxItem' recipByKey acceptID actionAccept + + return (projectActor project, sieve, acceptID, accept, inboxItemID) + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just (topicActorID, sieve, acceptID, (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept), inboxItemID) -> do + let topicByID = LocalActorProject projectID + forwardActivity authorIdMsig body topicByID topicActorID sieve + lift $ + sendActivity + topicByID topicActorID localRecipsAccept + remoteRecipsAccept fwdHostsAccept acceptID actionAccept + doneDB inboxItemID "[Team-active] Deleted the Team/Squad, forwarded Remove, sent Accept" + + where + + prepareAccept teamDB = do + encodeRouteHome <- getEncodeRouteHome + + audRemover <- lift $ makeAudSenderOnly authorIdMsig + audTeam <- + case teamDB of + Left (Entity g _) -> do + h <- encodeKeyHashid g + return $ AudLocal [LocalActorGroup h] [LocalStageGroupFollowers h] + Right (ObjURI h lu, Entity _ ra) -> + return $ AudRemote h [lu] (maybeToList $ remoteActorFollowers ra) + audMe <- + AudLocal [] . pure . LocalStageProjectFollowers <$> + encodeKeyHashid projectID + uRemove <- lift $ getActivityURI authorIdMsig + + let (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audRemover, audTeam, audMe] + + recips = map encodeRouteHome audLocal ++ audRemote + action = AP.Action + { AP.actionCapability = Nothing + , AP.actionSummary = Nothing + , AP.actionAudience = AP.Audience recips [] [] [] [] [] + , AP.actionFulfills = [uRemove] + , AP.actionSpecific = AP.AcceptActivity AP.Accept + { AP.acceptObject = uRemove + , AP.acceptResult = Nothing + } + } + + return (action, recipientSet, remoteActors, fwdHosts) + + removeTeamPassive team = do + + -- If team is local, find it in our DB + -- If team is remote, HTTP GET it, verify it's an actor of Project + -- type, and store in our DB (if it's already there, no need for HTTP) + -- + -- NOTE: This is a blocking HTTP GET done right here in the handler, + -- which is NOT a good idea. Ideally, it would be done async, and the + -- handler result would be sent later in a separate (e.g. Accept) activity. + -- But for the PoC level, the current situation will hopefully do. + teamDB <- + bitraverse + (\ g -> withDBExcept $ getEntityE g "Team not found in DB") + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ withDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor' instanceID h lu + case result of + Left Nothing -> throwE "Team @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Team isn't an actor" + Right (Just actor) -> do + case remoteActorType $ entityVal actor of + AP.ActorTypeTeam -> pure () + _ -> throwE "Remote team type isn't Team" + return (u, actor) + ) + team + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + (project, actorRecip) <- lift $ do + p <- getJust projectID + (p,) <$> getJust (projectActor p) + + -- Verify it's an active team of mine + squads <- lift $ case teamDB of + Left (Entity g _) -> + fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Left (t, s))) $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicLocalId E.==. send E.^. SquadThemSendDelegatorLocalTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicLocalSquad + E.where_ $ + squad E.^. SquadHolder E.==. E.val (projectResource project) E.&&. + topic E.^. SquadTopicLocalGroup E.==. E.val g + return + ( squad E.^. SquadId + , send E.^. SquadThemSendDelegatorLocalSquad + , start E.^. SquadUsStartId + , topic E.^. SquadTopicLocalId + , send E.^. SquadThemSendDelegatorLocalId + ) + Right (_, Entity a _) -> + fmap (map $ \ (d, a, z, E.Value t, E.Value s) -> (d, a, z, Right (t, s))) $ + E.select $ E.from $ \ (squad `E.InnerJoin` topic `E.InnerJoin` send `E.InnerJoin` accept `E.InnerJoin` start) -> do + E.on $ accept E.^. SquadUsAcceptId E.==. start E.^. SquadUsStartSquad + E.on $ squad E.^. SquadId E.==. accept E.^. SquadUsAcceptSquad + E.on $ topic E.^. SquadTopicRemoteId E.==. send E.^. SquadThemSendDelegatorRemoteTopic + E.on $ squad E.^. SquadId E.==. topic E.^. SquadTopicRemoteSquad + E.where_ $ + squad E.^. SquadHolder E.==. E.val (projectResource project) E.&&. + topic E.^. SquadTopicRemoteTopic E.==. E.val a + return + ( squad E.^. SquadId + , send E.^. SquadThemSendDelegatorRemoteSquad + , start E.^. SquadUsStartId + , topic E.^. SquadTopicRemoteId + , send E.^. SquadThemSendDelegatorRemoteId + ) + + (E.Value squadID, E.Value usAcceptID, E.Value squadStartID, topic) <- + verifySingleE squads "No squad" "Multiple squads" + + maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False + lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do + + return inboxItemID + + case maybeNew of + Nothing -> done "I already have this activity in my inbox" + Just inboxItemID -> + doneDB inboxItemID "[Team-passive] Saw the removal attempt, just waiting for the Revoke" + -- Meaning: An actor is revoking Grant activities -- Behavior: -- * For each revoked activity: