S2S: Enforce max chain length when verifying OCAPs

config/settings-default.yaml

@@ -172,6 +172,9 @@ retry-delivery-base:
 # List of (hosts of) other known federating instances.
 #instances:              []
 
+# Maximal length we allow for Grant chains (default: 16)
+max-grant-chain-length: 16
+
 ###############################################################################
 # User interface
 ###############################################################################

src/Vervis/Settings.hs

@@ -1,6 +1,7 @@
 {- This file is part of Vervis.
  -
- - Written in 2016, 2018, 2019, 2022 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2016, 2018, 2019, 2022, 2024
+ - by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -196,6 +197,8 @@ data AppSettings = AppSettings
     , appInboxDebugReportLength   :: Maybe Int
       -- | List of (hosts of) other known federating instances.
     , appInstances                :: [Text]
+      -- | Maximal length we allow for Grant chains.
+    , appMaxGrantChainLength      :: Int
 
       -- | Default color scheme for syntax highlighting of code blocks inside
       -- documentes rendered with pandoc.
@@ -260,6 +263,7 @@ instance FromJSON AppSettings where
         appDeliveryRetryBase        <- interval <$> o .: "retry-delivery-base"
         appInboxDebugReportLength   <- o .:? "activity-debug-reports"
         appInstances                <- o .:? "instances" .!= []
+        appMaxGrantChainLength      <- o .:? "max-grant-chain-length" .!= 16
 
         appHighlightStyle           <- do
             s <- o .:? "highlight-style" .!= "zenburn"

src/Vervis/Web/Collab.hs

@@ -1,6 +1,6 @@
 {- This file is part of Vervis.
  -
- - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ - Written in 2023, 2024 by fr33domlover <fr33domlover@riseup.net>.
  -
  - ♡ Copying is an act of love. Please copy, reuse and share.
  -
@@ -96,23 +96,24 @@ verifyCapability''
     -> ActE ()
 verifyCapability'' uCap recipientActor resource requiredRole = do
     manager <- asksEnv envHttpManager
+    maxDepth <- appMaxGrantChainLength <$> asksEnv envSettings
     encodeRouteHome <- getEncodeRouteHome
     uResource <-
         encodeRouteHome . VR.renderLocalActor <$> hashLocalActor resource
     now <- liftIO getCurrentTime
-    grants <- traverseGrants manager uResource now
+    grants <- traverseGrants maxDepth manager uResource now
     unless (checkRole grants) $
         throwE "checkRole returns False"
     where
-    traverseGrants manager uResource now = do
+    traverseGrants maxDepth manager uResource now = do
         encodeRouteHome <- getEncodeRouteHome
         uActor <-
             case recipientActor of
                 Left (a, _, _) -> encodeRouteHome . VR.renderLocalActor <$> hashLocalActor a
                 Right (a, _, _) -> return $ remoteAuthorURI a
-        go uCap uActor []
+        go uCap uActor 1 []
         where
-        go u@(ObjURI h lu) recipActor l = do
+        go u@(ObjURI h lu) recipActor depth l = do
             cap <- parseActivityURI' u
             AP.Doc host activity <-
                 case cap of
@@ -247,6 +248,8 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
                     return $ (u, activity, grant, role, targetIsProject, targetIsTeam) : l
 
                 Just uParent -> nameExceptT "Extension-Grant" $ do
+                    when (depth >= maxDepth) $
+                        throwE "Chain is longer than the max depth"
                     case cap of
                         Left (actor, _, _)
                             | resource == actor ->
@@ -262,7 +265,7 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
                     unless (status == ok200 || status == noContent204) $
                         throwE "Result URI gave neither 200 nor 204 status"
                     let uNextRecip = ObjURI host $ AP.activityActor activity
-                    go uParent uNextRecip $ (u, activity, grant, role, targetIsProject, targetIsTeam) : l
+                    go uParent uNextRecip (depth + 1) $ (u, activity, grant, role, targetIsProject, targetIsTeam) : l
     checkRole [] = error "Ended up with empty list of grants, impossible"
     checkRole (g:gs) = go g gs (view _4 g)
         where