S2S: Re-implement and re-enable deckResolveF
This commit is contained in:
fr33domlover
parent
25e1203ed8
commit
f76e80c028
2 changed files with 139 additions and 108 deletions
|
|
@ -25,7 +25,7 @@ module Vervis.Federation.Ticket
|
|||
--, deckOfferDepF
|
||||
--, repoOfferDepF
|
||||
|
||||
--, deckResolveF
|
||||
, deckResolveF
|
||||
--, repoResolveF
|
||||
)
|
||||
where
|
||||
|
|
@ -91,6 +91,7 @@ import qualified Data.Text.UTF8.Local as TU
|
|||
|
||||
import Development.PatchMediaType
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Actor
|
||||
|
|
@ -1870,135 +1871,165 @@ deckResolveF
|
|||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Resolve URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
deckResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do
|
||||
error "projectResolveF temporarily disabled"
|
||||
-> AP.Resolve URIMode
|
||||
-> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text))
|
||||
deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do
|
||||
|
||||
-- Check input
|
||||
recipDeckID <- decodeKeyHashid404 recipDeckHash
|
||||
taskID <- nameExceptT "Resolve object" $ do
|
||||
route <- do
|
||||
routeOrRemote <- parseFedURI uObject
|
||||
case routeOrRemote of
|
||||
Left route -> pure route
|
||||
Right _ -> throwE "Remote, so definitely not mine"
|
||||
case route of
|
||||
TicketR deckHash taskHash | deckHash == recipDeckHash ->
|
||||
decodeKeyHashidE taskHash "Invalid task keyhashid"
|
||||
_ -> throwE "Local route but not a ticket of mine"
|
||||
|
||||
{-
|
||||
-- Verify the capability URI is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
capID <- do
|
||||
uCap <- do
|
||||
fromMaybeE
|
||||
(activityCapability $ actbActivity body)
|
||||
"Asking to resolve ticket but no capability provided"
|
||||
nameExceptT "Resolve capability" $ parseActivityURI uCap
|
||||
|
||||
maybeHttp <- runDBExcept $ do
|
||||
|
||||
object <- parseWorkItem "Resolve object" uObject
|
||||
mmmmhttp <- runDBExcept $ do
|
||||
(Entity jidRecip projectRecip, actorRecip) <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid
|
||||
(ej,) <$> getJust (projectActor j)
|
||||
mltid <-
|
||||
case relevantObject object of
|
||||
Nothing -> do
|
||||
case object of
|
||||
Left wi -> verifyWorkItemExists wi
|
||||
Right _ -> return ()
|
||||
return Nothing
|
||||
Just ltid -> Just . (ltid,) <$> getObjectLtid ltid
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox actorRecip) luResolve False
|
||||
lift $ for mractid $ \ ractid -> for mltid $ \ (ltid, tid) -> do
|
||||
mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
-- Find recipient deck in DB, returning 404 if doesn't exist because
|
||||
-- we're in the deck's inbox post handler
|
||||
recipDeck <- lift $ get404 recipDeckID
|
||||
let recipDeckActorID = deckActor recipDeck
|
||||
recipDeckActor <- lift $ getJust recipDeckActorID
|
||||
|
||||
-- Insert the Resolve to deck's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luResolve False
|
||||
for mractid $ \ resolveID -> do
|
||||
|
||||
-- Find ticket in DB, verify it's not resolved
|
||||
ticketID <- do
|
||||
maybeTicket <- lift $ getTicket recipDeckID taskID
|
||||
(_deck, _task, Entity ticketID _, _author, maybeResolve) <-
|
||||
fromMaybeE maybeTicket "I don't have such a ticket in DB"
|
||||
unless (isNothing maybeResolve) $
|
||||
throwE "Ticket is already resolved"
|
||||
return ticketID
|
||||
|
||||
-- Verify the sender is authorized by the deck to resolve a ticket
|
||||
capability <-
|
||||
case capID of
|
||||
Left (capActor, _, capItem) -> return (capActor, capItem)
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local deck"
|
||||
verifyCapability
|
||||
capability
|
||||
(Right $ remoteAuthorId author)
|
||||
(GrantResourceDeck recipDeckID)
|
||||
|
||||
-- Forward the Resolve activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdResolve <- lift $ for mfwd $ \ (localRecips, sig) -> do
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
let sieve =
|
||||
makeRecipientSet
|
||||
[]
|
||||
[ LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
|
||||
, LocalPersonCollectionProjectTeam shrRecip prjRecip
|
||||
, LocalPersonCollectionProjectFollowers shrRecip prjRecip
|
||||
[ LocalStageDeckFollowers recipDeckHash
|
||||
, LocalStageTicketFollowers recipDeckHash taskHash
|
||||
]
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False ractid $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_J (actbBL body) ractid jidRecip sig remoteRecips
|
||||
obiidAccept <- insertEmptyOutboxItem (actorOutbox actorRecip) now
|
||||
mmtrrid <- insertResolve author ltid ractid obiidAccept
|
||||
case mmtrrid of
|
||||
Just (Just _) -> update tid [TicketStatus =. TSClosed]
|
||||
_ -> delete obiidAccept
|
||||
for mmtrrid $ \ mtrrid -> for mtrrid $ \ trrid -> do
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAccept luResolve ltid obiidAccept
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorProject shrRecip prjRecip)
|
||||
(actorInbox actorRecip)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
case mmmmhttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just mmmhttp ->
|
||||
case mmmhttp of
|
||||
Nothing -> return "Object not mine, just stored in inbox"
|
||||
Just mmhttp ->
|
||||
case mmhttp of
|
||||
Nothing -> return "Ticket already resolved"
|
||||
Just mhttp ->
|
||||
case mhttp of
|
||||
Nothing -> return "Activity already resolved a ticket"
|
||||
Just (mremotesHttpFwd, obiid, doc, fwdHosts, recips) -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "projectResolveF inbox-forwarding" $
|
||||
deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
|
||||
forkWorker "projectResolveF Accept HTTP delivery" $
|
||||
deliverRemoteHttp' fwdHosts obiid doc recips
|
||||
return $
|
||||
if isJust mremotesHttpFwd
|
||||
then "Ticket is mine, now resolved, did inbox-forwarding"
|
||||
else "Ticket is mine, now resolved, no inbox-forwarding to do"
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipDeckActorID
|
||||
(LocalActorDeck recipDeckHash) sieve resolveID
|
||||
|
||||
-- Mark ticket in DB as resolved by the Resolve
|
||||
acceptID <-
|
||||
lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
|
||||
lift $ insertResolve ticketID resolveID acceptID
|
||||
|
||||
-- Prepare an Accept activity and insert to deck's outbox
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift $ prepareAccept taskID
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorDeck recipDeckHash) recipDeckActorID
|
||||
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Resolve
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients
|
||||
return (maybeHttpFwdResolve, deliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Resolve activity and HTTP
|
||||
-- delivery of the Accept activity
|
||||
case maybeHttp of
|
||||
Nothing ->
|
||||
return "I already have this activity in my inbox, doing nothing"
|
||||
Just (maybeHttpFwdResolve, deliverHttpAccept) -> do
|
||||
for_ maybeHttpFwdResolve $
|
||||
forkWorker "deckResolveF inbox-forwarding"
|
||||
forkWorker "deckResolveF Accept HTTP delivery" deliverHttpAccept
|
||||
return $
|
||||
case maybeHttpFwdResolve of
|
||||
Nothing -> "Resolved ticket, no inbox-forwarding to do"
|
||||
Just _ ->
|
||||
"Resolved ticket and ran inbox-forwarding of the Resolve"
|
||||
|
||||
where
|
||||
relevantObject (Left (WorkItemProjectTicket shr prj ltid))
|
||||
| shr == shrRecip && prj == prjRecip = Just ltid
|
||||
relevantObject _ = Nothing
|
||||
|
||||
getObjectLtid ltid = do
|
||||
(_, _, Entity tid _, _, _, _, _, _) <- do
|
||||
mticket <- lift $ getProjectTicket shrRecip prjRecip ltid
|
||||
fromMaybeE mticket $ "Object" <> ": No such project-ticket"
|
||||
return tid
|
||||
insertResolve ticketID resolveID acceptID = do
|
||||
trid <- insert TicketResolve
|
||||
{ ticketResolveTicket = ticketID
|
||||
, ticketResolveAccept = acceptID
|
||||
}
|
||||
insert_ TicketResolveRemote
|
||||
{ ticketResolveRemoteTicket = trid
|
||||
, ticketResolveRemoteActivity = resolveID
|
||||
, ticketResolveRemoteActor = remoteAuthorId author
|
||||
}
|
||||
|
||||
insertAccept luResolve ltid obiidAccept = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
prepareAccept taskID = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhidAccept <- encodeKeyHashid obiidAccept
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
|
||||
audTicket =
|
||||
audSender =
|
||||
AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
audTracker =
|
||||
AudLocal
|
||||
[]
|
||||
[ LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
|
||||
, LocalPersonCollectionProjectTeam shrRecip prjRecip
|
||||
, LocalPersonCollectionProjectFollowers shrRecip prjRecip
|
||||
[ LocalStageDeckFollowers recipDeckHash
|
||||
, LocalStageTicketFollowers recipDeckHash taskHash
|
||||
]
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience [audAuthor, audTicket]
|
||||
collectAudience [audSender, audTracker]
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $
|
||||
ProjectOutboxItemR shrRecip prjRecip obikhidAccept
|
||||
, activityActor = encodeRouteLocal $ ProjectR shrRecip prjRecip
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hAuthor luResolve
|
||||
, acceptResult = Nothing
|
||||
action = AP.Action
|
||||
{ AP.actionCapability = Nothing
|
||||
, AP.actionSummary = Nothing
|
||||
, AP.actionAudience = AP.Audience recips [] [] [] [] []
|
||||
, AP.actionFulfills = []
|
||||
, AP.actionSpecific = AP.AcceptActivity AP.Accept
|
||||
{ AP.acceptObject = ObjURI hAuthor luResolve
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
-}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
repoResolveF
|
||||
:: UTCTime
|
||||
|
|
|
|||
|
|
@ -211,9 +211,9 @@ postDeckInboxR recipDeckHash =
|
|||
projectOfferDepF now shrRecip prjRecip remoteAuthor body mfwd luActivity dep target
|
||||
-}
|
||||
_ -> return ("Unsupported offer object type for decks", Nothing)
|
||||
AP.ResolveActivity resolve ->
|
||||
deckResolveF now recipDeckHash author body mfwd luActivity resolve
|
||||
{-
|
||||
ResolveActivity resolve ->
|
||||
(,Nothing) <$> projectResolveF now shrRecip prjRecip remoteAuthor body mfwd luActivity resolve
|
||||
UndoActivity undo ->
|
||||
(,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
|
||||
-}
|
||||
|
|
|
|||
Loading…
Reference in a new issue