From 1a3a46b6b2f856410720f7553b4f84985ef8d290 Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Tue, 7 Nov 2023 10:51:42 +0200 Subject: [PATCH 1/3] Implement OCAP "Verifying an invocation" process from ForgeFed spec Vervis currently supports only direct grants. The new process supports delegation chains as well. This commit just implements the new process as a new function, without yet using it anywhere. The next commits will plug it into Deck actor handlers. --- src/Vervis/Web/Collab.hs | 258 +++++++++++++++++++++++++++++++++++++++ src/Web/ActivityPub.hs | 3 + vervis.cabal | 1 + 3 files changed, 262 insertions(+) create mode 100644 src/Vervis/Web/Collab.hs diff --git a/src/Vervis/Web/Collab.hs b/src/Vervis/Web/Collab.hs new file mode 100644 index 0000000..4f0f2cc --- /dev/null +++ b/src/Vervis/Web/Collab.hs @@ -0,0 +1,258 @@ +{- This file is part of Vervis. + - + - Written in 2023 by fr33domlover . + - + - ♡ Copying is an act of love. Please copy, reuse and share. + - + - The author(s) have dedicated all copyright and related and neighboring + - rights to this software to the public domain worldwide. This software is + - distributed without any warranty. + - + - You should have received a copy of the CC0 Public Domain Dedication along + - with this software. If not, see + - . + -} + +module Vervis.Web.Collab + ( verifyCapability'' + ) +where + +import Control.Applicative +import Control.Exception.Base +import Control.Monad +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Data.Aeson +import Data.Bifunctor +import Data.Bitraversable +import Data.ByteString (ByteString) +import Data.Default.Class +import Data.Foldable +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import Data.Time.Clock +import Data.Traversable +import Database.Persist +import Network.HTTP.Client hiding (Proxy, proxy) +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status +import Optics.Core +import Text.Blaze.Html (Html) +import Yesod.Auth (requireAuth) +import Yesod.Core +import Yesod.Core.Handler (redirect, setMessage, lookupPostParam, notFound) +import Yesod.Form.Functions (runFormPost, runFormGet) +import Yesod.Form.Types (FormResult (..)) +import Yesod.Persist.Core (runDB, get404, getBy404) + +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Database.Esqueleto as E + +import Control.Concurrent.Actor +import Database.Persist.JSON +import Development.PatchMediaType +import Network.FedURI +import Web.ActivityPub hiding (Project (..), Repo (..), Actor (..), ActorDetail (..), ActorLocal (..)) +import Web.Actor +import Web.Actor.Persist +import Yesod.ActivityPub +import Yesod.Hashids +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Data.Either.Local +import Data.Paginate.Local +import Database.Persist.Local +import Yesod.Form.Local +import Yesod.Persist.Local + +import Vervis.Actor +import Vervis.Actor2 +import Vervis.Data.Actor +import Vervis.Data.Collab +import Vervis.FedURI +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Actor +import Vervis.Persist.Collab +import Vervis.Settings +import Vervis.Ticket +import Vervis.TicketFilter +import Vervis.Time + +import qualified Vervis.Recipient as VR + +verifyCapability'' + :: FedURI + -> Either + (LocalActorBy Key, ActorId, OutboxItemId) + (RemoteAuthor, LocalURI, Maybe ByteString) + -> GrantResourceBy Key + -> AP.Role + -> ActE () +verifyCapability'' uCap recipientActor resource requiredRole = do + manager <- asksEnv envHttpManager + encodeRouteHome <- getEncodeRouteHome + uResource <- + encodeRouteHome . VR.renderLocalActor <$> + hashLocalActor (grantResourceLocalActor resource) + now <- liftIO getCurrentTime + grants <- traverseGrants manager uResource now + unless (checkRole grants) $ + throwE "checkRole returns False" + where + traverseGrants 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 [] + where + go u@(ObjURI h lu) recipActor l = do + cap <- parseActivityURI' u + AP.Doc host activity <- + case cap of + Left (actor, _, itemID) -> withDBExcept $ do + 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 (AP.grantContext grant == uResource) $ + throwE "Grant.context isn't me, 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 + (capActor, capItem) <- + case cap of + Left (actor, _, itemID) -> return (actor, itemID) + Right _ -> throwE "Remote, so definitely not by me" + -- We already checked that the activity exists in DB + -- So proceed to 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 (grantResourceLocalActor topic == capActor) $ + error "Grant sender isn't the topic" + -- Verify the topic matches the resource specified + unless (topic == resource) $ + throwE "Capability topic is some other local resource" + return $ (u, activity, grant, role, targetIsProject, targetIsTeam) : l + + Just uParent -> nameExceptT "Extension-Grant" $ do + case cap of + Left (actor, _, _) + | grantResourceLocalActor resource == actor -> + throwE "Grant.delegates specified but Grant's actor is me" + _ -> return () + (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 $ (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 && role >= requiredRole + h@(_, _, next, role', _, _) : rest' -> + role' <= role && checkItem next && go h rest' role' + where + checkLeaf = AP.grantAllows grant == AP.Invoke + checkItem h = + AP.grantAllows grant == AP.GatherAndConvey && + targetIsProject + || + AP.grantAllows grant == AP.Distribute && + targetIsTeam && + (AP.grantAllows h == AP.Distribute || AP.grantAllows h == AP.Invoke) diff --git a/src/Web/ActivityPub.hs b/src/Web/ActivityPub.hs index d4dce07..b78bcd2 100644 --- a/src/Web/ActivityPub.hs +++ b/src/Web/ActivityPub.hs @@ -384,6 +384,7 @@ data ActorType | ActorTypeTicketTracker | ActorTypePatchTracker | ActorTypeProject + | ActorTypeTeam | ActorTypeOther Text deriving Eq @@ -394,6 +395,7 @@ parseActorType t | t == "TicketTracker" = ActorTypeTicketTracker | t == "PatchTracker" = ActorTypePatchTracker | t == "Project" = ActorTypeProject + | t == "Team" = ActorTypeTeam | otherwise = ActorTypeOther t renderActorType :: ActorType -> Text @@ -403,6 +405,7 @@ renderActorType = \case ActorTypeTicketTracker -> "TicketTracker" ActorTypePatchTracker -> "PatchTracker" ActorTypeProject -> "Project" + ActorTypeTeam -> "Team" ActorTypeOther t -> t instance FromJSON ActorType where diff --git a/vervis.cabal b/vervis.cabal index 5903770..0286bde 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -256,6 +256,7 @@ library Vervis.Time Vervis.Web.Actor + Vervis.Web.Collab Vervis.Web.Darcs Vervis.Web.Delivery Vervis.Web.Discussion From 34386bcf52ad23c4cf1a1ed3b893de1871f4ef2a Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sun, 12 Nov 2023 17:43:11 +0200 Subject: [PATCH 2/3] S2S: Deck: Resolve: Use the full OCAP-authorization algorithm deckResolve now supports Resolve requests that use extension-Grants. It iterates the verifies the Grant-chain using the process described in the ForgeFed specification. --- src/Vervis/Actor/Deck.hs | 17 ++++++++++ src/Vervis/Web/Collab.hs | 68 +++++++++++++++++++++++++++------------- 2 files changed, 64 insertions(+), 21 deletions(-) diff --git a/src/Vervis/Actor/Deck.hs b/src/Vervis/Actor/Deck.hs index 143f2f3..ecb1ab4 100644 --- a/src/Vervis/Actor/Deck.hs +++ b/src/Vervis/Actor/Deck.hs @@ -74,6 +74,7 @@ import Vervis.Persist.Collab import Vervis.Persist.Discussion import Vervis.RemoteActorStore import Vervis.Ticket +import Vervis.Web.Collab -- Meaning: An actor is adding some object to some target -- Behavior: @@ -518,6 +519,19 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do _ -> throwE "Local route but not a ticket of mine" taskID <- decodeKeyHashidE taskHash "Invalid TicketDeck keyhashid" + -- Verify that a capability is provided + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + + -- Verify the sender is authorized by the tracker to resolve a ticket + verifyCapability'' + uCap + authorIdMsig + (GrantResourceDeck deckID) + AP.RoleTriage + + {- -- Check capability capability <- do @@ -536,6 +550,7 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do Left (actorByKey, _, outboxItemID) -> return (actorByKey, outboxItemID) _ -> throwE "Capability is remote i.e. definitely not by me" + -} maybeNew <- withDBExcept $ do @@ -557,12 +572,14 @@ deckResolve now deckID (Verse authorIdMsig body) (AP.Resolve uObject) = do mractid <- lift $ insertToInbox now authorIdMsig body (actorInbox actorRecip) False for mractid $ \ resolveDB -> do + {- -- Verify the sender is authorized by the tracker to resolve a ticket verifyCapability' capability authorIdMsig (GrantResourceDeck deckID) AP.RoleTriage + -} -- Prepare forwarding the Resolve to my followers & ticket -- followers diff --git a/src/Vervis/Web/Collab.hs b/src/Vervis/Web/Collab.hs index 4f0f2cc..8ccf3b1 100644 --- a/src/Vervis/Web/Collab.hs +++ b/src/Vervis/Web/Collab.hs @@ -198,27 +198,53 @@ verifyCapability'' uCap recipientActor resource requiredRole = do Left (actor, _, itemID) -> return (actor, itemID) Right _ -> throwE "Remote, so definitely not by me" -- We already checked that the activity exists in DB - -- So proceed to 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 (grantResourceLocalActor topic == capActor) $ - error "Grant sender isn't the topic" - -- Verify the topic matches the resource specified - unless (topic == resource) $ - throwE "Capability topic is some other local resource" + -- 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 (grantResourceLocalActor topic == capActor) $ + error "Grant sender isn't the topic" + -- Verify the topic matches the resource specified + unless (topic == resource) $ + throwE "Capability topic is some other local 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 + unless (componentActor topic == grantResourceLocalActor resource) $ + throwE "Capability topic is some other local resource" + return $ (u, activity, grant, role, targetIsProject, targetIsTeam) : l Just uParent -> nameExceptT "Extension-Grant" $ do From 22c7b88a7922fb9cf0f2f46df264be0527f157fc Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Mon, 13 Nov 2023 14:15:13 +0200 Subject: [PATCH 3/3] Remove federation check from PublishResolveR --- src/Vervis/Handler/Client.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Vervis/Handler/Client.hs b/src/Vervis/Handler/Client.hs index 26fe558..02070a0 100644 --- a/src/Vervis/Handler/Client.hs +++ b/src/Vervis/Handler/Client.hs @@ -1289,8 +1289,8 @@ getPublishResolveR = do postPublishResolveR :: Handler () postPublishResolveR = do - federation <- getsYesod $ appFederation . appSettings - unless federation badMethod + --federation <- getsYesod $ appFederation . appSettings + --unless federation badMethod (uTicket, (uCap, cap)) <- runFormPostRedirect PublishResolveR resolveForm