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

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

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

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