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.
This commit is contained in:
fr33domlover 2022-09-08 12:00:14 +00:00
parent 00a39475eb
commit 8ec98e2a59
13 changed files with 809 additions and 76 deletions

View file

@ -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"

View file

@ -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

View file

@ -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
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

View file

@ -0,0 +1,636 @@
{- This file is part of Vervis.
-
- Written in 2022 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/>.
-}
{-# 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"

View file

@ -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 ->

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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 ->

View file

@ -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)

View file

@ -0,0 +1,49 @@
{- This file is part of Vervis.
-
- Written in 2022 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.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

View file

@ -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)

View file

@ -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