Merge remote-tracking branch 'upstream/main'

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

src/Vervis/Handler/Client.hs

@@ -1289,8 +1289,8 @@ getPublishResolveR = do
 
 postPublishResolveR :: Handler ()
 postPublishResolveR = do
-    federation <- getsYesod $ appFederation . appSettings
+    --federation <- getsYesod $ appFederation . appSettings
-    unless federation badMethod
+    --unless federation badMethod
 
     (uTicket, (uCap, cap)) <- runFormPostRedirect PublishResolveR resolveForm
 

src/Vervis/Web/Collab.hs

@@ -0,0 +1,284 @@
+{- 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 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
+                    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