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

@@ -0,0 +1,258 @@
+{- This file is part of Vervis.
+ -
+ - Written in 2023 by fr33domlover <fr33domlover@riseup.net>.
+ -
+ - ♡ 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
+ - <http://creativecommons.org/publicdomain/zero/1.0/>.
+ -}
+
+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)

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

vervis.cabal

@@ -256,6 +256,7 @@ library
                        Vervis.Time
 
                        Vervis.Web.Actor
+                       Vervis.Web.Collab
                        Vervis.Web.Darcs
                        Vervis.Web.Delivery
                        Vervis.Web.Discussion