From 7b64ab56b17cc187cfcdbdbbf8a9024b93a98197 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Fri, 16 Jun 2023 23:42:50 +0300 Subject: [PATCH] S2S Remove handlers for Person and Deck --- src/Vervis/Actor/Common.hs | 227 +++++++++++++++++++++++++++++++++- src/Vervis/Actor/Deck.hs | 23 ++++ src/Vervis/Actor/Person.hs | 52 ++++++++ src/Vervis/Data/Collab.hs | 63 ++++++---- src/Vervis/Federation/Util.hs | 2 +- src/Web/ActivityPub.hs | 21 ++++ 6 files changed, 361 insertions(+), 27 deletions(-) diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 9a5e94b..2717302 100644 --- a/src/Vervis/Actor/Common.hs +++ b/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 diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 398ea10..fa91bc1 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/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" diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index c11e86e..4459943 100644 --- a/src/Vervis/Actor/Person.hs +++ b/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" diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index f8b09a7..211848d 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -27,6 +27,7 @@ module Vervis.Data.Collab , parseGrant , parseAccept , parseReject + , parseRemove , grantResourceActorID @@ -138,6 +139,30 @@ parseTopic u = do pure routeOrRemote +parseRecipient sender u = do + routeOrRemote <- parseFedURI u + bitraverse + (\ route -> do + recipHash <- + fromMaybeE + (parseGrantRecip route) + "Not a grant recipient route" + recipKey <- + unhashGrantRecipE + recipHash + "Contains invalid hashid" + case recipKey of + GrantRecipPerson p | Left (LocalActorPerson p) == sender -> + throwE "Invite local sender and recipient are the same Person" + _ -> return recipKey + ) + (\ u -> do + when (Right u == sender) $ + throwE "Invite remote sender and recipient are the same actor" + return u + ) + routeOrRemote + parseInvite :: StageRoute Env ~ Route App => Either (LocalActorBy Key) FedURI @@ -149,31 +174,7 @@ parseInvite 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 - recipHash <- - fromMaybeE - (parseGrantRecip route) - "Not a grant recipient route" - recipKey <- - unhashGrantRecipE - recipHash - "Contains invalid hashid" - case recipKey of - GrantRecipPerson p | Left (LocalActorPerson p) == sender -> - throwE "Invite local sender and recipient are the same Person" - _ -> return recipKey - ) - (\ u -> do - when (Right u == sender) $ - throwE "Invite remote sender and recipient are the same actor" - return u - ) - routeOrRemote + <*> nameExceptT "Invite object" (parseRecipient sender object) parseJoin :: StageRoute Env ~ Route App @@ -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 diff --git a/src/Vervis/Federation/Util.hs b/src/Vervis/Federation/Util.hs index f18cae5..8045df0 100644 --- a/src/Vervis/Federation/Util.hs +++ b/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 diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index 928701f..07be975 100644 --- a/src/Web/ActivityPub.hs +++ b/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