S2S: Component: Remove: Implement component mode, updated process

src/Vervis/Actor/Common.hs

@@ -22,7 +22,7 @@ module Vervis.Actor.Common
     , topicAccept
     , topicReject
     , componentInvite
-    , topicRemove
+    , componentRemove
     , topicJoin
     , topicCreateMe
     , componentGrant
@@ -89,6 +89,7 @@ import Vervis.Persist.Discussion
 import Vervis.Recipient (makeRecipientSet, LocalStageBy (..), Aud (..), collectAudience, localActorFollowers, renderLocalActor)
 import Vervis.RemoteActorStore
 import Vervis.Ticket
+import Vervis.Web.Collab
 
 actorFollow
     :: (PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r)
@@ -1235,49 +1236,95 @@ componentInvite grabKomponent topicComponent now topicKey (Verse authorIdMsig bo
 
         return (action, recipientSet, remoteActors, fwdHosts)
 
-topicRemove
+-- Meaning: An actor A is removing actor B from a collection C
-    :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+-- Behavior:
-    => (topic -> ResourceId)
+--  * If C is my collaborators collection
-    -> (forall f. f topic -> LocalResourceBy f)
+--      * Verify A isn't removing themselves
+--      * Verify A is authorized by me to remove actors from me
+--      * Verify B already has a Grant for me
+--      * Remove the whole Collab record from DB
+--      * Forward the Remove to my followers
+--      * Send a Revoke:
+--          * To: Actor B
+--          * CC: Actor A, B's followers, my followers
+--
+--  * If C is my projects collection
+--      * Verify A's request is authorized
+--      * Verify B is an enabled project of mine
+--      * Remove the whole Stem record from DB
+--      * Forward to followers
+--      * Publish a Revoke on the start-Grant I'd sent to B
+--          * 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
+componentRemove
+    :: forall topic.
+       (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
+    => (topic -> KomponentId)
+    -> (forall f. f topic -> ComponentBy f)
     -> UTCTime
     -> Key topic
     -> Verse
     -> AP.Remove URIMode
     -> ActE (Text, Act (), Next)
-topicRemove grabResource topicResource now topicKey (Verse authorIdMsig body) remove = do
+componentRemove grabKomponent topicComponent now topicKey (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
+    (collection, item) <- parseRemove author remove
-        unless (Left (Left $ topicResource topicKey) == resource) $
+    case (collection, item) of
-            throwE "Remove topic isn't my collabs URI"
+        (Left (Left lr), _)
+            | lr == topicResource topicKey ->
+                removeCollab item
+        (Left (Right target), _)
+            | addTargetComponentProjects target == Just (topicComponent topicKey) ->
+                removeProjectActive item
+        (_, Left la) | la == resourceToActor (topicResource topicKey) ->
+            case collection of
+                Left (Right (ATProjectComponents j)) ->
+                    removeProjectPassive $ Left j
+                Right (ObjURI h luColl) -> do
+                    -- NOTE this is HTTP GET done synchronously in the activity
+                    -- handler
+                    manager <- asksEnv envHttpManager
+                    c <- AP.fetchAPID_T manager (AP.collectionId :: AP.Collection FedURI URIMode -> LocalURI) h luColl
+                    lu <- fromMaybeE (AP.collectionContext c) "No context"
+                    rwc <- AP.fetchRWC_T manager h lu
+                    AP.Actor l d <-
+                        case AP.rwcResource rwc of
+                            AP.ResourceActor a -> pure a
+                            AP.ResourceChild _ _ -> throwE "Remove.target remote ResourceChild"
+                    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"
+                _ -> throwE "I'm being removed from somewhere irrelevant"
+        _ -> throwE "This Remove isn't for me"
+
+    where
+
+    topicResource :: forall f. f topic -> LocalResourceBy f
+    topicResource = componentResource . topicComponent
+
+    removeCollab item = do
+
+        memberByKey <-
             bitraverse
                 (\case
                     LocalActorPerson p -> pure p
                     _ -> throwE "Not accepting non-person actors as collabs"
                 )
                 pure
-            memberOrComp
+                item
+
+        -- Check capability
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the specified capability gives relevant access
+        verifyCapability'' uCap authorIdMsig (topicResource topicKey) AP.RoleAdmin
 
         maybeNew <- withDBExcept $ do
 
@@ -1295,14 +1342,11 @@ topicRemove grabResource topicResource now topicKey (Verse authorIdMsig body) re
                     memberByKey
 
             -- Grab me from DB
-        resourceID <- lift $ grabResource <$> getJust topicKey
+            komponentID <- lift $ grabKomponent <$> getJust topicKey
+            Komponent resourceID <- lift $ getJust komponentID
             Resource topicActorID <- lift $ getJust resourceID
             topicActor <- lift $ getJust topicActorID
 
-        -- Verify the specified capability gives relevant access
-        verifyCapability'
-            capability authorIdMsig (topicResource topicKey) AP.RoleAdmin
-
             -- Find the collab that the member already has for me
             existingCollabIDs <-
                 lift $ case memberDB of
@@ -1414,7 +1458,7 @@ topicRemove grabResource topicResource now topicKey (Verse authorIdMsig body) re
                 lift $ sendActivity
                     topicByID topicActorID localRecipsRevoke
                     remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
-            doneDB inboxItemID "Deleted the Grant/Collab, forwarded Remove, sent Revoke"
+                doneDB inboxItemID "[Collab] Deleted the Grant/Collab, forwarded Remove, sent Revoke"
 
         where
 
@@ -1458,6 +1502,220 @@ topicRemove grabResource topicResource now topicKey (Verse authorIdMsig body) re
 
             return (action, recipientSet, remoteActors, fwdHosts)
 
+    removeProjectActive item = do
+
+        project <-
+            bitraverse
+                (\case
+                    LocalActorProject j -> pure j
+                    _ -> throwE "Local object isn't a Project"
+                )
+                pure
+                item
+
+        -- Check capability
+        uCap <- do
+            let muCap = AP.activityCapability $ actbActivity body
+            fromMaybeE muCap "No capability provided"
+
+        -- Verify the specified capability gives relevant access
+        verifyCapability'' uCap authorIdMsig (topicResource topicKey) AP.RoleAdmin
+
+        maybeNew <- withDBExcept $ do
+
+            -- Find project in our DB
+            projectDB <-
+                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"
+                    )
+                    project
+
+            -- Grab me from DB
+            komponentID <- lift $ grabKomponent <$> getJust topicKey
+            Komponent resourceID <- lift $ getJust komponentID
+            Resource topicActorID <- lift $ getJust resourceID
+            topicActor <- lift $ getJust topicActorID
+
+            -- Find my Stem record for this project
+            existingStemIDs <-
+                lift $ case projectDB of
+                    Left (Entity projectID _) ->
+                        fmap (map $ over _1 Left) $
+                        E.select $ E.from $ \ (stem `E.InnerJoin` project) -> do
+                            E.on $ stem E.^. StemId E.==. project E.^. StemProjectLocalStem
+                            E.where_ $
+                                project E.^. StemProjectLocalProject E.==. E.val projectID E.&&.
+                                stem E.^. StemHolder E.==. E.val komponentID
+                            return
+                                ( project E.^. StemProjectLocalId
+                                , project E.^. StemProjectLocalStem
+                                )
+                    Right (Entity remoteActorID _, _) ->
+                        fmap (map $ over _1 Right) $
+                        E.select $ E.from $ \ (stem `E.InnerJoin` project) -> do
+                            E.on $ stem E.^. StemId E.==. project E.^. StemProjectRemoteStem
+                            E.where_ $
+                                project E.^. StemProjectRemoteProject E.==. E.val remoteActorID E.&&.
+                                stem E.^. StemHolder E.==. E.val komponentID
+                            return
+                                ( project E.^. StemProjectRemoteId
+                                , project E.^. StemProjectRemoteStem
+                                )
+            (recipID, E.Value stemID) <-
+                case existingStemIDs of
+                    [] -> throwE "Remove object isn't a project of mine"
+                    [stem] -> return stem
+                    _ -> error "Multiple Stems found for removee"
+
+            -- Verify the Stem is enabled
+            maybeDelegatorGrant <-
+                lift $
+                case recipID of
+                    Left (E.Value localID) -> fmap Left <$> getBy (UniqueStemProjectGrantLocalProject localID)
+                    Right (E.Value remoteID) -> fmap Right <$> getBy (UniqueStemProjectGrantRemoteProject remoteID)
+            delegatorGrant <- fromMaybeE maybeDelegatorGrant "Stem not enabled yet"
+
+            -- Grab start-Grant that I'm going to revoke
+            let componentAcceptID =
+                    case delegatorGrant of
+                        Left (Entity _ (StemProjectGrantLocal ca _ _)) -> ca
+                        Right (Entity _ (StemProjectGrantRemote ca _ _)) -> ca
+            Entity startID (StemDelegateLocal _ grantID) <- do
+                maybeStart <-
+                    lift $ getBy $ UniqueStemDelegateLocal componentAcceptID
+                fromMaybeE maybeStart "Start-Grant not sent yet"
+
+            maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+            lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
+
+                -- Delete the whole Stem record
+                usOrThem <-
+                    requireEitherAlt
+                        (getKeyBy $ UniqueStemOriginAdd stemID)
+                        (getKeyBy $ UniqueStemOriginInvite stemID)
+                        "Neither us nor them"
+                        "Both us and them"
+
+                delete startID
+                case delegatorGrant of
+                    Left (Entity localID _) -> delete localID
+                    Right (Entity remoteID _) -> delete remoteID
+                case usOrThem of
+                    Left usID -> delete usID
+                    Right themID -> do
+                        deleteBy $ UniqueStemProjectAcceptLocal themID
+                        deleteBy $ UniqueStemProjectGestureRemote themID
+                        deleteBy $ UniqueStemProjectGestureLocal themID
+                        delete themID
+                delete componentAcceptID
+                deleteBy $ UniqueStemComponentGestureLocal stemID
+                deleteBy $ UniqueStemComponentGestureRemote stemID
+                case recipID of
+                    Left (E.Value localID) -> delete localID
+                    Right (E.Value remoteID) -> delete remoteID
+                delete stemID
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid topicKey
+                    let topicByHash = resourceToActor $ topicResource topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                -- Prepare a Revoke activity and insert to my outbox
+                revoke@(actionRevoke, _, _, _) <-
+                    lift $ prepareRevoke projectDB grantID
+                let recipByKey = resourceToActor $ topicResource topicKey
+                revokeID <- insertEmptyOutboxItem' (actorOutbox topicActor) now
+                _luRevoke <- updateOutboxItem' recipByKey revokeID actionRevoke
+
+                return (topicActorID, sieve, revokeID, revoke, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve, revokeID, (actionRevoke, localRecipsRevoke, remoteRecipsRevoke, fwdHostsRevoke), inboxItemID) -> do
+                let topicByID = resourceToActor $ topicResource topicKey
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                lift $ sendActivity
+                    topicByID topicActorID localRecipsRevoke
+                    remoteRecipsRevoke fwdHostsRevoke revokeID actionRevoke
+                doneDB inboxItemID "[Project-active] Deleted the Stem, forwarded Remove, sent Revoke"
+
+        where
+
+        prepareRevoke project grantID = do
+            encodeRouteHome <- getEncodeRouteHome
+            encodeRouteLocal <- getEncodeRouteLocal
+
+            recipHash <- encodeKeyHashid topicKey
+            let topicByHash = resourceToActor $ topicResource recipHash
+
+            projectHash <- bitraverse (encodeKeyHashid . entityKey) pure project
+
+            audRemover <- makeAudSenderOnly authorIdMsig
+            let audience =
+                    let audProject =
+                            case projectHash of
+                                Left j ->
+                                    AudLocal [LocalActorProject j] [LocalStageProjectFollowers j]
+                                Right (Entity _ actor, ObjURI h lu) ->
+                                    AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)
+                        audMe = AudLocal [] [localActorFollowers topicByHash]
+                    in  [audRemover, audProject, audMe]
+
+                (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)
+
+    removeProjectPassive _project = do
+
+        maybeNew <- withDBExcept $ do
+
+            -- Grab me from DB
+            komponentID <- lift $ grabKomponent <$> getJust topicKey
+            Komponent resourceID <- lift $ getJust komponentID
+            Resource topicActorID <- lift $ getJust resourceID
+            topicActor <- lift $ getJust topicActorID
+
+            maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox topicActor) False
+            lift $ for maybeRemoveDB $ \ (inboxItemID, _removeDB) -> do
+
+                -- Prepare forwarding Remove to my followers
+                sieve <- lift $ do
+                    topicHash <- encodeKeyHashid topicKey
+                    let topicByHash = resourceToActor $ topicResource topicHash
+                    return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+                return (topicActorID, sieve, inboxItemID)
+
+        case maybeNew of
+            Nothing -> done "I already have this activity in my inbox"
+            Just (topicActorID, sieve, inboxItemID) -> do
+                let topicByID = resourceToActor $ topicResource topicKey
+                forwardActivity authorIdMsig body topicByID topicActorID sieve
+                doneDB inboxItemID "[Project-passive] Just forwarded Remove"
+
 topicJoin
     :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic)
     => (topic -> ResourceId)

src/Vervis/Actor/Deck.hs

@@ -627,24 +627,13 @@ deckInvite
     -> ActE (Text, Act (), Next)
 deckInvite = componentInvite deckKomponent ComponentDeck
 
--- Meaning: An actor A is removing actor B from a resource
--- Behavior:
---      * Verify the resource is me
---      * Verify A isn't removing themselves
---      * Verify A is authorized by me to remove actors from me
---      * Verify B already has a Grant for me
---      * Remove the whole Collab record from DB
---      * Forward the Remove to my followers
---      * Send a Revoke:
---          * To: Actor B
---          * CC: Actor A, B's followers, my followers
 deckRemove
     :: UTCTime
     -> DeckId
     -> Verse
     -> AP.Remove URIMode
     -> ActE (Text, Act (), Next)
-deckRemove = topicRemove deckResource LocalResourceDeck
+deckRemove = componentRemove deckKomponent ComponentDeck
 
 -- Meaning: An actor A asked to join a resource
 -- Behavior: