forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S Remove handlers for Person and Deck

Browse source
This commit is contained in:
Pere Lev 2023-06-16 23:42:50 +03:00
parent 928ad8f9a9
commit 7b64ab56b1
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
6 changed files with 361 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

227
src/Vervis/Actor/Common.hs
View file

@ -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

23
src/Vervis/Actor/Deck.hs
View file

@ -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"

52
src/Vervis/Actor/Person.hs
View file

@ -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"

63
src/Vervis/Data/Collab.hs
View file

@ -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

2
src/Vervis/Federation/Util.hs
View file

@ -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

21
src/Web/ActivityPub.hs
View file

@ -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