From 8ec98e2a59e5644cef64afd17901f33b096c9e7a Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Thu, 8 Sep 2022 12:00:14 +0000 Subject: [PATCH] S2S: Invite->Accept->Grant (for Repo, Deck, Loom and Person, not for Group) Person inbox handler: - Invite: Parse and insert to inbox - Grant: Parse and insert to inbox Repo/Deck/Loom inbox handler: - Invite: Parse and remember as Collab record in DB for later - Accept: Send a Grant (and remember it in DB) Along with inviteC and acceptC, the Invite->Accept->Grant flow is now fully federated, yay! What's missing is UI for actually using it. Coming soon. --- src/Vervis/API.hs | 43 +-- src/Vervis/Access.hs | 22 +- src/Vervis/Data/Collab.hs | 60 ++- src/Vervis/Federation/Collab.hs | 636 ++++++++++++++++++++++++++++++++ src/Vervis/Handler/Deck.hs | 14 +- src/Vervis/Handler/Group.hs | 11 +- src/Vervis/Handler/Loom.hs | 12 +- src/Vervis/Handler/Person.hs | 5 + src/Vervis/Handler/Repo.hs | 14 +- src/Vervis/Persist/Actor.hs | 11 + src/Vervis/Persist/Collab.hs | 49 +++ src/Vervis/Web/Actor.hs | 6 +- vervis.cabal | 2 + 13 files changed, 809 insertions(+), 76 deletions(-) create mode 100644 src/Vervis/Federation/Collab.hs create mode 100644 src/Vervis/Persist/Collab.hs diff --git a/src/Vervis/API.hs b/src/Vervis/API.hs index a35fddc..70eacc8 100644 --- a/src/Vervis/API.hs +++ b/src/Vervis/API.hs @@ -52,6 +52,7 @@ import Data.ByteString (ByteString) import Data.Either import Data.Foldable import Data.Function +import Data.Functor.Identity import Data.List (sort, deleteBy, nub, union, unionBy, partition) import Data.List.NonEmpty (NonEmpty (..), nonEmpty) import Data.Maybe @@ -130,6 +131,8 @@ import Vervis.Model.Ident import Vervis.Model.Role import Vervis.Model.Workflow import Vervis.Model.Ticket +import Vervis.Persist.Actor +import Vervis.Persist.Collab import Vervis.Recipient import Vervis.RemoteActorStore import Vervis.Settings @@ -280,7 +283,8 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept -- If resource is local, verify it has received the Accept resourceByEntity <- getGrantResource resource "getGrantResource" - let resourceActorID = grantResourceActor resourceByEntity + let resourceActorID = + grantResourceActorID $ bmap (Identity . entityVal) resourceByEntity verifyActorHasItem resourceActorID acceptID "Local topic didn't receive the Accept" -- If Collab sender is local, verify it has received the Accept @@ -328,34 +332,6 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept where - parseAccept (Accept object mresult) = do - verifyNothingE mresult "Accept must not contain 'result'" - first (\ (actor, _, item) -> (actor, item)) <$> - nameExceptT "Accept object" (parseActivityURI object) - - getRemoteActorURI actor = do - object <- getJust $ remoteActorIdent actor - inztance <- getJust $ remoteObjectInstance object - return $ - ObjURI - (instanceHost inztance) - (remoteObjectIdent object) - - getCollabTopic collabID = do - maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID - maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID - maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID - return $ - case (maybeRepo, maybeDeck, maybeLoom) of - (Nothing, Nothing, Nothing) -> error "Found Collab without topic" - (Just r, Nothing, Nothing) -> - GrantResourceRepo $ collabTopicRepoRepo r - (Nothing, Just d, Nothing) -> - GrantResourceDeck $ collabTopicDeckDeck d - (Nothing, Nothing, Just l) -> - GrantResourceLoom $ collabTopicLoomLoom l - _ -> error "Found Collab with multiple topics" - verifySenderAddressed localRecips actor = do actorByHash <- hashLocalActor actor unless (actorIsAddressed localRecips actorByHash) $ @@ -379,11 +355,6 @@ acceptC (Entity senderPersonID senderPerson) senderActor summary audience accept update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc] return doc - grantResourceActor :: GrantResourceBy Entity -> ActorId - grantResourceActor (GrantResourceRepo (Entity _ r)) = repoActor r - grantResourceActor (GrantResourceDeck (Entity _ d)) = deckActor d - grantResourceActor (GrantResourceLoom (Entity _ l)) = loomActor l - insertGrantToOutbox :: KeyHashid Person -> Either (LocalActorBy Key, Entity Actor) (FedURI, Maybe LocalURI) @@ -1794,7 +1765,7 @@ inviteC inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience invite = do -- Check input - (resource, recipient) <- parseInvite (Just senderPersonID) invite + (resource, recipient) <- parseInvite (Left senderPersonID) invite ParsedAudience localRecips remoteRecips blinded fwdHosts <- do mrecips <- parseAudience audience recips <- fromMaybeE mrecips "Invite with no recipients" @@ -1981,8 +1952,6 @@ inviteC (Entity senderPersonID senderPerson) senderActor muCap summary audience Right (Right Nothing) -> Left ResultNotActor Right (Right (Just actor)) -> Right $ Right (roid, luManager, actor) - getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e - verifyRecipientAddressed localRecips recipient = do recipientHash <- hashGrantRecip recipient fromMaybeE (verify recipientHash) "Recipient not addressed" diff --git a/src/Vervis/Access.hs b/src/Vervis/Access.hs index 7df7099..3ef2777 100644 --- a/src/Vervis/Access.hs +++ b/src/Vervis/Access.hs @@ -67,8 +67,10 @@ module Vervis.Access , unhashGrantResourcePure , unhashGrantResource , unhashGrantResourceE + , unhashGrantResource404 , hashGrantResource , getGrantResource + , getGrantResource404 , grantResourceLocalActor @@ -85,12 +87,12 @@ import Control.Monad.Trans.Maybe import Control.Monad.Trans.Reader import Data.Barbie import Data.Bifunctor -import Data.Foldable import Data.Maybe import Data.Text (Text) import Database.Persist import Database.Persist.Sql import GHC.Generics +import Yesod.Core.Handler import qualified Database.Esqueleto as E @@ -101,8 +103,6 @@ import Control.Monad.Trans.Except.Local import Data.Either.Local import Database.Persist.Local -import Vervis.ActivityPub -import Vervis.FedURI import Vervis.Foundation import Vervis.Model import Vervis.Model.Role @@ -285,6 +285,8 @@ unhashGrantResource resource = do unhashGrantResourceE resource e = ExceptT $ maybe (Left e) Right <$> unhashGrantResource resource +unhashGrantResource404 = maybe notFound return <=< unhashGrantResource + hashGrantResource (GrantResourceRepo k) = GrantResourceRepo <$> encodeKeyHashid k hashGrantResource (GrantResourceDeck k) = @@ -299,16 +301,26 @@ getGrantResource (GrantResourceDeck k) e = getGrantResource (GrantResourceLoom k) e = GrantResourceLoom <$> getEntityE k e +getGrantResource404 = maybe notFound return <=< getGrantResourceEntity + where + getGrantResourceEntity (GrantResourceRepo k) = + fmap GrantResourceRepo <$> getEntity k + getGrantResourceEntity (GrantResourceDeck k) = + fmap GrantResourceDeck <$> getEntity k + getGrantResourceEntity (GrantResourceLoom k) = + fmap GrantResourceLoom <$> getEntity k + grantResourceLocalActor :: GrantResourceBy f -> LocalActorBy f grantResourceLocalActor (GrantResourceRepo r) = LocalActorRepo r grantResourceLocalActor (GrantResourceDeck d) = LocalActorDeck d grantResourceLocalActor (GrantResourceLoom l) = LocalActorLoom l verifyCapability - :: (LocalActorBy Key, OutboxItemId) + :: MonadIO m + => (LocalActorBy Key, OutboxItemId) -> Either PersonId RemoteActorId -> GrantResourceBy Key - -> ExceptT Text (ReaderT SqlBackend Handler) () + -> ExceptT Text (ReaderT SqlBackend m) () verifyCapability (capActor, capItem) actor resource = do -- Find the activity itself by URI in the DB diff --git a/src/Vervis/Data/Collab.hs b/src/Vervis/Data/Collab.hs index 9a4ef1b..fb98654 100644 --- a/src/Vervis/Data/Collab.hs +++ b/src/Vervis/Data/Collab.hs @@ -15,30 +15,41 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE UndecidableInstances #-} module Vervis.Data.Collab ( GrantRecipBy (..) + , parseInvite , parseGrant + , parseAccept + + , grantResourceActorID ) where +import Control.Monad import Control.Monad.Trans.Except import Data.Barbie +import Data.Bifunctor +import Data.Functor.Identity import Data.Text (Text) import Database.Persist.Types import GHC.Generics import Network.FedURI -import Web.ActivityPub import Yesod.ActivityPub import Yesod.FedURI import Yesod.Hashids import Yesod.MonadSite +import qualified Web.ActivityPub as AP + import Control.Monad.Trans.Except.Local import Vervis.Access +import Vervis.Data.Actor import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -46,6 +57,8 @@ import Vervis.Model data GrantRecipBy f = GrantRecipPerson (f Person) deriving (Generic, FunctorB, TraversableB, ConstraintsB) +deriving instance AllBF Eq f GrantRecipBy => Eq (GrantRecipBy f) + parseGrantRecip (PersonR p) = Just $ GrantRecipPerson p parseGrantRecip _ = Nothing @@ -62,18 +75,18 @@ unhashGrantRecipE resource e = ExceptT $ maybe (Left e) Right <$> unhashGrantRecip resource parseInvite - :: Maybe PersonId - -> Invite URIMode + :: Either PersonId FedURI + -> AP.Invite URIMode -> ExceptT Text Handler ( Either (GrantResourceBy Key) FedURI , Either (GrantRecipBy Key) FedURI ) -parseInvite maybeSenderID (Invite instrument object target) = do +parseInvite sender (AP.Invite instrument object target) = do verifyRole instrument (,) <$> parseTopic target <*> parseRecipient object where - verifyRole (Left RoleAdmin) = pure () + verifyRole (Left AP.RoleAdmin) = pure () verifyRole (Right _) = throwE "ForgeFed Admin is the only role allowed currently" parseTopic u@(ObjURI h lu) = do @@ -114,24 +127,26 @@ parseInvite maybeSenderID (Invite instrument object target) = do recipHash "Invite object contains invalid hashid" case recipKey of - GrantRecipPerson p | Just p == maybeSenderID -> - throwE "Invite sender and recipient are the same Person" + GrantRecipPerson p | Left p == sender -> + throwE "Invite local sender and recipient are the same Person" _ -> return recipKey - else pure $ Right u + else Right <$> do + when (Right u == sender) $ + throwE "Invite remote sender and recipient are the same actor" + return u parseGrant - :: Maybe PersonId - -> Grant URIMode + :: AP.Grant URIMode -> ExceptT Text Handler ( Either (GrantResourceBy Key) FedURI , Either (GrantRecipBy Key) FedURI ) -parseGrant maybeSenderID (Grant object context target) = do +parseGrant (AP.Grant object context target) = do verifyRole object (,) <$> parseContext context <*> parseTarget target where - verifyRole (Left RoleAdmin) = pure () + verifyRole (Left AP.RoleAdmin) = pure () verifyRole (Right _) = throwE "ForgeFed Admin is the only role allowed currently" parseContext u@(ObjURI h lu) = do @@ -167,12 +182,17 @@ parseGrant maybeSenderID (Grant object context target) = do fromMaybeE (parseGrantRecip route) "Grant target isn't a grant recipient route" - recipKey <- - unhashGrantRecipE - recipHash - "Grant target contains invalid hashid" - case recipKey of - GrantRecipPerson p | Just p == maybeSenderID -> - throwE "Grant sender and recipient are the same Person" - _ -> return recipKey + unhashGrantRecipE + recipHash + "Grant target contains invalid hashid" else pure $ Right u + +parseAccept (AP.Accept object mresult) = do + verifyNothingE mresult "Accept must not contain 'result'" + first (\ (actor, _, item) -> (actor, item)) <$> + nameExceptT "Accept object" (parseActivityURI object) + +grantResourceActorID :: GrantResourceBy Identity -> ActorId +grantResourceActorID (GrantResourceRepo (Identity r)) = repoActor r +grantResourceActorID (GrantResourceDeck (Identity d)) = deckActor d +grantResourceActorID (GrantResourceLoom (Identity l)) = loomActor l diff --git a/src/Vervis/Federation/Collab.hs b/src/Vervis/Federation/Collab.hs new file mode 100644 index 0000000..bb3d036 --- /dev/null +++ b/src/Vervis/Federation/Collab.hs @@ -0,0 +1,636 @@ +{- This file is part of Vervis. + - + - Written in 2022 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 + - . + -} + +{-# LANGUAGE RankNTypes #-} + +module Vervis.Federation.Collab + ( personInviteF + , topicInviteF + + , repoAcceptF + , deckAcceptF + , loomAcceptF + + , personGrantF + ) +where + +import Control.Exception hiding (Handler) +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Reader +import Data.Barbie +import Data.Bifunctor +import Data.Bitraversable +import Data.ByteString (ByteString) +import Data.Either +import Data.Foldable +import Data.Functor.Identity +import Data.List.NonEmpty (NonEmpty) +import Data.Maybe +import Data.Text (Text) +import Data.Time.Clock +import Data.Traversable +import Database.Persist +import Database.Persist.Sql +import Yesod.Persist.Core + +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T + +import Database.Persist.JSON +import Development.PatchMediaType +import Network.FedURI +import Yesod.ActivityPub +import Yesod.FedURI +import Yesod.Hashids +import Yesod.MonadSite + +import qualified Web.ActivityPub as AP + +import Control.Monad.Trans.Except.Local +import Data.Either.Local +import Data.Tuple.Local +import Database.Persist.Local +import Yesod.Persist.Local + +import Vervis.Access +import Vervis.ActivityPub +import Vervis.Data.Actor +import Vervis.Data.Collab +import Vervis.Delivery +import Vervis.FedURI +import Vervis.Federation.Auth +import Vervis.Federation.Util +import Vervis.Foundation +import Vervis.Model +import Vervis.Persist.Actor +import Vervis.Persist.Collab +import Vervis.Recipient +import Vervis.RemoteActorStore + +personInviteF + :: UTCTime + -> KeyHashid Person + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Invite URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +personInviteF now recipHash author body mfwd luInvite invite = (,Nothing) <$> do + + -- Check input + (resourceAndCap, recipient) <- do + + -- Check the invite-specific data + (resource, recip) <- + parseInvite (Right $ remoteAuthorURI author) invite + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + capability <- do + let muCap = AP.activityCapability $ actbActivity body + uCap <- fromMaybeE muCap "No capability provided" + nameExceptT "Invite capability" $ parseActivityURI uCap + + -- Verify that capability is either a local activity of a local + -- resource, or both resource and capability are of the same remote + -- instance + (,recip) <$> case (resource, capability) of + (Left r, Left (actor, _, item)) -> do + unless (grantResourceLocalActor r == actor) $ + throwE "Local capability belongs to actor that isn't the resource" + return $ Left (r, item) + (Left _, Right _) -> + throwE "Remote capability obviously doesn't belong to local resource" + (Right _, Left _) -> + throwE "Local capability obviously doesn't belong to remote resource" + (Right (ObjURI h r), Right (ObjURI h' c)) -> do + unless (h == h') $ + throwE "Capability and resource are on different remote instances" + return $ Right (ObjURI h r, c) + + -- Find recipient person in DB, returning 404 if doesn't exist because + -- we're in the person's inbox post handler + personRecipID <- decodeKeyHashid404 recipHash + mhttp <- runDBExcept $ do + (personRecip, actorRecip) <- lift $ do + p <- get404 personRecipID + (p,) <$> getJust (personActor p) + + mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luInvite True + for mractid $ \ inviteID -> do + + -- If resource is local, find it in our DB + _resourceDB <- + bitraverse + (flip getGrantResource "Invite local target not found in DB" . fst) + pure + resourceAndCap + + -- If recipient is local, find it in our DB + _recipientDB <- + bitraverse + (flip getGrantRecip "Invite local object not found in DB") + pure + recipient + + -- Forward the Invite activity to relevant local stages, and + -- schedule delivery for unavailable remote members of them + lift $ for mfwd $ \ (localRecips, sig) -> do + let inviteeIsRecip = + case recipient of + Left (GrantRecipPerson p) -> p == personRecipID + _ -> False + sieve = + if inviteeIsRecip + then makeRecipientSet [] [LocalStagePersonFollowers recipHash] + else makeRecipientSet [] [] + remoteRecips <- + insertRemoteActivityToLocalInboxes + False inviteID $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_P (actbBL body) inviteID personRecipID sig remoteRecips + + -- Launch asynchronous HTTP forwarding of the Invite activity + case mhttp of + Nothing -> return "I already have this activity in my inbox, doing nothing" + Just mremotesHttpFwd -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "personInviteF inbox-forwarding" $ + deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes + return $ + case mremotesHttpFwd of + Nothing -> "Inserted to inbox, no inbox-forwarding to do" + Just _ -> "Inserted to inbox and ran inbox-forwarding of the Invite" + +topicInviteF + :: UTCTime + -> GrantResourceBy KeyHashid + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Invite URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +topicInviteF now recipByHash author body mfwd luInvite invite = do + + -- Check input + uCap <- do + let muCap = AP.activityCapability $ actbActivity body + fromMaybeE muCap "No capability provided" + (resourceAndCap, recipient) <- do + + -- Check the invite-specific data + (resource, recip) <- + parseInvite (Right $ remoteAuthorURI author) invite + + -- Verify the capability URI is one of: + -- * Outbox item URI of a local actor, i.e. a local activity + -- * A remote URI + capability <- nameExceptT "Invite capability" $ parseActivityURI uCap + + -- Verify that capability is either a local activity of a local + -- resource, or both resource and capability are of the same remote + -- instance + (,recip) <$> case (resource, capability) of + (Left r, Left (actor, _, item)) -> do + unless (grantResourceLocalActor r == actor) $ + throwE "Local capability belongs to actor that isn't the resource" + return $ Left (r, item) + (Left _, Right _) -> + throwE "Remote capability obviously doesn't belong to local resource" + (Right _, Left _) -> + throwE "Local capability obviously doesn't belong to remote resource" + (Right (ObjURI h r), Right (ObjURI h' c)) -> do + unless (h == h') $ + throwE "Capability and resource are on different remote instances" + return $ Right (ObjURI h r, c) + + -- Find recipient topic in DB, returning 404 if doesn't exist because + -- we're in the topic's inbox post handler + recipByKey <- unhashGrantResource404 recipByHash + (_recipByEntity, recipActorID, recipActor) <- lift $ runDB $ do + recipE <- getGrantResource404 recipByKey + let actorID = grantResourceActorID $ bmap (Identity . entityVal) recipE + (recipE, actorID,) <$> getJust actorID + + -- Verify that Invite's topic is me, otherwise I don't need this Invite + capability <- + case resourceAndCap of + Left (resource, item) | resource == recipByKey -> return item + _ -> throwE "I'm not the Invite's topic, don't need this Invite" + + return $ (,) "Ran initial checks, doing the rest asynchronously" $ Just $ do + mhttp <- do + mractid <- lift $ runSiteDB $ insertToInbox now author body (actorInbox recipActor) luInvite False + for mractid $ \ inviteID -> do + + -- Verify the specified capability gives relevant access to the + -- resource + let recipLocalActorByKey = grantResourceLocalActor recipByKey + runSiteDBExcept $ + verifyCapability + (recipLocalActorByKey, capability) + (Right $ remoteAuthorId author) + recipByKey + + -- If recipient is remote, HTTP GET it, make sure it's an + -- actor, and insert it to our DB. If recipient is local, find + -- it in our DB. + recipientDB <- + bitraverse + (runSiteDBExcept . flip getGrantRecip "Invitee not found in DB") + (\ u@(ObjURI h lu) -> do + instanceID <- + lift $ runSiteDB $ either entityKey id <$> insertBy' (Instance h) + result <- + ExceptT $ first (T.pack . displayException) <$> + fetchRemoteActor instanceID h lu + case result of + Left Nothing -> throwE "Recipient @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Recipient isn't an actor" + Right (Just actor) -> return $ entityKey actor + ) + recipient + + lift $ runSiteDB $ do + + -- Insert Collab record to DB + insertCollab recipByKey recipientDB inviteID + + -- Forward the Invite activity to relevant local stages, + -- and schedule delivery for unavailable remote members of + -- them + for mfwd $ \ (localRecips, sig) -> do + let sieve = + makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor recipByHash] + remoteRecips <- + insertRemoteActivityToLocalInboxes + False inviteID $ + localRecipSieve' + sieve False False localRecips + case recipByKey of + GrantResourceRepo repoID -> do + repoHash <- encodeKeyHashid repoID + fwds <- deliverRemoteDB_R (actbBL body) inviteID repoID sig remoteRecips + return $ deliverRemoteHTTP_R now repoHash (actbBL body) sig fwds + GrantResourceDeck deckID -> do + deckHash <- encodeKeyHashid deckID + fwds <- deliverRemoteDB_D (actbBL body) inviteID deckID sig remoteRecips + return $ deliverRemoteHTTP_D now deckHash (actbBL body) sig fwds + GrantResourceLoom loomID -> do + loomHash <- encodeKeyHashid loomID + fwds <- deliverRemoteDB_L (actbBL body) inviteID loomID sig remoteRecips + return $ deliverRemoteHTTP_L now loomHash (actbBL body) sig fwds + + -- Launch asynchronous HTTP forwarding of the Invite activity + case mhttp of + Nothing -> return "I already have this activity in my inbox, doing nothing" + Just maybeForward -> do + traverse_ (forkWorker "topicInviteF inbox-forwarding") maybeForward + return $ + case maybeForward of + Nothing -> "Inserted Collab to DB, no inbox-forwarding to do" + Just _ -> "Inserted Collab to DB and ran inbox-forwarding of the Invite" + + where + + insertCollab resource recipient inviteID = do + collabID <- insert Collab + case resource of + GrantResourceRepo repoID -> + insert_ $ CollabTopicRepo collabID repoID + GrantResourceDeck deckID -> + insert_ $ CollabTopicDeck collabID deckID + GrantResourceLoom loomID -> + insert_ $ CollabTopicLoom collabID loomID + insert_ $ CollabFulfillsInviteRemote collabID (remoteAuthorId author) inviteID + case recipient of + Left (GrantRecipPerson (Entity personID _)) -> + insert_ $ CollabRecipLocal collabID personID + Right remoteActorID -> + insert_ $ CollabRecipRemote collabID remoteActorID + +topicAcceptF + :: (PersistRecordBackend topic SqlBackend, ToBackendKey SqlBackend topic) + => (topic -> ActorId) + -> (forall f. f topic -> GrantResourceBy f) + -> ( BL.ByteString + -> RemoteActivityId + -> Key topic + -> ByteString + -> [((InstanceId, Host), NonEmpty RemoteRecipient)] + -> ReaderT SqlBackend Handler + [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] + ) + -> ( UTCTime + -> KeyHashid topic + -> BL.ByteString + -> ByteString + -> [((InstanceId, Host), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId, Key fwder))] + -> Worker () + ) + -> UTCTime + -> KeyHashid topic + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Accept URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +topicAcceptF topicActor topicResource deliverRemoteDB deliverRemoteHTTP now recipHash author body mfwd luAccept accept = (,Nothing) <$> do + + -- Check input + acceptee <- parseAccept accept + + -- Find recipient topic in DB, returning 404 if doesn't exist because + -- we're in the topic's inbox post handler + recipKey <- decodeKeyHashid404 recipHash + mhttp <- runDBExcept $ do + (recipActorID, recipActor) <- lift $ do + recip <- get404 recipKey + let actorID = topicActor recip + (actorID,) <$> getJust actorID + + -- Find the accepted activity in our DB + accepteeDB <- do + a <- getActivity acceptee + fromMaybeE a "Can't find acceptee in DB" + + -- See if the accepted activity is an Invite to a local resource, + -- grabbing the Collab record from our DB + (collabID, inviteSender) <- + case accepteeDB of + Left (actorByKey, _actorEntity, itemID) -> do + maybeSender <- + lift $ getValBy $ UniqueCollabFulfillsInviteLocalInvite itemID + (,Left actorByKey) . collabFulfillsInviteLocalCollab <$> + fromMaybeE maybeSender "Accepted local activity isn't an Invite I'm aware of" + Right remoteActivityID -> do + maybeSender <- + lift $ getValBy $ UniqueCollabFulfillsInviteRemoteInvite remoteActivityID + CollabFulfillsInviteRemote collab actorID _ <- + fromMaybeE maybeSender "Accepted remote activity isn't an Invite I'm aware of" + actor <- lift $ getJust actorID + sender <- lift $ (,remoteActorFollowers actor) <$> getRemoteActorURI actor + return (collab, Right sender) + + -- Find the local resource and verify it's me + topic <- lift $ getCollabTopic collabID + unless (topicResource recipKey == topic) $ + throwE "Accept object is an Invite for some other resource" + + -- Find the Collab recipient and verify it's the sender of the Accept + recipID <- do + recip <- + lift $ + requireEitherAlt + (getBy $ UniqueCollabRecipLocal collabID) + (getBy $ UniqueCollabRecipRemote collabID) + "Found Collab with no recip" + "Found Collab with multiple recips" + case recip of + Right (Entity crrid crr) + | collabRecipRemoteActor crr == remoteAuthorId author -> return crrid + _ -> throwE "Accepting an Invite whose recipient is someone else" + + -- Verify the Collab isn't already validated + maybeEnabled <- lift $ getBy $ UniqueCollabEnable collabID + verifyNothingE maybeEnabled "I already sent a Grant for this Invite" + + -- Record the Accept on the Collab + mractid <- lift $ insertToInbox now author body (actorInbox recipActor) luAccept False + for mractid $ \ acceptID -> do + maybeAccept <- lift $ insertUnique $ CollabRecipRemoteAccept recipID acceptID + unless (isNothing maybeAccept) $ do + lift $ delete acceptID + throwE "This Invite already has an Accept by recip" + + -- Forward the Accept activity to relevant local stages, and + -- schedule delivery for unavailable remote members of them + maybeRemotesHttpFwdAccept <- lift $ for mfwd $ \ (localRecips, sig) -> do + let sieve = + makeRecipientSet [] [localActorFollowers $ grantResourceLocalActor $ topicResource recipHash] + remoteRecips <- + insertRemoteActivityToLocalInboxes + False acceptID $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB (actbBL body) acceptID recipKey sig remoteRecips + + remotesHttpGrant <- lift $ do + + -- Enable the Collab in our DB + grantID <- insertEmptyOutboxItem (actorOutbox recipActor) now + insert_ $ CollabEnable collabID grantID + + -- Prepare a Grant activity and insert to topic's outbox + (docGrant, localRecipsGrant, remoteRecipsGrant, fwdHostsGrant) <- + insertGrantToOutbox inviteSender grantID + + -- Deliver the Grant to local recipients, and schedule delivery + -- for unavailable remote recipients + (grantID, docGrant, fwdHostsGrant,) <$> do + knownRemoteRecipsGrant <- + deliverLocal' + False + (grantResourceLocalActor $ topicResource recipHash) + recipActorID + grantID + localRecipsGrant + deliverRemoteDB'' fwdHostsGrant grantID remoteRecipsGrant knownRemoteRecipsGrant + + return (maybeRemotesHttpFwdAccept, remotesHttpGrant) + + -- Launch asynchronous HTTP forwarding of the Accept activity + case mhttp of + Nothing -> return "I already have this activity in my inbox, doing nothing" + Just (mremotesHttpFwd, (grantID, docGrant, fwdHostsGrant, recipsGrant)) -> do + forkWorker "topicAcceptF Grant HTTP delivery" $ + deliverRemoteHttp' fwdHostsGrant grantID docGrant recipsGrant + case mremotesHttpFwd of + Nothing -> return "Sent a Grant, no inbox-forwarding to do" + Just (sig, remotes) -> do + forkWorker "topicAcceptF inbox-forwarding" $ + deliverRemoteHTTP now recipHash (actbBL body) sig remotes + return "Sent a Grant and ran inbox-forwarding of the Accept" + + where + + insertGrantToOutbox + :: Either (LocalActorBy Key) (FedURI, Maybe LocalURI) + -> OutboxItemId + -> ReaderT SqlBackend Handler + ( AP.Doc AP.Activity URIMode + , RecipientRoutes + , [(Host, NonEmpty LocalURI)] + , [Host] + ) + insertGrantToOutbox sender grantID = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + hLocal <- asksSite siteInstanceHost + + accepter <- getJust $ remoteAuthorId author + let topicByHash = grantResourceLocalActor $ topicResource recipHash + + senderHash <- bitraverse hashLocalActor pure sender + grantHash <- encodeKeyHashid grantID + + let audSender = + case senderHash of + Left actor -> AudLocal [actor] [localActorFollowers actor] + Right (ObjURI h lu, followers) -> + AudRemote h [lu] (maybeToList followers) + audRecip = + let ObjURI h lu = remoteAuthorURI author + in AudRemote h [lu] (maybeToList $ remoteActorFollowers accepter) + audTopic = AudLocal [] [localActorFollowers topicByHash] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audSender, audRecip, audTopic] + + recips = map encodeRouteHome audLocal ++ audRemote + doc = AP.Doc hLocal AP.Activity + { AP.activityId = Just $ encodeRouteLocal $ activityRoute topicByHash grantHash + , AP.activityActor = encodeRouteLocal $ renderLocalActor topicByHash + , AP.activityCapability = Nothing + , AP.activitySummary = Nothing + , AP.activityAudience = AP.Audience recips [] [] [] [] [] + , AP.activityFulfills = [AP.acceptObject accept] + , AP.activitySpecific = AP.GrantActivity AP.Grant + { AP.grantObject = Left AP.RoleAdmin + , AP.grantContext = encodeRouteHome $ renderLocalActor topicByHash + , AP.grantTarget = remoteAuthorURI author + } + } + + update grantID [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) + +repoAcceptF + :: UTCTime + -> KeyHashid Repo + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Accept URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +repoAcceptF = + topicAcceptF repoActor GrantResourceRepo deliverRemoteDB_R deliverRemoteHTTP_R + +deckAcceptF + :: UTCTime + -> KeyHashid Deck + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Accept URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +deckAcceptF = + topicAcceptF deckActor GrantResourceDeck deliverRemoteDB_D deliverRemoteHTTP_D + +loomAcceptF + :: UTCTime + -> KeyHashid Loom + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Accept URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +loomAcceptF = + topicAcceptF loomActor GrantResourceLoom deliverRemoteDB_L deliverRemoteHTTP_L + +personGrantF + :: UTCTime + -> KeyHashid Person + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Grant URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +personGrantF now recipHash author body mfwd luGrant grant = (,Nothing) <$> do + + -- Check input + (_remoteResource, recipient) <- do + (resource, recip) <- parseGrant grant + let u@(ObjURI h _) = remoteAuthorURI author + resourceURI <- + case resource of + Right (ObjURI h' r) | h == h' -> return (u, r) + _ -> throwE "Grant resource and Grant author are from different instances" + when (recip == Right u) $ + throwE "Grant sender and target are the same remote actor" + return (resourceURI, recip) + + -- Find recipient person in DB, returning 404 if doesn't exist because + -- we're in the person's inbox post handler + personRecipID <- decodeKeyHashid404 recipHash + mhttp <- runDBExcept $ do + (personRecip, actorRecip) <- lift $ do + p <- get404 personRecipID + (p,) <$> getJust (personActor p) + + mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luGrant True + for mractid $ \ grantID -> do + + -- If recipient is local, find it in our DB + _recipientDB <- + bitraverse + (flip getGrantRecip "Grant local target not found in DB") + pure + recipient + + -- Forward the Grant activity to relevant local stages, and + -- schedule delivery for unavailable remote members of them + lift $ for mfwd $ \ (localRecips, sig) -> do + let targetIsRecip = + case recipient of + Left (GrantRecipPerson p) -> p == personRecipID + _ -> False + sieve = + if targetIsRecip + then makeRecipientSet [] [LocalStagePersonFollowers recipHash] + else makeRecipientSet [] [] + remoteRecips <- + insertRemoteActivityToLocalInboxes + False grantID $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_P (actbBL body) grantID personRecipID sig remoteRecips + + -- Launch asynchronous HTTP forwarding of the Invite activity + case mhttp of + Nothing -> return "I already have this activity in my inbox, doing nothing" + Just mremotesHttpFwd -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "personGrantF inbox-forwarding" $ + deliverRemoteHTTP_P now recipHash (actbBL body) sig remotes + return $ + case mremotesHttpFwd of + Nothing -> "Inserted to inbox, no inbox-forwarding to do" + Just _ -> "Inserted to inbox and ran inbox-forwarding of the Grant" diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index cabb8d6..346573e 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -91,8 +91,10 @@ import Data.Paginate.Local import Database.Persist.Local import Yesod.Persist.Local +import Vervis.Access import Vervis.API import Vervis.Federation.Auth +import Vervis.Federation.Collab import Vervis.FedURI import Vervis.Form.Project import Vervis.Foundation @@ -155,13 +157,17 @@ postDeckInboxR recipDeckHash = postInbox $ handleRobotInbox (LocalActorDeck recipDeckHash) handle where handle - :: RemoteAuthor + :: UTCTime + -> RemoteAuthor + -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> SpecificActivity URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - handle _author _mfwd _luActivity specific = + handle now author body mfwd luActivity specific = case specific of + AP.AcceptActivity accept -> + deckAcceptF now recipDeckHash author body mfwd luActivity accept {- CreateActivity (Create obj mtarget) -> case obj of @@ -172,6 +178,10 @@ postDeckInboxR recipDeckHash = _ -> error "Unsupported create object type for projects" FollowActivity follow -> (,Nothing) <$> projectFollowF shrRecip prjRecip now remoteAuthor body mfwd luActivity follow + -} + AP.InviteActivity invite -> + topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity invite + {- OfferActivity (Offer obj target) -> case obj of OfferTicket ticket -> diff --git a/src/Vervis/Handler/Group.hs b/src/Vervis/Handler/Group.hs index 2dc473f..ccbe4c8 100644 --- a/src/Vervis/Handler/Group.hs +++ b/src/Vervis/Handler/Group.hs @@ -45,14 +45,12 @@ where import Control.Monad.Trans.Except import Data.Text (Text) +import Data.Time.Clock import Database.Persist import Data.ByteString (ByteString) import Yesod.Core.Content (TypedContent) -import Yesod.Core.Handler import Yesod.Persist.Core -import qualified Database.Esqueleto as E - import Network.FedURI import Yesod.ActivityPub import Yesod.FedURI @@ -64,7 +62,6 @@ import Vervis.Federation.Auth import Vervis.FedURI import Vervis.Foundation import Vervis.Model -import Vervis.Model.Group import Vervis.Recipient import Vervis.Web.Actor @@ -111,12 +108,14 @@ postGroupInboxR recipGroupHash = postInbox $ handleRobotInbox (LocalActorGroup recipGroupHash) handle where handle - :: RemoteAuthor + :: UTCTime + -> RemoteAuthor + -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.SpecificActivity URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - handle _author _mfwd _luActivity specific = + handle _now _author _body _mfwd _luActivity specific = case specific of _ -> return ("Unsupported activity type for groups", Nothing) diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 06ddb1f..0d564fa 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -61,8 +61,10 @@ import Data.Paginate.Local import Database.Persist.Local import Yesod.Persist.Local +import Vervis.Access import Vervis.API import Vervis.Federation.Auth +import Vervis.Federation.Collab import Vervis.FedURI import Vervis.Foundation import Vervis.Model @@ -113,13 +115,19 @@ postLoomInboxR recipLoomHash = postInbox $ handleRobotInbox (LocalActorLoom recipLoomHash) handle where handle - :: RemoteAuthor + :: UTCTime + -> RemoteAuthor + -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.SpecificActivity URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - handle _author _mfwd _luActivity specific = + handle now author body mfwd luActivity specific = case specific of + AP.AcceptActivity accept -> + loomAcceptF now recipLoomHash author body mfwd luActivity accept + AP.InviteActivity invite -> + topicInviteF now (GrantResourceLoom recipLoomHash) author body mfwd luActivity invite _ -> return ("Unsupported activity type for looms", Nothing) getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 3cf497a..ee531a5 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -69,6 +69,7 @@ import Vervis.ActorKey import Vervis.API import Vervis.Data.Actor import Vervis.Federation.Auth +import Vervis.Federation.Collab import Vervis.Foundation import Vervis.Model import Vervis.Model.Ident @@ -203,6 +204,10 @@ postPersonInboxR recipPersonHash = postInbox handle FollowActivity follow -> (,Nothing) <$> sharerFollowF shrRecip now author body mfwd luActivity follow -} + AP.GrantActivity grant -> + personGrantF now recipPersonHash author body mfwd luActivity grant + AP.InviteActivity invite -> + personInviteF now recipPersonHash author body mfwd luActivity invite {- OfferActivity (Offer obj target) -> case obj of diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 962cc4e..75ad7ee 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -148,8 +148,10 @@ import Yesod.Persist.Local import qualified Data.Git.Local as G (createRepo) import qualified Darcs.Local.Repository as D (createRepo) +import Vervis.Access import Vervis.API import Vervis.Federation.Auth +import Vervis.Federation.Collab import Vervis.FedURI import Vervis.Foundation import Vervis.Path @@ -215,13 +217,17 @@ postRepoInboxR recipRepoHash = postInbox $ handleRobotInbox (LocalActorRepo recipRepoHash) handle where handle - :: RemoteAuthor + :: UTCTime + -> RemoteAuthor + -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.SpecificActivity URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) - handle _author _mfwd _luActivity specific = + handle now author body mfwd luActivity specific = case specific of + AP.AcceptActivity accept -> + repoAcceptF now recipRepoHash author body mfwd luActivity accept {- ApplyActivity (AP.Apply uObject uTarget) -> repoApplyF now shrRecip rpRecip remoteAuthor body mfwd luActivity uObject uTarget @@ -239,6 +245,10 @@ postRepoInboxR recipRepoHash = _ -> error "Unsupported create object type for repos" FollowActivity follow -> (,Nothing) <$> repoFollowF shrRecip rpRecip now remoteAuthor body mfwd luActivity follow + -} + AP.InviteActivity invite -> + topicInviteF now (GrantResourceRepo recipRepoHash) author body mfwd luActivity invite + {- OfferActivity (Offer obj target) -> case obj of OfferTicket ticket -> diff --git a/src/Vervis/Persist/Actor.hs b/src/Vervis/Persist/Actor.hs index 0e77a3e..c85038e 100644 --- a/src/Vervis/Persist/Actor.hs +++ b/src/Vervis/Persist/Actor.hs @@ -16,6 +16,7 @@ module Vervis.Persist.Actor ( getLocalActor , verifyLocalActivityExistsInDB + , getRemoteActorURI ) where @@ -28,6 +29,8 @@ import Data.Text (Text) import Database.Persist import Database.Persist.Sql +import Network.FedURI + import Control.Monad.Trans.Except.Local import Database.Persist.Local @@ -66,3 +69,11 @@ verifyLocalActivityExistsInDB actorByKey outboxItemID = do itemActorByKey <- lift $ getLocalActor itemActorID unless (itemActorByKey == actorByKey) $ throwE "Actor-in-URI and Actor-owning-the-outbox-item-in-DB mismatch" + +getRemoteActorURI actor = do + object <- getJust $ remoteActorIdent actor + inztance <- getJust $ remoteObjectInstance object + return $ + ObjURI + (instanceHost inztance) + (remoteObjectIdent object) diff --git a/src/Vervis/Persist/Collab.hs b/src/Vervis/Persist/Collab.hs new file mode 100644 index 0000000..cbf26f7 --- /dev/null +++ b/src/Vervis/Persist/Collab.hs @@ -0,0 +1,49 @@ +{- This file is part of Vervis. + - + - Written in 2022 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.Persist.Collab + ( getCollabTopic + , getGrantRecip + ) +where + +import Control.Monad.IO.Class +import Control.Monad.Trans.Reader +import Database.Persist.Sql + +import Database.Persist.Local + +import Vervis.Access +import Vervis.Data.Collab +import Vervis.Model + +getCollabTopic + :: MonadIO m => CollabId -> ReaderT SqlBackend m (GrantResourceBy Key) +getCollabTopic collabID = do + maybeRepo <- getValBy $ UniqueCollabTopicRepo collabID + maybeDeck <- getValBy $ UniqueCollabTopicDeck collabID + maybeLoom <- getValBy $ UniqueCollabTopicLoom collabID + return $ + case (maybeRepo, maybeDeck, maybeLoom) of + (Nothing, Nothing, Nothing) -> error "Found Collab without topic" + (Just r, Nothing, Nothing) -> + GrantResourceRepo $ collabTopicRepoRepo r + (Nothing, Just d, Nothing) -> + GrantResourceDeck $ collabTopicDeckDeck d + (Nothing, Nothing, Just l) -> + GrantResourceLoom $ collabTopicLoomLoom l + _ -> error "Found Collab with multiple topics" + +getGrantRecip (GrantRecipPerson k) e = GrantRecipPerson <$> getEntityE k e diff --git a/src/Vervis/Web/Actor.hs b/src/Vervis/Web/Actor.hs index 119ff62..1bfe0a9 100644 --- a/src/Vervis/Web/Actor.hs +++ b/src/Vervis/Web/Actor.hs @@ -458,7 +458,9 @@ getFollowingCollection here actor hash = do handleRobotInbox :: LocalActorBy KeyHashid - -> ( RemoteAuthor + -> ( UTCTime + -> RemoteAuthor + -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> SpecificActivity URIMode @@ -480,4 +482,4 @@ handleRobotInbox recipByHash handleSpecific now auth body = do paudLocalRecips <$> fromMaybeE mrecips "Activity with no recipients" msig <- checkForwarding recipByHash let mfwd = (localRecips,) <$> msig - handleSpecific remoteAuthor mfwd luActivity (activitySpecific $ actbActivity body) + handleSpecific now remoteAuthor body mfwd luActivity (activitySpecific $ actbActivity body) diff --git a/vervis.cabal b/vervis.cabal index a36c93a..bf5c807 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -144,6 +144,7 @@ library Vervis.Discussion --Vervis.Federation Vervis.Federation.Auth + Vervis.Federation.Collab --Vervis.Federation.Discussion --Vervis.Federation.Offer --Vervis.Federation.Push @@ -206,6 +207,7 @@ library Vervis.Path Vervis.Persist.Actor + Vervis.Persist.Collab Vervis.Query Vervis.Readme