S2S Remove handlers for Person and Deck

src/Vervis/Actor/Common.hs

@@ -20,7 +20,7 @@ module Vervis.Actor.Common
     , topicAccept
     , topicReject
     , topicInvite
-    --, topicHandleLocalInvite
+    , topicRemove
     , topicJoin
     )
 where
@@ -34,12 +34,14 @@ import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Maybe
 import Control.Monad.Trans.Reader
+import Data.Barbie
 import Data.Bifoldable
 import Data.Bifunctor
 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
@@ -806,6 +808,229 @@ topicInvite grabActor topicResource topicField topicCollabField collabTopicCtor
             Right remoteActorID ->
                 insert_ $ CollabRecipRemote collabID remoteActorID
 
+topicRemove
+    :: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
+       , PersistRecordBackend ct SqlBackend
+       )
+    => (topic -> ActorId)
+    -> (forall f. f topic -> GrantResourceBy f)
+    -> EntityField ct (Key topic)
+    -> EntityField ct CollabId
+    -> UTCTime
+    -> Key topic
+    -> Verse
+    -> AP.Remove URIMode
+    -> ActE (Text, Act (), Next)
+topicRemove grabActor topicResource topicField topicCollabField 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 "Invite 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, member) <- parseRemove author remove
+        unless (Left (topicResource topicKey) == resource) $
+            throwE "Remove topic isn't me"
+        return member
+
+    maybeNew <- withDBExcept $ do
+
+        -- Find member in our DB
+        memberDB <-
+            bitraverse
+                (flip getGrantRecip "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 topicKey
+            let actorID = grabActor recip
+            (actorID,) <$> getJust actorID
+
+        -- Verify the specified capability gives relevant access
+        verifyCapability' capability authorIdMsig (topicResource topicKey)
+
+        -- Find the collab that the member already has for me
+        existingCollabIDs <-
+            lift $ case memberDB of
+                Left (GrantRecipPerson (Entity personID _)) ->
+                    fmap (map $ over _2 Left) $
+                    E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
+                        E.on $
+                            topic E.^. topicCollabField E.==.
+                            recipl E.^. CollabRecipLocalCollab
+                        E.where_ $
+                            topic E.^. topicField E.==. E.val topicKey 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.^. topicCollabField E.==.
+                            recipr E.^. CollabRecipRemoteCollab
+                        E.where_ $
+                            topic E.^. topicField E.==. E.val topicKey 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.^. topicCollabField E.==.
+                    enable E.^. CollabEnableCollab
+                E.where_ $
+                    topic E.^. topicField E.==. E.val topicKey E.&&.
+                    topic E.^. topicCollabField E.!=. E.val collabID
+                return $ topic E.^. topicCollabField
+        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
+            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 topicKey
+                let topicByHash =
+                        grantResourceLocalActor $ topicResource topicHash
+                return $ makeRecipientSet [] [localActorFollowers topicByHash]
+
+            -- Prepare a Revoke activity and insert to my outbox
+            revoke@(actionRevoke, _, _, _) <-
+                lift $ prepareRevoke memberDB grantID
+            let recipByKey = grantResourceLocalActor $ topicResource topicKey
+            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 = grantResourceLocalActor $ topicResource topicKey
+            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 topicKey
+        let topicByHash = grantResourceLocalActor $ topicResource recipHash
+
+        memberHash <- bitraverse (hashGrantRecip . bmap entityKey) pure member
+
+        audRemover <- makeAudSenderOnly authorIdMsig
+        let audience =
+                let audMember =
+                        case memberHash of
+                            Left (GrantRecipPerson 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)
+
 topicJoin
     :: ( PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic
        , PersistRecordBackend ct SqlBackend

src/Vervis/Actor/Deck.hs

@@ -181,6 +181,28 @@ deckInvite =
         deckActor GrantResourceDeck
         CollabTopicDeckDeck CollabTopicDeckCollab CollabTopicDeck
 
+-- 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
+        deckActor GrantResourceDeck
+        CollabTopicDeckDeck CollabTopicDeckCollab
+
 -- Meaning: An actor A asked to join a resource
 -- Behavior:
 --      * Verify the resource is me
@@ -414,6 +436,7 @@ deckBehavior now deckID (Left verse@(Verse _authorIdMsig body)) =
         AP.InviteActivity invite -> deckInvite now deckID verse invite
         AP.JoinActivity join     -> deckJoin now deckID verse join
         AP.RejectActivity reject -> deckReject now deckID verse reject
+        AP.RemoveActivity remove -> deckRemove now deckID verse remove
         AP.UndoActivity undo     -> deckUndo now deckID verse undo
         _ -> throwE "Unsupported activity type for Deck"
 deckBehavior _ _ (Right _) = throwE "ClientMsgs aren't supported for Deck"

src/Vervis/Actor/Person.hs

@@ -476,6 +476,57 @@ personInvite now recipPersonID (Verse authorIdMsig body) invite = do
                         "I'm the target; Inserted to inbox; \
                         \Forwarded to followers if addressed"
 
+-- Meaning: Someone removed someone from a resource
+-- Behavior:
+--      * Insert to my inbox
+--      * If I'm the object, forward the Remove to my followers
+personRemove
+    :: UTCTime
+    -> PersonId
+    -> Verse
+    -> AP.Remove URIMode
+    -> ActE (Text, Act (), Next)
+personRemove now recipPersonID (Verse authorIdMsig body) remove = do
+
+    -- Check input
+    member <- do
+        let author = bimap (view _1) (remoteAuthorURI . view _1) authorIdMsig
+        (_resource, member) <- parseRemove author remove
+        return member
+
+    maybeNew <- withDBExcept $ do
+
+        -- Grab me from DB
+        (personRecip, actorRecip) <- lift $ do
+            p <- getJust recipPersonID
+            (p,) <$> getJust (personActor p)
+
+        maybeRemoveDB <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) True
+        for maybeRemoveDB $ \ _removeDB ->
+            return $ personActor personRecip
+
+    case maybeNew of
+        Nothing -> done "I already have this activity in my inbox"
+        Just actorID -> do
+            let memberIsMe =
+                    case member of
+                        Left (GrantRecipPerson p) -> p == recipPersonID
+                        _ -> False
+            if not memberIsMe
+                then done "I'm not the member; Inserted to inbox"
+                else do
+                    recipHash <- encodeKeyHashid recipPersonID
+                    let sieve =
+                            makeRecipientSet
+                                []
+                                [LocalStagePersonFollowers recipHash]
+                    forwardActivity
+                        authorIdMsig body (LocalActorPerson recipPersonID)
+                        actorID sieve
+                    done
+                        "I'm the member; Inserted to inbox; \
+                        \Forwarded to followers if addressed"
+
 -- Meaning: Someone asked to join a resource
 -- Behavior: Insert to my inbox
 personJoin
@@ -589,6 +640,7 @@ personBehavior now personID (Left verse@(Verse _authorIdMsig body)) =
         AP.InviteActivity invite -> personInvite now personID verse invite
         AP.JoinActivity join     -> personJoin now personID verse join
         AP.RejectActivity reject -> personReject now personID verse reject
+        AP.RemoveActivity remove -> personRemove now personID verse remove
         AP.RevokeActivity revoke -> personRevoke now personID verse revoke
         AP.UndoActivity undo     -> personUndo now personID verse undo
         _ -> throwE "Unsupported activity type for Person"

src/Vervis/Data/Collab.hs

@@ -27,6 +27,7 @@ module Vervis.Data.Collab
     , parseGrant
     , parseAccept
     , parseReject
+    , parseRemove
 
     , grantResourceActorID
 
@@ -138,20 +139,7 @@ parseTopic u = do
         pure
         routeOrRemote
 
-parseInvite
+parseRecipient sender u = do
-    :: StageRoute Env ~ Route App
-    => Either (LocalActorBy Key) FedURI
-    -> AP.Invite URIMode
-    -> ActE
-        ( Either (GrantResourceBy Key) FedURI
-        , Either (GrantRecipBy Key) FedURI
-        )
-parseInvite sender (AP.Invite instrument object target) = do
-    verifyRole instrument
-    (,) <$> nameExceptT "Invite target" (parseTopic target)
-        <*> nameExceptT "Invite object" (parseRecipient object)
-    where
-    parseRecipient u = do
     routeOrRemote <- parseFedURI u
     bitraverse
         (\ route -> do
@@ -175,6 +163,19 @@ parseInvite sender (AP.Invite instrument object target) = do
         )
         routeOrRemote
 
+parseInvite
+    :: StageRoute Env ~ Route App
+    => Either (LocalActorBy Key) FedURI
+    -> AP.Invite URIMode
+    -> ActE
+        ( Either (GrantResourceBy Key) FedURI
+        , Either (GrantRecipBy Key) FedURI
+        )
+parseInvite sender (AP.Invite instrument object target) = do
+    verifyRole instrument
+    (,) <$> nameExceptT "Invite target" (parseTopic target)
+        <*> nameExceptT "Invite object" (parseRecipient sender object)
+
 parseJoin
     :: StageRoute Env ~ Route App
     => AP.Join URIMode -> ActE (Either (GrantResourceBy Key) FedURI)
@@ -261,6 +262,18 @@ parseReject (AP.Reject object) =
     first (\ (actor, _, item) -> (actor, item)) <$>
         nameExceptT "Reject object" (parseActivityURI' object)
 
+parseRemove
+    :: StageRoute Env ~ Route App
+    => Either (LocalActorBy Key) FedURI
+    -> AP.Remove URIMode
+    -> ActE
+        ( Either (GrantResourceBy Key) FedURI
+        , Either (GrantRecipBy Key) FedURI
+        )
+parseRemove sender (AP.Remove object origin) =
+    (,) <$> nameExceptT "Remove origin" (parseTopic origin)
+        <*> nameExceptT "Remove object" (parseRecipient sender object)
+
 grantResourceActorID :: GrantResourceBy Identity -> ActorId
 grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r
 grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d

src/Vervis/Federation/Util.hs

@@ -53,7 +53,7 @@ insertToInbox
                 (RemoteAuthor, LocalURI, RemoteActivityId)
             )
         )
-insertToInbox now (Left a@(_, _, outboxItemID)) body inboxID unread = do
+insertToInbox now (Left a@(_, _, outboxItemID)) _body inboxID unread = do
     inboxItemID <- insert $ InboxItem unread now
     maybeItem <- insertUnique $ InboxItemLocal inboxID outboxItemID inboxItemID
     case maybeItem of

src/Web/ActivityPub.hs

@@ -80,6 +80,7 @@ module Web.ActivityPub
     , Offer (..)
     , Push (..)
     , Reject (..)
+    , Remove (..)
     , Resolve (..)
     , Revoke (..)
     , Undo (..)
@@ -1897,6 +1898,22 @@ parseReject o = Reject <$> o .: "object"
 encodeReject :: UriMode u => Reject u -> Series
 encodeReject (Reject obj) = "object" .= obj
 
+data Remove u = Remove
+    { removeObject :: ObjURI u
+    , removeOrigin :: ObjURI u
+    }
+
+parseRemove :: UriMode u => Object -> Parser (Remove u)
+parseRemove o =
+    Remove
+        <$> o .: "object"
+        <*> o .: "origin"
+
+encodeRemove :: UriMode u => Remove u -> Series
+encodeRemove (Remove obj origin)
+    =  "object" .= obj
+    <> "origin" .= origin
+
 data Resolve u = Resolve
     { resolveObject :: ObjURI u
     }
@@ -1992,6 +2009,7 @@ data SpecificActivity u
     | OfferActivity   (Offer u)
     | PushActivity    (Push u)
     | RejectActivity  (Reject u)
+    | RemoveActivity  (Remove u)
     | ResolveActivity (Resolve u)
     | RevokeActivity  (Revoke u)
     | UndoActivity    (Undo u)
@@ -2008,6 +2026,7 @@ activityType (JoinActivity _)    = "Join"
 activityType (OfferActivity _)   = "Offer"
 activityType (PushActivity _)    = "Push"
 activityType (RejectActivity _)  = "Reject"
+activityType (RemoveActivity _)  = "Remove"
 activityType (ResolveActivity _) = "Resolve"
 activityType (RevokeActivity _)  = "Revoke"
 activityType (UndoActivity _)    = "Undo"
@@ -2072,6 +2091,7 @@ instance ActivityPub Activity where
                         "Offer"   -> OfferActivity   <$> parseOffer o a actor
                         "Push"    -> PushActivity    <$> parsePush a o
                         "Reject"  -> RejectActivity  <$> parseReject o
+                        "Remove"  -> RemoveActivity  <$> parseRemove o
                         "Resolve" -> ResolveActivity <$> parseResolve o
                         "Revoke"  -> RevokeActivity  <$> parseRevoke a o
                         "Undo"    -> UndoActivity    <$> parseUndo a o
@@ -2100,6 +2120,7 @@ instance ActivityPub Activity where
         encodeSpecific h u (OfferActivity a)   = encodeOffer h u a
         encodeSpecific h _ (PushActivity a)    = encodePush h a
         encodeSpecific _ _ (RejectActivity a)  = encodeReject a
+        encodeSpecific _ _ (RemoveActivity a)  = encodeRemove a
         encodeSpecific _ _ (ResolveActivity a) = encodeResolve a
         encodeSpecific h _ (RevokeActivity a)  = encodeRevoke h a
         encodeSpecific h _ (UndoActivity a)    = encodeUndo h a