forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Vocab: Expand Remove activity parsing in preparation for child/parent mode

Browse source
This commit is contained in:
Pere Lev 2024-03-27 15:48:06 +02:00
parent 992e17f1ca
commit a1df4b3bdb
No known key found for this signature in database
GPG key ID: 5252C5C863E5E57D
5 changed files with 86 additions and 73 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -1,6 +1,7 @@
{- This file is part of Vervis.
-
- Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
- Written in 2019, 2020, 2022, 2023, 2024
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
-
@ -1285,22 +1286,20 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
(resource, memberOrComp) <- parseRemove author remove
unless (Left (Left $ topicResource topicKey) == resource) $
throwE "Remove topic isn't my collabs URI"
member <-
bitraverse
(\case
Left m -> pure m
Right _ -> throwE "Not accepting component actors as collabs"
)
pure
memberOrComp
return member
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 getGrantRecip "Member not found in DB")
(flip getEntityE "Member not found in DB")
(\ u@(ObjURI h lu) -> (,u) <$> do
maybeActor <- lift $ runMaybeT $ do
iid <- MaybeT $ getKeyBy $ UniqueInstance h
@ -1323,7 +1322,7 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
-- Find the collab that the member already has for me
existingCollabIDs <-
lift $ case memberDB of
Left (GrantRecipPerson (Entity personID _)) ->
Left (Entity personID _) ->
fmap (map $ over _2 Left) $
E.select $ E.from $ \ (topic `E.InnerJoin` recipl) -> do
E.on $
@ -1446,13 +1445,13 @@ topicRemove grabActor topicResource topicField topicCollabField now topicKey (Ve
recipHash <- encodeKeyHashid topicKey
let topicByHash = topicResource recipHash
memberHash <- bitraverse (hashGrantRecip . bmap entityKey) pure member
memberHash <- bitraverse (encodeKeyHashid . entityKey) pure member
audRemover <- makeAudSenderOnly authorIdMsig
let audience =
let audMember =
case memberHash of
Left (GrantRecipPerson p) ->
Left p ->
AudLocal [LocalActorPerson p] [LocalStagePersonFollowers p]
Right (Entity _ actor, ObjURI h lu) ->
AudRemote h [lu] (maybeToList $ remoteActorFollowers actor)

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

@ -1,6 +1,6 @@
{- This file is part of Vervis.
-
- Written in 2016, 2018, 2019, 2020, 2022, 2023
- Written in 2016, 2018, 2019, 2020, 2022, 2023, 2024
- by fr33domlover <fr33domlover@riseup.net>.
-
- ♡ Copying is an act of love. Please copy, reuse and share.
@ -760,7 +760,7 @@ personRemove now recipPersonID (Verse authorIdMsig body) remove = do
Just actorID -> do
let memberIsMe =
case memberOrComp of
Left (Left (GrantRecipPerson p)) -> p == recipPersonID
Left (LocalActorPerson p) -> p == recipPersonID
_ -> False
if not memberIsMe
then done "I'm not the member; Inserted to inbox"

36
src/Vervis/Actor/Person/Client.hs
View file

@ -1274,29 +1274,13 @@ clientRemove
clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHosts action) remove = do
-- Check input
(resourceOrComps, memberOrComp) <- parseRemove (Left $ LocalActorPerson personMeID) remove
resource <-
bitraverse
(\case
Left r -> pure r
Right _ -> throwE "Not accepting project components as target"
)
pure
resourceOrComps
member <-
bitraverse
(\case
Left r -> pure r
Right _ -> throwE "Not accepting component actors as collabs"
)
pure
memberOrComp
(resource, member) <- parseRemove (Left $ LocalActorPerson personMeID) remove
_capID <- fromMaybeE maybeCap "No capability provided"
-- If resource collabs is remote, HTTP GET it to determine resource
resource' <-
bitraverse
pure
(pure . either id addTargetActor)
(\ (ObjURI h luColl) -> do
manager <- asksEnv envHttpManager
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
@ -1316,7 +1300,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Verify that member is addressed by the Remove
bitraverse_
(verifyRecipientAddressed localRecips)
(verifyActorAddressed localRecips)
(verifyRemoteAddressed remoteRecips)
member
@ -1332,7 +1316,7 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- If member is local, find it in our DB
_memberDB <-
bitraverse
(flip getGrantRecip "Member not found in DB")
(flip getLocalActorEntityE "Member not found in DB")
pure
member
@ -1348,15 +1332,15 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
-- Prepare local recipients for Remove delivery
sieve <- lift $ do
resourceHash <- bitraverse hashLocalActor pure resource'
recipientHash <- bitraverse hashGrantRecip pure member
recipientHash <- bitraverse hashLocalActor pure member
senderHash <- encodeKeyHashid personMeID
let sieveActors = catMaybes
[ case resourceHash of
Left a -> Just a
Right _ -> Nothing
Right _ -> Nothing
, case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalActorPerson p
Right _ -> Nothing
Left a -> Just a
Right _ -> Nothing
]
sieveStages = catMaybes
[ Just $ LocalStagePersonFollowers senderHash
@ -1364,8 +1348,8 @@ clientRemove now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
Left a -> Just $ localActorFollowers a
Right _ -> Nothing
, case recipientHash of
Left (GrantRecipPerson p) -> Just $ LocalStagePersonFollowers p
Right _ -> Nothing
Left a -> Just $ localActorFollowers a
Right _ -> Nothing
]
return $ makeRecipientSet sieveActors sieveStages
return

25
src/Vervis/Client.hs
View file

@ -1279,30 +1279,14 @@ remove personID uRecipient uResourceCollabs = do
env <- asksSite appEnv
let activity = AP.Remove uRecipient uResourceCollabs
(resourceOrComps, recipientOrComp) <-
(resource, recipient) <-
runActE $ parseRemove (Left $ LocalActorPerson personID) activity
resource <-
bitraverse
(\case
Left r -> pure r
Right _-> throwE "Not accepting project components as target"
)
pure
resourceOrComps
recipient <-
bitraverse
(\case
Left r -> pure r
Right _ -> throwE "Not accepting component actors as collabs"
)
pure
recipientOrComp
-- If resource collabs is remote, we need to HTTP GET it to determine the
-- resource via collection 'context'
resource' <-
bitraverse
pure
(pure . either id addTargetActor)
(\ (ObjURI h luColl) -> do
manager <- asksSite appHttpManager
coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
@ -1337,7 +1321,7 @@ remove personID uRecipient uResourceCollabs = do
-- collection
recipientDB <-
bitraverse
(runActE . hashGrantRecip)
VR.hashLocalActor
(\ u@(ObjURI h lu) -> do
instanceID <-
lift $ runDB $ either entityKey id <$> insertBy' (Instance h)
@ -1363,8 +1347,7 @@ remove personID uRecipient uResourceCollabs = do
(maybeToList $ remoteActorFollowers remoteActor)
audRecipient =
case recipientDB of
Left (GrantRecipPerson p) ->
AudLocal [] [LocalStagePersonFollowers p]
Left la -> AudLocal [la] [localActorFollowers la]
Right (remoteActor, ObjURI h lu) ->
AudRemote h
[lu]

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

@ -352,17 +352,69 @@ parseReject (AP.Reject object) =
first (\ (actor, _, item) -> (actor, item)) <$>
nameExceptT "Reject object" (parseActivityURI' object)
parseAddTarget = \case
ProjectComponentsR j ->
ATProjectComponents <$>
WAP.decodeKeyHashidE j "Inavlid project components hashid"
ProjectParentsR j ->
ATProjectParents <$>
WAP.decodeKeyHashidE j "Inavlid project parents hashid"
ProjectChildrenR j ->
ATProjectChildren <$>
WAP.decodeKeyHashidE j "Inavlid project children hashid"
GroupParentsR g ->
ATGroupParents <$>
WAP.decodeKeyHashidE g "Inavlid team parents hashid"
GroupChildrenR g ->
ATGroupChildren <$>
WAP.decodeKeyHashidE g "Inavlid team children hashid"
_ -> throwE "Not an Add target collection route"
parseCollabs route = do
resourceHash <-
fromMaybeE
(parseGrantResourceCollabs route)
"Not a shared resource collabs route"
unhashLocalActorE
resourceHash
"Contains invalid hashid"
parseRemove
:: StageRoute Env ~ Route App
=> Either (LocalActorBy Key) FedURI
-> AP.Remove URIMode
-> ActE
( Either (Either (LocalActorBy Key) ProjectId) FedURI
, Either (Either (GrantRecipBy Key) (ComponentBy Key)) FedURI
( Either (Either (LocalActorBy Key) AddTarget) FedURI
, Either (LocalActorBy Key) FedURI
)
parseRemove sender (AP.Remove object origin) =
(,) <$> nameExceptT "Remove origin" (parseTopic' origin)
(,) <$> nameExceptT "Remove origin" (parseOrigin origin)
<*> nameExceptT "Remove object" (parseRecipient' sender object)
where
parseOrigin u = do
routeOrRemote <- parseFedURI u
bitraverse
(\ route ->
Left <$> parseCollabs route <|> Right <$> parseAddTarget route
)
pure
routeOrRemote
parseRecipient' sender u = do
routeOrRemote <- parseFedURI u
bitraverse
(\ route -> do
a <- parseLocalActorE' route
case a of
LocalActorPerson p | Left (LocalActorPerson p) == sender ->
throwE "Remove local sender and recipient are the same Person"
_ -> return a
)
(\ u -> do
when (Right u == sender) $
throwE "Remove remote sender and recipient are the same actor"
return u
)
routeOrRemote
data AddTarget
= ATProjectComponents ProjectId
@ -370,6 +422,7 @@ data AddTarget
| ATProjectChildren ProjectId
| ATGroupParents GroupId
| ATGroupChildren GroupId
deriving Eq
addTargetActor :: AddTarget -> LocalActorBy Key
addTargetActor = \case
@ -398,7 +451,7 @@ parseAdd sender (AP.Add object target role _context) = do
when (sender == component) $
throwE "Sender and component are the same"
case collection of
Left t | sender == Left (targetActor t) ->
Left t | sender == Left (addTargetActor t) ->
throwE "Sender and target collection actor are the same"
_ -> pure ()
return (component, collection, role)
@ -430,12 +483,6 @@ parseAdd sender (AP.Add object target role _context) = do
)
pure
routeOrRemote
targetActor = \case
ATProjectComponents j -> LocalActorProject j
ATProjectParents j -> LocalActorProject j
ATProjectChildren j -> LocalActorProject j
ATGroupParents g -> LocalActorGroup g
ATGroupChildren g -> LocalActorGroup g
grantResourceActorID :: LocalActorBy Identity -> ActorId
grantResourceActorID (LocalActorPerson (Identity p)) = personActor p