diff --git a/src/Vervis/Actor/Common.hs b/src/Vervis/Actor/Common.hs index 364758c..bf1fca8 100644 --- a/src/Vervis/Actor/Common.hs +++ b/src/Vervis/Actor/Common.hs @@ -1,6 +1,7 @@ {- This file is part of Vervis. - - - Written in 2019, 2020, 2022, 2023 by fr33domlover . + - Written in 2019, 2020, 2022, 2023, 2024 + - by fr33domlover . - - ♡ 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) diff --git a/src/Vervis/Actor/Person.hs b/src/Vervis/Actor/Person.hs index a8ec28a..b36c7d0 100644 --- a/src/Vervis/Actor/Person.hs +++ b/src/Vervis/Actor/Person.hs @@ -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 . - - ♡ 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" diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs index 67a754a..f0da743 100644 --- a/src/Vervis/Actor/Person/Client.hs +++ b/src/Vervis/Actor/Person/Client.hs @@ -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 diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index c15a590..41e8518 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -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] diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 2898aec..f3b7f3c 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -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