diff --git a/src/Vervis/Actor/Project.hs b/src/Vervis/Actor/Project.hs index 534def9..3f2bd9e 100644 --- a/src/Vervis/Actor/Project.hs +++ b/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 diff --git a/src/Vervis/Web/Collab.hs b/src/Vervis/Web/Collab.hs index eef8453..7a3d5f7 100644 --- a/src/Vervis/Web/Collab.hs +++ b/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)