forge/Vervis
1
0
Fork 0
Code Pull requests Activity

S2S: deckOfferTicketF (i.e. local deck receives ticket from remote author)

Browse source
This commit is contained in:
fr33domlover 2022-09-23 15:58:54 +00:00
parent 0d922b0e5a
commit ef8e1c1108
4 changed files with 178 additions and 102 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

261
src/Vervis/Federation/Ticket.hs
View file

@ -14,19 +14,20 @@
-}
module Vervis.Federation.Ticket
( personOfferTicketF
, deckOfferTicketF
, repoOfferTicketF
( --personOfferTicketF
deckOfferTicketF
--, repoOfferTicketF
, repoAddBundleF
--, repoAddBundleF
, repoApplyF
--, repoApplyF
--, loomApplyF
, deckOfferDepF
, repoOfferDepF
--, deckOfferDepF
--, repoOfferDepF
, deckResolveF
, repoResolveF
--, deckResolveF
--, repoResolveF
)
where
@ -90,7 +91,9 @@ import Development.PatchMediaType
import Vervis.ActivityPub
import Vervis.Cloth
import Vervis.Data.Ticket
import Vervis.Darcs
import Vervis.Delivery
import Vervis.FedURI
import Vervis.Federation.Auth
import Vervis.Federation.Util
@ -244,7 +247,7 @@ personOfferTicketF
-> KeyHashid Person
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Ticket URIMode
-> FedURI
@ -315,120 +318,188 @@ deckOfferTicketF
-> KeyHashid Deck
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Ticket URIMode
-> FedURI
-> ExceptT Text Handler Text
deckOfferTicketF now recipHash author body mfwd luOffer ticket uTarget = do
error "projectOfferTicketF temporarily disabled"
deckOfferTicketF now recipDeckHash author body mfwd luOffer ticket uTarget = do
-- Check input
recipDeckID <- decodeKeyHashid404 recipDeckHash
(title, desc, source) <- do
let uAuthor@(ObjURI hAuthor _) = remoteAuthorURI author
WorkItemOffer {..} <- checkOfferTicket hAuthor ticket uTarget
unless (wioAuthor == Right (remoteAuthorURI author)) $
throwE "Offering a Ticket attributed to someone else"
case wioRest of
TAM_Task deckID ->
if deckID == recipDeckID
then return ()
else throwE
"Offer target is some other local deck, so I have \
\no use for this Offer. Was I supposed to receive \
\it?"
TAM_Merge _ _ ->
throwE
"Offer target is some local loom, so I have no use for \
\this Offer. Was I supposed to receive it?"
TAM_Remote _ _ ->
throwE
"Offer target is some remote tracker, so I have no use \
\for this Offer. Was I supposed to receive it?"
return (wioTitle, wioDesc, wioSource)
{-
(target, summary, content, source) <- checkOfferTicket author ticket uTarget
mmhttp <- for (targetRelevance target) $ \ () -> lift $ runDB $ do
Entity jid j <- do
sid <- getKeyBy404 $ UniqueSharer shrRecip
getBy404 $ UniqueProject prjRecip sid
a <- getJust $ projectActor j
mractid <- insertToInbox now author body (actorInbox a) luOffer False
for mractid $ \ ractid -> do
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
-- Find recipient deck in DB, returning 404 if doesn't exist because we're
-- in the deck's inbox post handler
maybeHttp <- lift $ runDB $ do
(recipDeckActorID, recipDeckActor) <- do
deck <- get404 recipDeckID
let actorID = deckActor deck
(actorID,) <$> getJust actorID
-- Insert the Offer to deck's inbox
mractid <- insertToInbox now author body (actorInbox recipDeckActor) luOffer False
for mractid $ \ offerID -> do
-- Forward the Offer activity to relevant local stages, and
-- schedule delivery for unavailable remote members of them
maybeHttpFwdOffer <- for mfwd $ \ (localRecips, sig) -> do
let sieve =
makeRecipientSet
[]
[ LocalPersonCollectionProjectTeam shrRecip prjRecip
, LocalPersonCollectionProjectFollowers shrRecip prjRecip
]
[LocalStageDeckFollowers recipDeckHash]
remoteRecips <-
insertRemoteActivityToLocalInboxes
False ractid $
localRecipSieve'
sieve False False localRecips
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
(obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do
obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now
(_, ltid) <- insertLocalTicket now author (flip TicketProjectLocal jid) summary content source ractid obiidAccept
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAccept shrRecip prjRecip author luOffer ltid obiidAccept
knownRemoteRecipsAccept <-
deliverLocal'
False
(LocalActorProject shrRecip prjRecip)
(actorInbox a)
obiidAccept
localRecipsAccept
(obiidAccept,docAccept,fwdHostsAccept,) <$>
deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept)
case mmhttp of
Nothing -> return "Offer target isn't me, not using"
Just mhttp ->
case mhttp of
Nothing -> return "Activity already in my inbox, doing nothing"
Just (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do
for_ mremotesHttpFwd $ \ (sig, remotes) ->
forkWorker "projectOfferTicketF inbox-forwarding" $
deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
forkWorker "projectOfferTicketF Accept HTTP delivery" $
deliverRemoteHttp' fwdHosts obiid doc remotes
return $
case mremotesHttpFwd of
Nothing -> "Accepted new ticket, no inbox-forwarding to do"
Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer"
insertRemoteActivityToLocalInboxes False offerID $
localRecipSieve' sieve False False localRecips
remoteRecipsHttp <-
deliverRemoteDB_D
(actbBL body) offerID recipDeckID sig remoteRecips
return $
deliverRemoteHTTP_D
now recipDeckHash (actbBL body) sig remoteRecipsHttp
-- Insert the new ticket to our DB
acceptID <- insertEmptyOutboxItem (actorOutbox recipDeckActor) now
taskID <- insertTask now title desc source recipDeckID offerID acceptID
-- Prepare an Accept activity and insert to deck's outbox
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
insertAcceptToOutbox taskID acceptID
-- Deliver the Accept to local recipients, and schedule delivery
-- for unavailable remote recipients
knownRemoteRecipsAccept <-
deliverLocal'
False (LocalActorDeck recipDeckHash) recipDeckActorID
acceptID localRecipsAccept
remoteRecipsHttpAccept <-
deliverRemoteDB''
fwdHostsAccept acceptID remoteRecipsAccept
knownRemoteRecipsAccept
-- Return instructions for HTTP inbox-forwarding of the Offer
-- activity, and for HTTP delivery of the Accept activity to
-- remote recipients
return
( maybeHttpFwdOffer
, deliverRemoteHttp'
fwdHostsAccept acceptID docAccept remoteRecipsHttpAccept
)
-- Launch asynchronous HTTP forwarding of the Offer activity and HTTP
-- delivery of the Accept activity
case maybeHttp of
Nothing -> return "I already have this activity in my inbox, doing nothing"
Just (maybeHttpFwdOffer, deliverHttpAccept) -> do
forkWorker "deckOfferTicketF Accept HTTP delivery" deliverHttpAccept
case maybeHttpFwdOffer of
Nothing -> return "Opened a ticket, no inbox-forwarding to do"
Just forwardHttpOffer -> do
forkWorker "deckOfferTicketF inbox-forwarding" forwardHttpOffer
return "Opened a ticket and ran inbox-forwarding of the Offer"
where
targetRelevance (Left (WITProject shr prj))
| shr == shrRecip && prj == prjRecip = Just ()
targetRelevance _ = Nothing
insertAccept shr prj author luOffer ltid obiidAccept = do
insertTask now title desc source deckID offerID acceptID = do
did <- insert Discussion
fsid <- insert FollowerSet
tid <- insert Ticket
{ ticketNumber = Nothing
, ticketCreated = now
, ticketTitle = title
, ticketSource = source
, ticketDescription = desc
, ticketStatus = TSNew
, ticketDiscuss = did
, ticketFollowers = fsid
, ticketAccept = acceptID
}
insert_ TicketAuthorRemote
{ ticketAuthorRemoteTicket = tid
, ticketAuthorRemoteAuthor = remoteAuthorId author
, ticketAuthorRemoteOpen = offerID
}
insert $ TicketDeck tid deckID
insertAcceptToOutbox
:: TicketDeckId
-> OutboxItemId
-> ReaderT SqlBackend Handler
( AP.Doc AP.Activity URIMode
, RecipientRoutes
, [(Host, NonEmpty LocalURI)]
, [Host]
)
insertAcceptToOutbox taskID acceptID = do
encodeRouteLocal <- getEncodeRouteLocal
encodeRouteHome <- getEncodeRouteHome
hLocal <- asksSite siteInstanceHost
obikhidAccept <- encodeKeyHashid obiidAccept
ltkhid <- encodeKeyHashid ltid
taskHash <- encodeKeyHashid taskID
acceptHash <- encodeKeyHashid acceptID
ra <- getJust $ remoteAuthorId author
let ObjURI hAuthor luAuthor = remoteAuthorURI author
audAuthor =
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
audProject =
AudLocal []
[ LocalPersonCollectionProjectTeam shr prj
, LocalPersonCollectionProjectFollowers shr prj
]
audSender =
AudRemote hAuthor
[luAuthor]
(maybeToList $ remoteActorFollowers ra)
audTracker = AudLocal [] [LocalStageDeckFollowers recipDeckHash]
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
collectAudience [audAuthor, audProject]
collectAudience [audSender, audTracker]
recips = map encodeRouteHome audLocal ++ audRemote
doc = Doc hLocal Activity
{ activityId =
doc = AP.Doc hLocal AP.Activity
{ AP.activityId =
Just $ encodeRouteLocal $
ProjectOutboxItemR shr prj obikhidAccept
, activityActor = encodeRouteLocal $ ProjectR shr prj
, activityCapability = Nothing
, activitySummary = Nothing
, activityAudience = Audience recips [] [] [] [] []
, activitySpecific = AcceptActivity Accept
DeckOutboxItemR recipDeckHash acceptHash
, AP.activityActor =
encodeRouteLocal $ DeckR recipDeckHash
, AP.activityCapability = Nothing
, AP.activitySummary = Nothing
, AP.activityAudience = AP.Audience recips [] [] [] [] []
, AP.activityFulfills = []
, AP.activitySpecific = AP.AcceptActivity AP.Accept
{ acceptObject = ObjURI hAuthor luOffer
, acceptResult =
Just $ encodeRouteLocal $ ProjectTicketR shr prj ltkhid
Just $ encodeRouteLocal $
TicketR recipDeckHash taskHash
}
}
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
update acceptID [OutboxItemActivity =. persistJSONObjectFromDoc doc]
return (doc, recipientSet, remoteActors, fwdHosts)
-}
repoOfferTicketF
:: UTCTime
-> KeyHashid Repo
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.Ticket URIMode
-> FedURI
@ -577,7 +648,7 @@ repoAddBundleF
-> KeyHashid Repo
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> NonEmpty (AP.Patch URIMode)
-> FedURI
@ -739,7 +810,7 @@ repoApplyF
-> KeyHashid Repo
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> FedURI
-> FedURI
@ -1297,7 +1368,7 @@ personOfferDepF
-> KeyHashid Person
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.TicketDependency URIMode
-> FedURI
@ -1504,7 +1575,7 @@ deckOfferDepF
-> KeyHashid Deck
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.TicketDependency URIMode
-> FedURI
@ -1674,7 +1745,7 @@ repoOfferDepF
-> KeyHashid Repo
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> AP.TicketDependency URIMode
-> FedURI
@ -1869,7 +1940,7 @@ deckResolveF
-> KeyHashid Deck
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> Resolve URIMode
-> ExceptT Text Handler Text
@ -2006,7 +2077,7 @@ repoResolveF
-> KeyHashid Repo
-> RemoteAuthor
-> ActivityBody
-> Maybe (LocalRecipientSet, ByteString)
-> Maybe (RecipientRoutes, ByteString)
-> LocalURI
-> Resolve URIMode
-> ExceptT Text Handler Text

9
src/Vervis/Handler/Deck.hs
View file

@ -97,6 +97,7 @@ import Vervis.Access
import Vervis.API
import Vervis.Federation.Auth
import Vervis.Federation.Collab
import Vervis.Federation.Ticket
import Vervis.FedURI
import Vervis.Form.Project
import Vervis.Form.Ticket
@ -187,14 +188,16 @@ postDeckInboxR recipDeckHash =
-}
AP.InviteActivity invite ->
topicInviteF now (GrantResourceDeck recipDeckHash) author body mfwd luActivity invite
{-
OfferActivity (Offer obj target) ->
case obj of
OfferTicket ticket ->
(,Nothing) <$> projectOfferTicketF now shrRecip prjRecip remoteAuthor body mfwd luActivity ticket target
(,Nothing) <$> deckOfferTicketF now recipDeckHash author body mfwd luActivity ticket target
{-
OfferDep dep ->
projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
_ -> return ("Unsupported offer object type for projects", Nothing)
-}
_ -> return ("Unsupported offer object type for decks", Nothing)
{-
ResolveActivity resolve ->
(,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
UndoActivity undo ->

8
src/Web/ActivityPub.hs
View file

@ -1418,19 +1418,21 @@ encodeAdd h (Add obj target)
data Apply u = Apply
{ applyObject :: ObjURI u
, applyTarget :: ObjURI u
, applyTarget :: Either (ObjURI u) (Authority u, Branch u)
}
parseApply :: UriMode u => Object -> Parser (Apply u)
parseApply o =
Apply
<$> o .: "object"
<*> o .: "target"
<*> (second fromDoc <$> o .:+ "target")
where
fromDoc (Doc h v) = (h, v)
encodeApply :: UriMode u => Apply u -> Series
encodeApply (Apply obj target)
= "object" .= obj
<> "target" .= target
<> "target" .=+ second (uncurry Doc) target
data CreateObject u
= CreateNote (Authority u) (Note u)

2
vervis.cabal
View file

@ -151,7 +151,7 @@ library
--Vervis.Federation.Discussion
--Vervis.Federation.Offer
--Vervis.Federation.Push
--Vervis.Federation.Ticket
Vervis.Federation.Ticket
Vervis.Federation.Util
Vervis.FedURI
-- Vervis.Field.Key