S2S: Implement repoUndoF, loomUndoF, personUndoF
This commit is contained in:
fr33domlover
parent
9b158c13cd
commit
e4d7156cbc
4 changed files with 476 additions and 259 deletions
|
|
@ -25,9 +25,10 @@ module Vervis.Federation.Offer
|
|||
, loomFollowF
|
||||
, repoFollowF
|
||||
|
||||
--, sharerUndoF
|
||||
, personUndoF
|
||||
, deckUndoF
|
||||
--, repoUndoF
|
||||
, loomUndoF
|
||||
, repoUndoF
|
||||
)
|
||||
where
|
||||
|
||||
|
|
@ -677,6 +678,146 @@ repoFollowF now recipRepoHash =
|
|||
now
|
||||
recipRepoHash
|
||||
|
||||
personUndoF
|
||||
:: UTCTime
|
||||
-> KeyHashid Person
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
personUndoF now recipPersonHash author body mfwd luUndo (AP.Undo uObject) = do
|
||||
|
||||
-- Check input
|
||||
recipPersonID <- decodeKeyHashid404 recipPersonHash
|
||||
undone <-
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI uObject
|
||||
|
||||
-- Verify the capability URI, if provided, is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
maybeCapability <-
|
||||
for (AP.activityCapability $ actbActivity body) $ \ uCap ->
|
||||
nameExceptT "Undo capability" $
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI uCap
|
||||
|
||||
maybeHttp <- runDBExcept $ do
|
||||
|
||||
-- Find recipient person in DB, returning 404 if doesn't exist because we're
|
||||
-- in the person's inbox post handler
|
||||
(recipPersonActorID, recipPersonActor) <- lift $ do
|
||||
person <- get404 recipPersonID
|
||||
let actorID = personActor person
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Insert the Undo to person's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipPersonActor) luUndo False
|
||||
for mractid $ \ undoID -> do
|
||||
|
||||
maybeUndo <- runMaybeT $ do
|
||||
|
||||
-- Find the undone activity in our DB
|
||||
undoneDB <- MaybeT $ getActivity undone
|
||||
|
||||
let followers = actorFollowers recipPersonActor
|
||||
MaybeT $ lift $ runMaybeT $ tryUnfollow followers undoneDB
|
||||
|
||||
for maybeUndo $ \ (remoteFollowID, followerID) -> do
|
||||
|
||||
(sieve, acceptAudience) <- do
|
||||
(audSenderOnly, _audSenderAndFollowers) <- do
|
||||
ra <- lift $ getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
return
|
||||
( AudRemote hAuthor [luAuthor] []
|
||||
, AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
)
|
||||
unless (followerID == remoteAuthorId author) $
|
||||
throwE "Trying to undo someone else's Follow"
|
||||
lift $ delete remoteFollowID
|
||||
return
|
||||
( makeRecipientSet [] []
|
||||
, [audSenderOnly]
|
||||
)
|
||||
|
||||
-- Forward the Undo activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) ->
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipPersonActorID
|
||||
(LocalActorPerson recipPersonHash) sieve undoID
|
||||
|
||||
|
||||
-- Prepare an Accept activity and insert to person's outbox
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipPersonActor) now
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift . lift $ prepareAccept acceptAudience
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorPerson recipPersonID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorPerson recipPersonHash) recipPersonActorID
|
||||
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Undo
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients
|
||||
return (maybeHttpFwdUndo, deliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Undo activity and HTTP
|
||||
-- delivery of the Accept activity
|
||||
case maybeHttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just Nothing -> return "Unrelated to me, just inserted to inbox"
|
||||
Just (Just (maybeHttpFwdUndo, deliverHttpAccept)) -> do
|
||||
forkWorker "personUndoF Accept HTTP delivery" deliverHttpAccept
|
||||
case maybeHttpFwdUndo of
|
||||
Nothing -> return "Undid, no inbox-forwarding to do"
|
||||
Just forwardHttpUndo -> do
|
||||
forkWorker "personUndoF inbox-forwarding" forwardHttpUndo
|
||||
return "Undid and ran inbox-forwarding of the Undo"
|
||||
|
||||
where
|
||||
|
||||
tryUnfollow _ (Left _) = mzero
|
||||
tryUnfollow personFollowersID (Right remoteActivityID) = do
|
||||
Entity remoteFollowID remoteFollow <-
|
||||
MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
|
||||
let followerID = remoteFollowActor remoteFollow
|
||||
followerSetID = remoteFollowTarget remoteFollow
|
||||
guard $ followerSetID == personFollowersID
|
||||
return (remoteFollowID, followerID)
|
||||
|
||||
prepareAccept audience = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let ObjURI hAuthor _ = remoteAuthorURI author
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience audience
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
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 luUndo
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
deckUndoF
|
||||
:: UTCTime
|
||||
-> KeyHashid Deck
|
||||
|
|
@ -888,274 +1029,352 @@ deckUndoF now recipDeckHash author body mfwd luUndo (AP.Undo uObject) = do
|
|||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
{-
|
||||
getFollow (Left _) = return Nothing
|
||||
getFollow (Right ractid) = getBy $ UniqueRemoteFollowFollow ractid
|
||||
loomUndoF
|
||||
:: UTCTime
|
||||
-> KeyHashid Loom
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
loomUndoF now recipLoomHash author body mfwd luUndo (AP.Undo uObject) = do
|
||||
|
||||
getResolve (Left (_, obiid)) = fmap Left <$> getBy (UniqueTicketResolveLocalActivity obiid)
|
||||
getResolve (Right ractid) = fmap Right <$> getBy (UniqueTicketResolveRemoteActivity ractid)
|
||||
-- Check input
|
||||
recipLoomID <- decodeKeyHashid404 recipLoomHash
|
||||
undone <-
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI uObject
|
||||
|
||||
deleteResolve myWorkItem prepareAccept tr = do
|
||||
let (trid, trxid) =
|
||||
case tr of
|
||||
Left (Entity trlid trl) -> (ticketResolveLocalTicket trl, Left trlid)
|
||||
Right (Entity trrid trr) -> (ticketResolveRemoteTicket trr, Right trrid)
|
||||
ltid <- ticketResolveTicket <$> getJust trid
|
||||
wi <- getWorkItem ltid
|
||||
case myWorkItem wi of
|
||||
Nothing -> return ("Undo is of a TicketResolve but not my ticket", Nothing, Nothing)
|
||||
Just wiData -> do
|
||||
bitraverse delete delete trxid
|
||||
delete trid
|
||||
tid <- localTicketTicket <$> getJust ltid
|
||||
update tid [TicketStatus =. TSTodo]
|
||||
(colls, accept) <- prepareAccept wiData
|
||||
return ("Ticket unresolved", Just colls, Just accept)
|
||||
-- Verify the capability URI, if provided, is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
maybeCapability <-
|
||||
for (AP.activityCapability $ actbActivity body) $ \ uCap ->
|
||||
nameExceptT "Undo capability" $
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI uCap
|
||||
|
||||
maybeHttp <- runDBExcept $ do
|
||||
|
||||
-- Find recipient loom in DB, returning 404 if doesn't exist because we're
|
||||
-- in the loom's inbox post handler
|
||||
(recipLoomActorID, recipLoomActor) <- lift $ do
|
||||
loom <- get404 recipLoomID
|
||||
let actorID = loomActor loom
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Insert the Undo to loom's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipLoomActor) luUndo False
|
||||
for mractid $ \ undoID -> do
|
||||
|
||||
-- Find the undone activity in our DB
|
||||
undoneDB <- do
|
||||
a <- getActivity undone
|
||||
fromMaybeE a "Can't find undone in DB"
|
||||
|
||||
(sieve, acceptAudience) <- do
|
||||
maybeUndo <- do
|
||||
let followers = actorFollowers recipLoomActor
|
||||
lift $ runMaybeT $
|
||||
Left <$> tryUnfollow recipLoomID followers undoneDB <|>
|
||||
Right <$> tryUnresolve recipLoomID undoneDB
|
||||
undo <- fromMaybeE maybeUndo "Undone activity isn't a Follow or Resolve related to me"
|
||||
(audSenderOnly, audSenderAndFollowers) <- do
|
||||
ra <- lift $ getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
return
|
||||
( AudRemote hAuthor [luAuthor] []
|
||||
, AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
)
|
||||
case undo of
|
||||
Left (remoteFollowID, followerID) -> do
|
||||
unless (followerID == remoteAuthorId author) $
|
||||
throwE "Trying to undo someone else's Follow"
|
||||
lift $ delete remoteFollowID
|
||||
return
|
||||
( makeRecipientSet [] []
|
||||
, [audSenderOnly]
|
||||
)
|
||||
Right (deleteFromDB, clothID) -> do
|
||||
|
||||
-- Verify the sender is authorized by the loom to unresolve a MR
|
||||
capability <- do
|
||||
cap <-
|
||||
fromMaybeE
|
||||
maybeCapability
|
||||
"Asking to unresolve MR but no capability provided"
|
||||
case cap of
|
||||
Left c -> pure c
|
||||
Right _ -> throwE "Capability is a remote URI, i.e. not authored by me"
|
||||
verifyCapability
|
||||
capability
|
||||
(Right $ remoteAuthorId author)
|
||||
(GrantResourceLoom recipLoomID)
|
||||
|
||||
lift deleteFromDB
|
||||
|
||||
clothHash <- encodeKeyHashid clothID
|
||||
return
|
||||
( makeRecipientSet
|
||||
[LocalActorLoom recipLoomHash]
|
||||
[ LocalStageLoomFollowers recipLoomHash
|
||||
, LocalStageClothFollowers recipLoomHash clothHash
|
||||
]
|
||||
, [ AudLocal
|
||||
[]
|
||||
[ LocalStageLoomFollowers recipLoomHash
|
||||
, LocalStageClothFollowers recipLoomHash clothHash
|
||||
]
|
||||
, audSenderAndFollowers
|
||||
]
|
||||
)
|
||||
|
||||
-- Forward the Undo activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) ->
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipLoomActorID
|
||||
(LocalActorLoom recipLoomHash) sieve undoID
|
||||
|
||||
|
||||
-- Prepare an Accept activity and insert to loom's outbox
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipLoomActor) now
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift . lift $ prepareAccept acceptAudience
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorLoom recipLoomID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorLoom recipLoomHash) recipLoomActorID
|
||||
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Undo
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients
|
||||
return (maybeHttpFwdUndo, deliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Undo activity and HTTP
|
||||
-- delivery of the Accept activity
|
||||
case maybeHttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just (maybeHttpFwdUndo, deliverHttpAccept) -> do
|
||||
forkWorker "loomUndoF Accept HTTP delivery" deliverHttpAccept
|
||||
case maybeHttpFwdUndo of
|
||||
Nothing -> return "Undid, no inbox-forwarding to do"
|
||||
Just forwardHttpUndo -> do
|
||||
forkWorker "loomUndoF inbox-forwarding" forwardHttpUndo
|
||||
return "Undid and ran inbox-forwarding of the Undo"
|
||||
|
||||
deleteRemoteFollow myWorkItem author fsidRecip (Entity rfid rf)
|
||||
| remoteFollowActor rf /= remoteAuthorId author =
|
||||
return "Undo sent by different actor than the one who sent the Follow"
|
||||
| remoteFollowTarget rf == fsidRecip = do
|
||||
delete rfid
|
||||
return "Undo applied to sharer RemoteFollow"
|
||||
| otherwise = do
|
||||
r <- tryTicket $ remoteFollowTarget rf
|
||||
when (isRight r) $ delete rfid
|
||||
return $ either id id r
|
||||
where
|
||||
tryTicket fsid = do
|
||||
mltid <- getKeyBy $ UniqueLocalTicketFollowers fsid
|
||||
case mltid of
|
||||
Nothing -> return $ Left "Undo object is a RemoteFollow, but not for me and not for a ticket"
|
||||
Just ltid -> do
|
||||
wi <- getWorkItem ltid
|
||||
return $
|
||||
if myWorkItem wi
|
||||
then Right "Undo applied to RemoteFollow of my ticket"
|
||||
else Left "Undo is of RemoteFollow of a ticket that isn't mine"
|
||||
|
||||
insertAcceptOnUndo actor author luUndo obiid auds = do
|
||||
encodeRouteLocal <- getEncodeRouteLocal
|
||||
tryUnfollow _ _ (Left _) = mzero
|
||||
tryUnfollow loomID loomFollowersID (Right remoteActivityID) = do
|
||||
Entity remoteFollowID remoteFollow <-
|
||||
MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
|
||||
let followerID = remoteFollowActor remoteFollow
|
||||
followerSetID = remoteFollowTarget remoteFollow
|
||||
if followerSetID == loomFollowersID
|
||||
then pure ()
|
||||
else do
|
||||
ticketID <-
|
||||
MaybeT $ getKeyBy $ UniqueTicketFollowers followerSetID
|
||||
TicketLoom _ l _ <-
|
||||
MaybeT $ getValBy $ UniqueTicketLoom ticketID
|
||||
guard $ l == loomID
|
||||
return (remoteFollowID, followerID)
|
||||
|
||||
tryUnresolve loomID undone = do
|
||||
(deleteFromDB, ticketID) <- findTicket undone
|
||||
Entity clothID (TicketLoom _ l _) <-
|
||||
MaybeT $ getBy $ UniqueTicketLoom ticketID
|
||||
guard $ l == loomID
|
||||
return (deleteFromDB, clothID)
|
||||
where
|
||||
findTicket (Left (_actorByKey, _actorEntity, itemID)) = do
|
||||
Entity resolveLocalID resolveLocal <-
|
||||
MaybeT $ getBy $ UniqueTicketResolveLocalActivity itemID
|
||||
let resolveID = ticketResolveLocalTicket resolveLocal
|
||||
resolve <- lift $ getJust resolveID
|
||||
let ticketID = ticketResolveTicket resolve
|
||||
return
|
||||
( delete resolveLocalID >> delete resolveID
|
||||
, ticketID
|
||||
)
|
||||
findTicket (Right remoteActivityID) = do
|
||||
Entity resolveRemoteID resolveRemote <-
|
||||
MaybeT $ getBy $
|
||||
UniqueTicketResolveRemoteActivity remoteActivityID
|
||||
let resolveID = ticketResolveRemoteTicket resolveRemote
|
||||
resolve <- lift $ getJust resolveID
|
||||
let ticketID = ticketResolveTicket resolve
|
||||
return
|
||||
( delete resolveRemoteID >> delete resolveID
|
||||
, ticketID
|
||||
)
|
||||
|
||||
prepareAccept audience = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
hLocal <- asksSite siteInstanceHost
|
||||
obikhid <- encodeKeyHashid obiid
|
||||
let hAuthor = objUriAuthority $ remoteAuthorURI author
|
||||
|
||||
let ObjURI hAuthor _ = remoteAuthorURI author
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience auds
|
||||
collectAudience audience
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
doc = Doc hLocal Activity
|
||||
{ activityId =
|
||||
Just $ encodeRouteLocal $ actorOutboxItem actor obikhid
|
||||
, activityActor = encodeRouteLocal $ renderLocalActor actor
|
||||
, activityCapability = Nothing
|
||||
, activitySummary = Nothing
|
||||
, activityAudience = Audience recips [] [] [] [] []
|
||||
, activitySpecific = AcceptActivity Accept
|
||||
{ acceptObject = ObjURI hAuthor luUndo
|
||||
, 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 luUndo
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
|
||||
return (doc, recipientSet, remoteActors, fwdHosts)
|
||||
where
|
||||
actorOutboxItem (LocalActorSharer shr) = SharerOutboxItemR shr
|
||||
actorOutboxItem (LocalActorProject shr prj) = ProjectOutboxItemR shr prj
|
||||
actorOutboxItem (LocalActorRepo shr rp) = RepoOutboxItemR shr rp
|
||||
|
||||
sharerUndoF
|
||||
:: KeyHashid Person
|
||||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
||||
error "sharerUndoF temporarily disabled"
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
||||
|
||||
|
||||
|
||||
object <- parseActivity uObj
|
||||
mmmhttp <- runDBExcept $ do
|
||||
p <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
getValBy404 $ UniquePersonIdent sid
|
||||
mractid <- lift $ insertToInbox now author body (personInbox p) luUndo True
|
||||
for mractid $ \ ractid -> do
|
||||
mobject' <- getActivity object
|
||||
lift $ for mobject' $ \ object' -> do
|
||||
mobject'' <- runMaybeT $
|
||||
Left <$> MaybeT (getFollow object') <|>
|
||||
Right <$> MaybeT (getResolve object')
|
||||
for mobject'' $ \ object'' -> do
|
||||
(result, mfwdColl, macceptAuds) <-
|
||||
case object'' of
|
||||
Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (personFollowers p) erf
|
||||
Right tr -> deleteResolve myWorkItem prepareAccept tr
|
||||
mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
|
||||
let sieve = makeRecipientSet [] colls
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False ractid $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_S (actbBL body) ractid (personIdent p) sig remoteRecips
|
||||
mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
|
||||
obiidAccept <- insertEmptyOutboxItem (personOutbox p) now
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptOnUndo (LocalActorSharer shrRecip) author luUndo obiidAccept acceptAuds
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorSharer shrRecip)
|
||||
(personInbox p)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mmmhttp of
|
||||
Nothing -> return "Activity already in my inbox"
|
||||
Just mmhttp ->
|
||||
case mmhttp of
|
||||
Nothing -> return "Undo object isn't a known activity"
|
||||
Just mhttp ->
|
||||
case mhttp of
|
||||
Nothing -> return "Undo object isn't in use"
|
||||
Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "sharerUndoF inbox-forwarding" $
|
||||
deliverRemoteHTTP_S now shrRecip (actbBL body) sig remotes
|
||||
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
|
||||
forkWorker "sharerUndoF Accept HTTP delivery" $
|
||||
deliverRemoteHttp' fwdHosts obiid doc remotes
|
||||
let fwdMsg =
|
||||
case mremotesHttpFwd of
|
||||
Nothing -> "No inbox-forwarding"
|
||||
Just _ -> "Did inbox-forwarding"
|
||||
acceptMsg =
|
||||
case mremotesHttpAccept of
|
||||
Nothing -> "Didn't send Accept"
|
||||
Just _ -> "Sent Accept"
|
||||
return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
|
||||
where
|
||||
myWorkItem (WorkItemSharerTicket shr talid patch)
|
||||
| shr == shrRecip = Just (talid, patch)
|
||||
myWorkItem _ = Nothing
|
||||
|
||||
prepareAccept (talid, patch) = do
|
||||
talkhid <- encodeKeyHashid talid
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
ticketFollowers =
|
||||
if patch
|
||||
then LocalPersonCollectionSharerProposalFollowers shrRecip talkhid
|
||||
else LocalPersonCollectionSharerTicketFollowers shrRecip talkhid
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
audTicket =
|
||||
AudLocal [] [ticketFollowers]
|
||||
return ([ticketFollowers], [audAuthor, audTicket])
|
||||
-}
|
||||
|
||||
{-
|
||||
repoUndoF
|
||||
:: KeyHashid Repo
|
||||
-> UTCTime
|
||||
:: UTCTime
|
||||
-> KeyHashid Repo
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> AP.Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
repoUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
||||
error "repoUndoF temporarily disabled"
|
||||
repoUndoF now recipRepoHash author body mfwd luUndo (AP.Undo uObject) = do
|
||||
|
||||
-- Check input
|
||||
recipRepoID <- decodeKeyHashid404 recipRepoHash
|
||||
undone <-
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI uObject
|
||||
|
||||
-- Verify the capability URI, if provided, is one of:
|
||||
-- * Outbox item URI of a local actor, i.e. a local activity
|
||||
-- * A remote URI
|
||||
maybeCapability <-
|
||||
for (AP.activityCapability $ actbActivity body) $ \ uCap ->
|
||||
nameExceptT "Undo capability" $
|
||||
first (\ (actor, _, item) -> (actor, item)) <$>
|
||||
parseActivityURI uCap
|
||||
|
||||
maybeHttp <- runDBExcept $ do
|
||||
|
||||
-- Find recipient repo in DB, returning 404 if doesn't exist because we're
|
||||
-- in the repo's inbox post handler
|
||||
(recipRepoActorID, recipRepoActor) <- lift $ do
|
||||
repo <- get404 recipRepoID
|
||||
let actorID = repoActor repo
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
object <- parseActivity uObj
|
||||
mmmhttp <- runDBExcept $ do
|
||||
Entity rid r <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
getBy404 $ UniqueRepo rpRecip sid
|
||||
mractid <- lift $ insertToInbox now author body (repoInbox r) luUndo False
|
||||
for mractid $ \ ractid -> do
|
||||
mobject' <- getActivity object
|
||||
lift $ for mobject' $ \ object' -> do
|
||||
mobject'' <- runMaybeT $
|
||||
Left <$> MaybeT (getFollow object') <|>
|
||||
Right <$> MaybeT (getResolve object')
|
||||
for mobject'' $ \ object'' -> do
|
||||
(result, mfwdColl, macceptAuds) <-
|
||||
case object'' of
|
||||
Left erf -> (,Nothing,Nothing) <$> deleteRemoteFollow (isJust . myWorkItem) author (repoFollowers r) erf
|
||||
Right tr -> deleteResolve myWorkItem prepareAccept tr
|
||||
mremotesHttpFwd <- for (liftA2 (,) mfwd mfwdColl) $ \ ((localRecips, sig), colls) -> do
|
||||
let sieve = makeRecipientSet [] colls
|
||||
remoteRecips <-
|
||||
insertRemoteActivityToLocalInboxes
|
||||
False ractid $
|
||||
localRecipSieve'
|
||||
sieve False False localRecips
|
||||
(sig,) <$> deliverRemoteDB_R (actbBL body) ractid rid sig remoteRecips
|
||||
mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
|
||||
obiidAccept <- insertEmptyOutboxItem (repoOutbox r) now
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptOnUndo (LocalActorRepo shrRecip rpRecip) author luUndo obiidAccept acceptAuds
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorRepo shrRecip rpRecip)
|
||||
(repoInbox r)
|
||||
obiidAccept
|
||||
localRecipsAccept
|
||||
(obiidAccept,docAccept,fwdHostsAccept,) <$>
|
||||
deliverRemoteDB fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
|
||||
return (result, mremotesHttpFwd, mremotesHttpAccept)
|
||||
case mmmhttp of
|
||||
Nothing -> return "Activity already in my inbox"
|
||||
Just mmhttp ->
|
||||
case mmhttp of
|
||||
Nothing -> return "Undo object isn't a known activity"
|
||||
Just mhttp ->
|
||||
case mhttp of
|
||||
Nothing -> return "Undo object isn't in use"
|
||||
Just (msg, mremotesHttpFwd, mremotesHttpAccept) -> do
|
||||
for_ mremotesHttpFwd $ \ (sig, remotes) ->
|
||||
forkWorker "repoUndoF inbox-forwarding" $
|
||||
deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes
|
||||
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
|
||||
forkWorker "repoUndoF Accept HTTP delivery" $
|
||||
deliverRemoteHttp' fwdHosts obiid doc remotes
|
||||
let fwdMsg =
|
||||
case mremotesHttpFwd of
|
||||
Nothing -> "No inbox-forwarding"
|
||||
Just _ -> "Did inbox-forwarding"
|
||||
acceptMsg =
|
||||
case mremotesHttpAccept of
|
||||
Nothing -> "Didn't send Accept"
|
||||
Just _ -> "Sent Accept"
|
||||
return $ msg <> "; " <> fwdMsg <> "; " <> acceptMsg
|
||||
where
|
||||
myWorkItem (WorkItemRepoProposal shr rp ltid)
|
||||
| shr == shrRecip && rp == rpRecip = Just ltid
|
||||
myWorkItem _ = Nothing
|
||||
-- Insert the Undo to repo's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipRepoActor) luUndo False
|
||||
for mractid $ \ undoID -> do
|
||||
|
||||
prepareAccept ltid = do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
-- Find the undone activity in our DB
|
||||
undoneDB <- do
|
||||
a <- getActivity undone
|
||||
fromMaybeE a "Can't find undone in DB"
|
||||
|
||||
(sieve, acceptAudience) <- do
|
||||
(remoteFollowID, followerID) <- do
|
||||
maybeUndo <- do
|
||||
let followers = actorFollowers recipRepoActor
|
||||
lift $ runMaybeT $ tryUnfollow followers undoneDB
|
||||
fromMaybeE maybeUndo "Undone activity isn't a Follow related to me"
|
||||
(audSenderOnly, _audSenderAndFollowers) <- do
|
||||
ra <- lift $ getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
ticketFollowers =
|
||||
LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
audTicket =
|
||||
AudLocal [] [ticketFollowers]
|
||||
return ([ticketFollowers], [audAuthor, audTicket])
|
||||
-}
|
||||
return
|
||||
( AudRemote hAuthor [luAuthor] []
|
||||
, AudRemote hAuthor
|
||||
[luAuthor]
|
||||
(maybeToList $ remoteActorFollowers ra)
|
||||
)
|
||||
unless (followerID == remoteAuthorId author) $
|
||||
throwE "Trying to undo someone else's Follow"
|
||||
lift $ delete remoteFollowID
|
||||
return
|
||||
( makeRecipientSet [] []
|
||||
, [audSenderOnly]
|
||||
)
|
||||
|
||||
-- Forward the Undo activity to relevant local stages, and
|
||||
-- schedule delivery for unavailable remote members of them
|
||||
maybeHttpFwdUndo <- lift $ for mfwd $ \ (localRecips, sig) ->
|
||||
forwardActivityDB
|
||||
(actbBL body) localRecips sig recipRepoActorID
|
||||
(LocalActorRepo recipRepoHash) sieve undoID
|
||||
|
||||
|
||||
-- Prepare an Accept activity and insert to repo's outbox
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipRepoActor) now
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift . lift $ prepareAccept acceptAudience
|
||||
_luAccept <- lift $ updateOutboxItem (LocalActorRepo recipRepoID) acceptID actionAccept
|
||||
|
||||
-- Deliver the Accept to local recipients, and schedule delivery
|
||||
-- for unavailable remote recipients
|
||||
deliverHttpAccept <-
|
||||
deliverActivityDB
|
||||
(LocalActorRepo recipRepoHash) recipRepoActorID
|
||||
localRecipsAccept remoteRecipsAccept fwdHostsAccept
|
||||
acceptID actionAccept
|
||||
|
||||
-- Return instructions for HTTP inbox-forwarding of the Undo
|
||||
-- activity, and for HTTP delivery of the Accept activity to
|
||||
-- remote recipients
|
||||
return (maybeHttpFwdUndo, deliverHttpAccept)
|
||||
|
||||
-- Launch asynchronous HTTP forwarding of the Undo activity and HTTP
|
||||
-- delivery of the Accept activity
|
||||
case maybeHttp of
|
||||
Nothing -> return "I already have this activity in my inbox, doing nothing"
|
||||
Just (maybeHttpFwdUndo, deliverHttpAccept) -> do
|
||||
forkWorker "repoUndoF Accept HTTP delivery" deliverHttpAccept
|
||||
case maybeHttpFwdUndo of
|
||||
Nothing -> return "Undid, no inbox-forwarding to do"
|
||||
Just forwardHttpUndo -> do
|
||||
forkWorker "repoUndoF inbox-forwarding" forwardHttpUndo
|
||||
return "Undid and ran inbox-forwarding of the Undo"
|
||||
|
||||
where
|
||||
|
||||
tryUnfollow _ (Left _) = mzero
|
||||
tryUnfollow repoFollowersID (Right remoteActivityID) = do
|
||||
Entity remoteFollowID remoteFollow <-
|
||||
MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
|
||||
let followerID = remoteFollowActor remoteFollow
|
||||
followerSetID = remoteFollowTarget remoteFollow
|
||||
guard $ followerSetID == repoFollowersID
|
||||
return (remoteFollowID, followerID)
|
||||
|
||||
prepareAccept audience = do
|
||||
encodeRouteHome <- getEncodeRouteHome
|
||||
|
||||
let ObjURI hAuthor _ = remoteAuthorURI author
|
||||
|
||||
(recipientSet, remoteActors, fwdHosts, audLocal, audRemote) =
|
||||
collectAudience audience
|
||||
|
||||
recips = map encodeRouteHome audLocal ++ audRemote
|
||||
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 luUndo
|
||||
, AP.acceptResult = Nothing
|
||||
}
|
||||
}
|
||||
|
||||
return (action, recipientSet, remoteActors, fwdHosts)
|
||||
|
|
|
|||
|
|
@ -171,6 +171,8 @@ postLoomInboxR recipLoomHash =
|
|||
_ -> return ("Unsupported offer object type for looms", Nothing)
|
||||
AP.ResolveActivity resolve ->
|
||||
loomResolveF now recipLoomHash author body mfwd luActivity resolve
|
||||
AP.UndoActivity undo ->
|
||||
(,Nothing) <$> loomUndoF now recipLoomHash author body mfwd luActivity undo
|
||||
_ -> return ("Unsupported activity type for looms", Nothing)
|
||||
|
||||
getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent
|
||||
|
|
|
|||
|
|
@ -231,9 +231,9 @@ postPersonInboxR recipPersonHash = postInbox handle
|
|||
(,Nothing) <$> sharerRejectF shrRecip now author body mfwd luActivity reject
|
||||
ResolveActivity resolve ->
|
||||
(,Nothing) <$> sharerResolveF now shrRecip author body mfwd luActivity resolve
|
||||
UndoActivity undo ->
|
||||
(,Nothing) <$> sharerUndoF shrRecip now author body mfwd luActivity undo
|
||||
-}
|
||||
AP.UndoActivity undo ->
|
||||
(,Nothing) <$> personUndoF now recipPersonHash author body mfwd luActivity undo
|
||||
_ -> return ("Unsupported activity type for Person", Nothing)
|
||||
|
||||
getPersonOutboxR :: KeyHashid Person -> Handler TypedContent
|
||||
|
|
|
|||
|
|
@ -280,16 +280,12 @@ postRepoInboxR recipRepoHash =
|
|||
{-
|
||||
OfferActivity (Offer obj target) ->
|
||||
case obj of
|
||||
OfferTicket ticket ->
|
||||
(,Nothing) <$> repoOfferTicketF now shrRecip rpRecip remoteAuthor body mfwd luActivity ticket target
|
||||
OfferDep dep ->
|
||||
repoOfferDepF now shrRecip rpRecip remoteAuthor body mfwd luActivity dep target
|
||||
_ -> return ("Unsupported offer object type for repos", Nothing)
|
||||
ResolveActivity resolve ->
|
||||
(,Nothing) <$> repoResolveF now shrRecip rpRecip remoteAuthor body mfwd luActivity resolve
|
||||
UndoActivity undo->
|
||||
(,Nothing) <$> repoUndoF shrRecip rpRecip now remoteAuthor body mfwd luActivity undo
|
||||
-}
|
||||
AP.UndoActivity undo->
|
||||
(,Nothing) <$> repoUndoF now recipRepoHash author body mfwd luActivity undo
|
||||
_ -> return ("Unsupported activity type for repos", Nothing)
|
||||
|
||||
getRepoOutboxR :: KeyHashid Repo -> Handler TypedContent
|
||||
|
|
|
|||
Loading…
Reference in a new issue