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