From 710bfc27c0719164e72c3b873a29c0f3312135b3 Mon Sep 17 00:00:00 2001
From: Pere Lev <pere@towards.vision>
Date: Wed, 28 Jun 2023 09:38:53 +0300
Subject: [PATCH] C2S: When HTTP GETing an Invite/Remove topic, compare with
 collabs URI

Until now the code GETs the collabs URI to find the resource, but it
didn't make sure the URI was really the collabs URI specified by the
resource. This commit adds the check.
---
 src/Vervis/Actor/Person/Client.hs |  3 +++
 src/Vervis/Client.hs              |  6 ++++++
 src/Web/ActivityPub.hs            | 26 ++++++++++++++++++++++++++
 3 files changed, 35 insertions(+)

diff --git a/src/Vervis/Actor/Person/Client.hs b/src/Vervis/Actor/Person/Client.hs
index ffa905a..c3e663f 100644
--- a/src/Vervis/Actor/Person/Client.hs
+++ b/src/Vervis/Actor/Person/Client.hs
@@ -507,6 +507,9 @@ clientInvite now personMeID (ClientMsg maybeCap localRecips remoteRecips fwdHost
                 manager <- asksEnv envHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
+                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl) $
+                    throwE "Invite target isn't a collabs list"
 
                 instanceID <-
                     lift $ withDB $ either entityKey id <$> insertBy' (Instance h)
diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs
index 14aaa5c..9d6c47a 100644
--- a/src/Vervis/Client.hs
+++ b/src/Vervis/Client.hs
@@ -1011,6 +1011,9 @@ invite personID uRecipient uResourceCollabs role = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
+                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl) $
+                    throwE "Invite target isn't a collabs list"
                 return $ ObjURI h lu
             )
             resource
@@ -1104,6 +1107,9 @@ remove personID uRecipient uResourceCollabs = do
                 manager <- asksSite appHttpManager
                 coll <- ExceptT $ liftIO $ first T.pack <$> AP.fetchAPID manager AP.collectionId h luColl
                 lu <- fromMaybeE (AP.collectionContext (coll :: AP.Collection FedURI URIMode)) "Remote topic collabs has no 'context'"
+                AP.ResourceWithCollections _ mluCollabs _ <- ExceptT $ liftIO $ first (T.pack . show) <$> AP.fetchRWC manager h lu
+                unless (mluCollabs == Just luColl) $
+                    throwE "Remove origin isn't a collabs list"
                 return $ ObjURI h lu
             )
             resource
diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs
index e1b8131..7488079 100644
--- a/src/Web/ActivityPub.hs
+++ b/src/Web/ActivityPub.hs
@@ -49,6 +49,7 @@ module Web.ActivityPub
     , CollectionPage (..)
     , Recipient (..)
     , Resource (..)
+    , ResourceWithCollections (..)
     , Project (..)
 
       -- * Content objects
@@ -125,6 +126,7 @@ module Web.ActivityPub
     , fetchTip
     , fetchRecipient
     , fetchResource
+    , fetchRWC
     , keyListedByActor
     , fetchUnknownKey
     , fetchKnownPersonalKey
@@ -847,6 +849,24 @@ instance ActivityPub Resource where
         =  "id"        .= ObjURI h luId
         <> "managedBy" .= ObjURI h luManager
 
+data ResourceWithCollections u = ResourceWithCollections
+    { rwcResource   :: Resource u
+    , rwcCollabs    :: Maybe LocalURI
+    , rwcComponents :: Maybe LocalURI
+    }
+
+instance ActivityPub ResourceWithCollections where
+    jsonldContext _ = [as2Context, secContext, forgeContext]
+    parseObject o = do
+        (h, r) <- parseObject o
+        fmap (h,) $ ResourceWithCollections r
+            <$> withAuthorityMaybeO h (o .:? "collaborators")
+            <*> withAuthorityMaybeO h (o .:? "components")
+    toSeries h (ResourceWithCollections r collabs comps)
+        =  toSeries h r
+        <> "collaborators" .=? (ObjURI h <$> collabs)
+        <> "components"    .=? (ObjURI h <$> comps)
+
 data Project u = Project
     { projectActor      :: Actor u
     , projectTracker    :: Maybe (ObjURI u)
@@ -2602,6 +2622,12 @@ fetchResource m = fetchAPID' m getId
     getId (ResourceActor a)      = actorId $ actorLocal a
     getId (ResourceChild luId _) = luId
 
+fetchRWC :: UriMode u => Manager -> Authority u -> LocalURI -> IO (Either (Maybe APGetError) (ResourceWithCollections u))
+fetchRWC m = fetchAPID' m (getId . rwcResource)
+    where
+    getId (ResourceActor a)      = actorId $ actorLocal a
+    getId (ResourceChild luId _) = luId
+
 fetchAPID :: (MonadIO m, UriMode u, ActivityPub a) => Manager -> (a u -> LocalURI) -> Authority u -> LocalURI -> m (Either String (a u))
 fetchAPID m getId h lu = first showError <$> fetchAPID' m getId h lu
     where