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

src/Vervis/Actor/Common.hs

@@ -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
-            bitraverse
+            (\case
-                (\case
+                LocalActorPerson p -> pure p
-                    Left m -> pure m
+                _ -> throwE "Not accepting non-person actors as collabs"
-                    Right _ -> throwE "Not accepting component actors as collabs"
+            )
-                )
+            pure
-                pure
+            memberOrComp
-                memberOrComp
-        return member
 
     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)

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

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, member) <- 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
     _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
+                        Left a -> Just a
-                        Right _                   -> Nothing
+                        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
+                        Left a -> Just $ localActorFollowers a
-                        Right _                   -> Nothing
+                        Right _                    -> Nothing
                     ]
             return $ makeRecipientSet sieveActors sieveStages
         return

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) ->
+                Left la -> AudLocal [la] [localActorFollowers la]
-                    AudLocal [] [LocalStagePersonFollowers p]
                 Right (remoteActor, ObjURI h lu) ->
                     AudRemote h
                         [lu]

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 (LocalActorBy Key) AddTarget) FedURI
-        , Either (Either (GrantRecipBy Key) (ComponentBy Key)) 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