diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index bb10a38..16aec9e 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -1502,8 +1502,21 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo -- * 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, and C is some project's components collection -- * Just forward to my followers +-- +-- * 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 componentRemove :: forall topic. (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) @@ -1525,10 +1538,15 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo (Left (Right target), _) | addTargetComponentProjects target == Just (topicComponent topicKey) -> removeProjectActive item + (Left (Right target), _) + | (resourceFromNG <$> addTargetResourceTeams target) == Just meResource -> + removeTeamActive item (_, Left la) | la == resourceToActor (topicResource topicKey) -> case collection of Left (Right (ATProjectComponents j)) -> removeProjectPassive $ Left j + Left (Right (ATGroupEfforts g)) -> + removeTeamPassive $ Left g Right (ObjURI h luColl) -> do -- NOTE this is HTTP GET done synchronously in the activity -- handler @@ -1543,12 +1561,21 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo 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" + 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" where + toComponent = topicComponent + meID = topicKey + + meComponent = toComponent meID + meResource = componentResource meComponent + meActor = resourceToActor meResource + topicResource :: forall f. f topic -> LocalResourceBy f topicResource = componentResource . topicComponent @@ -1961,6 +1988,276 @@ componentRemove grabKomponent topicComponent now topicKey (Verse authorIdMsig bo forwardActivity authorIdMsig body topicByID topicActorID sieve doneDB inboxItemID "[Project-passive] Just forwarded Remove" + 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 + meResource + AP.RoleAdmin + + maybeNew <- withDBExcept $ do + + -- Grab me from DB + meKomponentID <- lift $ grabKomponent <$> getJust meID + Komponent meResourceID <- lift $ getJust meKomponentID + Resource meActorID <- lift $ getJust meResourceID + meActorDB <- lift $ getJust meActorID + + -- 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 meResourceID 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 meResourceID 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 meActorDB) False + lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do + + -- 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 + h <- hashLocalActor meActor + return $ makeRecipientSet [] [localActorFollowers h] + + -- Prepare Accept activity + accept@(actionAccept, _, _, _) <- prepareAccept teamDB + acceptID <- insertEmptyOutboxItem' (actorOutbox meActorDB) now + _luAccept <- updateOutboxItem' meActor acceptID actionAccept + + return (meActorID, 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 + forwardActivity authorIdMsig body meActor topicActorID sieve + lift $ + sendActivity + meActor 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 . localActorFollowers <$> + hashLocalActor meActor + 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 + meKomponentID <- lift $ grabKomponent <$> getJust meID + Komponent meResourceID <- lift $ getJust meKomponentID + Resource meActorID <- lift $ getJust meResourceID + meActorDB <- lift $ getJust meActorID + + -- 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 meResourceID 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 meResourceID 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 meActorDB) 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" + topicJoin :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) => (topic -> ResourceId)