S2S: Project: Grant: Before extending a Grant, test to avoid infinite loop

src/Vervis/Actor/Project.hs

@@ -2946,6 +2946,9 @@ projectGrant now projectID (Verse authorIdMsig body) grant = do
 
     handleChild role sendID topic = do
 
+        uCap <- lift $ getActivityURI authorIdMsig
+        checkCapabilityBeforeExtending uCap (LocalActorProject projectID)
+
         maybeNew <- withDBExcept $ do
 
             -- Grab me from DB

src/Vervis/Web/Collab.hs

@@ -15,6 +15,7 @@
 
 module Vervis.Web.Collab
     ( verifyCapability''
+    , checkCapabilityBeforeExtending
     )
 where
 
@@ -284,3 +285,205 @@ verifyCapability'' uCap recipientActor resource requiredRole = do
                 AP.grantAllows grant == AP.Distribute &&
                 targetIsTeam &&
                 (AP.grantAllows h == AP.Distribute || AP.grantAllows h == AP.Invoke)
+
+checkCapabilityBeforeExtending
+    :: FedURI
+    -> LocalActorBy Key
+    -> ActE ()
+checkCapabilityBeforeExtending uCap extender = do
+    manager <- asksEnv envHttpManager
+    maxDepth <- appMaxGrantChainLength <$> asksEnv envSettings
+    encodeRouteHome <- getEncodeRouteHome
+    uExtender <-
+        encodeRouteHome . VR.renderLocalActor <$> hashLocalActor extender
+    now <- liftIO getCurrentTime
+    grants <- traverseGrants maxDepth manager uExtender now
+    unless (checkRole grants) $
+        throwE "checkRole returns False"
+    where
+    traverseGrants maxDepth manager uExtender now = go uCap uExtender (const True) 1 []
+        where
+        go u@(ObjURI h lu) recipActor resourceOk depth l = do
+            cap <- parseActivityURI' u
+            AP.Doc host activity <-
+                case cap of
+                    Left (actor, _, itemID) -> withDBExcept $ do
+                        when (actor == extender) $
+                            throwE "Found my own Grant in the chain"
+
+                        item <- getE itemID "No such OutboxItemId in DB"
+                        let outboxID = outboxItemOutbox item
+                        actorID <- do
+                            ma <- lift $ getKeyBy $ UniqueActorOutbox outboxID
+                            fromMaybeE ma "Item's outbox doesn't belong to any actor"
+                        itemActor <- lift $ getLocalActor actorID
+                        unless (itemActor == actor) $
+                            throwE "No such local activity in DB, actor and item mismatch"
+                        let obj = persistJSONDoc $ outboxItemActivity item
+                        case fromJSON $ Object obj of
+                            Error s -> throwE $ "Parsing local activity JSON object into an Activity failed: " <> T.pack s
+                            Success doc -> return doc
+                    Right _ -> do
+                        ract <- lift $ withDB $ runMaybeT $ do
+                            instanceID <- MaybeT $ getKeyBy $ UniqueInstance h
+                            objectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID lu
+                            MaybeT $ getValBy $ UniqueRemoteActivity objectID
+                        case ract of
+                            Just act -> do
+                                let obj = persistJSONDoc $ remoteActivityContent act
+                                case fromJSON $ Object obj of
+                                    Error s -> throwE $ "Parsing cached remote activity JSON object into an Activity failed: " <> T.pack s
+                                    Success doc -> return doc
+                            Nothing -> withExceptT T.pack $ AP.fetchAP manager $ Left u
+            luId <- fromMaybeE (AP.activityId activity) "Activity without id"
+            unless (u == ObjURI host luId) $
+                throwE "Fetched URI and activity id mismatch"
+            grant <-
+                case AP.activitySpecific activity of
+                    AP.GrantActivity g -> return g
+                    _ -> throwE "Not a Grant activity"
+
+            unless (resourceOk $ AP.grantContext grant) $
+                throwE "Grant.context isn't the resource"
+            unless (AP.grantTarget grant == recipActor) $
+                throwE "Grant.target isn't the actor of the previous grant"
+            when (any ((== u) . view _1) l) $
+                throwE "This Grant is already listed in l"
+            for_ (AP.grantStart grant) $ \ start ->
+                unless (start <= now) $
+                    throwE "Grant starts in the future"
+            for_ (AP.grantEnd grant) $ \ end ->
+                unless (now < end) $
+                    throwE "Grant has already expired"
+
+            role <-
+                case AP.grantObject grant of
+                    AP.RXRole r -> pure r
+                    RXDelegator -> throwE "Role is delegator"
+            (targetIsProject, targetIsTeam) <- do
+                routeOrRemote <- parseFedURI $ AP.grantTarget grant
+                case routeOrRemote of
+                    Left route -> do
+                        actor <- nameExceptT "Grant.target" $ parseLocalActorE' route
+                        return $
+                            case actor of
+                                LocalActorGroup _ -> (False, True)
+                                LocalActorProject _ -> (True, False)
+                                _ -> (False, False)
+                    Right (ObjURI hTarget luTarget) -> do
+                        mact <- lift $ withDB $ runMaybeT $ do
+                            instanceID <- MaybeT $ getKeyBy $ UniqueInstance h
+                            objectID <- MaybeT $ getKeyBy $ UniqueRemoteObject instanceID lu
+                            MaybeT $ getValBy $ UniqueRemoteActor objectID
+                        typ <-
+                            case mact of
+                                Just act -> return $ remoteActorType act
+                                Nothing -> do
+                                    actor <- ExceptT $ first T.pack <$> AP.fetchAPID manager (AP.actorId . AP.actorLocal) hTarget luTarget
+                                    return $ AP.actorType $ AP.actorDetail actor
+                        return (typ == AP.ActorTypeProject, typ == AP.ActorTypeTeam)
+
+            case AP.grantDelegates grant of
+
+                Nothing -> nameExceptT "Leaf-Grant" $ withDBExcept $ do
+                    let hContext = objUriAuthority $ AP.grantContext grant
+                    unless (host == hContext) $
+                        throwE "Start-Grant id and context are from different hosts"
+                    case cap of
+                        Left (capActor, _, capItem) -> do
+                            -- We already checked that the activity exists in DB
+                            -- So proceed to find the Collab or Stem record
+                            if null l
+
+                                -- This is thr only Grant in the chain, so we're
+                                -- looking for a Collab record
+                                then nameExceptT "Collab" $ do
+                                    -- Find the Collab record
+                                    collabID <- do
+                                        maybeEnable <- lift $ getValBy $ UniqueCollabEnableGrant capItem
+                                        collabEnableCollab <$>
+                                            fromMaybeE maybeEnable "No CollabEnable for this activity"
+                                    -- Find the recipient of that Collab
+                                    recipID <-
+                                        lift $ bimap collabRecipLocalPerson collabRecipRemoteActor <$>
+                                            requireEitherAlt
+                                                (getValBy $ UniqueCollabRecipLocal collabID)
+                                                (getValBy $ UniqueCollabRecipRemote collabID)
+                                                "No collab recip"
+                                                "Both local and remote recips for collab"
+                                    -- Find the local topic, on which this Collab gives access
+                                    topic <- lift $ getCollabTopic collabID
+                                    -- Verify that topic is indeed the sender of the Grant
+                                    unless (topic == capActor) $
+                                        error "Grant sender isn't the topic"
+                                    -- Verify the topic matches the resource specified
+                                    uTopic <- lift $ lift $ do
+                                        actorR <- VR.renderLocalActor <$> hashLocalActor topic
+                                        encodeRouteHome <- getEncodeRouteHome
+                                        return $ encodeRouteHome actorR
+                                    unless (uTopic == AP.grantContext grant) $
+                                        throwE "Capability topic is some other resource"
+
+                                -- There are more Grants in the chain, so we're
+                                -- looking for a Stem record
+                                else nameExceptT "Stem" $ do
+                                    -- Find the Stem record
+                                    stemID <- do
+                                        scaID <- do
+                                            maybeSCA <- lift $ getValBy $ UniqueStemDelegateLocalGrant capItem
+                                            stemDelegateLocalStem <$>
+                                                fromMaybeE maybeSCA "No StemDelegateLocal for this activity"
+                                        lift $ stemComponentAcceptStem <$> getJust scaID
+                                    -- Find the local topic, on which this Stem gives access
+                                    topic <- lift $ getStemIdent stemID
+                                    -- Verify that topic is indeed the sender of the Grant
+                                    unless (componentActor topic == capActor) $
+                                        error "Grant sender isn't the Stem ident"
+                                    -- Verify the topic matches the resource specified
+                                    uTopic <- lift $ lift $ do
+                                        actorR <- VR.renderLocalActor <$> hashLocalActor (componentActor topic)
+                                        encodeRouteHome <- getEncodeRouteHome
+                                        return $ encodeRouteHome actorR
+                                    unless (uTopic == AP.grantContext grant) $
+                                        throwE "Capability topic is some other resource"
+                        Right _ -> pure ()
+
+                    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"
+                    when (ObjURI host (AP.activityActor activity) == AP.grantContext grant) $
+                        throwE "Grant.delegates specified but Grant's actor is the resource"
+                    (luResult, _) <- fromMaybeE (AP.grantResult grant) "Grant.result not specified"
+                    req <- either (throwE . T.pack . displayException) pure $ requestFromURI $ uriFromObjURI $ ObjURI host luResult
+                    let req' =
+                            req { method = "HEAD"
+                                }
+                    response <- liftIO $ httpNoBody req' manager
+                    let status = responseStatus response
+                    unless (status == ok200 || status == noContent204) $
+                        throwE "Result URI gave neither 200 nor 204 status"
+                    let uNextRecip = ObjURI host $ AP.activityActor activity
+                    go uParent uNextRecip (== AP.grantContext grant) (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
+        go (u, activity, grant, _, targetIsProject, targetIsTeam) rest role =
+            case rest of
+                [] -> checkLeaf
+                h@(_, _, next, role', _, _) : rest' ->
+                    role' <= role && checkItem next && go h rest' role'
+            where
+            checkLeaf =
+                case (AP.grantAllows grant, extender) of
+                    (AP.GatherAndConvey, LocalActorProject _) -> True
+                    (AP.Distribute, LocalActorGroup _) -> True
+                    _ -> False
+            checkItem h =
+                AP.grantAllows grant == AP.GatherAndConvey &&
+                targetIsProject
+                ||
+                AP.grantAllows grant == AP.Distribute &&
+                targetIsTeam &&
+                (AP.grantAllows h == AP.Distribute || AP.grantAllows h == AP.Invoke)