S2S: Project: Remove: Copy topicRemove code to Project, preparing for new code

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 =
+projectRemove now projectID (Verse authorIdMsig body) remove = do
-    topicRemove
+
-        projectActor LocalActorProject
+    -- Check capability
-        CollabTopicProjectProject CollabTopicProjectCollab
+    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: