mirror of
https://code.sup39.dev/repos/Wqawg
synced 2024-12-27 18:54:53 +09:00
S2S: Implement deckUndoF
This commit is contained in:
fr33domlover
parent
934c69daae
commit
9b158c13cd
2 changed files with 215 additions and 107 deletions
|
|
@ -26,7 +26,7 @@ module Vervis.Federation.Offer
|
|||
, repoFollowF
|
||||
|
||||
--, sharerUndoF
|
||||
--, projectUndoF
|
||||
, deckUndoF
|
||||
--, repoUndoF
|
||||
)
|
||||
where
|
||||
|
|
@ -79,6 +79,7 @@ import Data.Tuple.Local
|
|||
import Database.Persist.Local
|
||||
import Yesod.Persist.Local
|
||||
|
||||
import Vervis.Access
|
||||
import Vervis.ActivityPub
|
||||
import Vervis.Cloth
|
||||
import Vervis.Data.Actor
|
||||
|
|
@ -676,6 +677,217 @@ repoFollowF now recipRepoHash =
|
|||
now
|
||||
recipRepoHash
|
||||
|
||||
deckUndoF
|
||||
:: UTCTime
|
||||
-> KeyHashid Deck
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (RecipientRoutes, ByteString)
|
||||
-> LocalURI
|
||||
-> AP.Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
deckUndoF now recipDeckHash author body mfwd luUndo (AP.Undo uObject) = do
|
||||
|
||||
-- Check input
|
||||
recipDeckID <- decodeKeyHashid404 recipDeckHash
|
||||
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 deck in DB, returning 404 if doesn't exist because we're
|
||||
-- in the deck's inbox post handler
|
||||
(recipDeckActorID, recipDeckActor) <- lift $ do
|
||||
deck <- get404 recipDeckID
|
||||
let actorID = deckActor deck
|
||||
(actorID,) <$> getJust actorID
|
||||
|
||||
-- Insert the Undo to deck's inbox
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) 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 recipDeckActor
|
||||
lift $ runMaybeT $
|
||||
Left <$> tryUnfollow recipDeckID followers undoneDB <|>
|
||||
Right <$> tryUnresolve recipDeckID 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, taskID) -> do
|
||||
|
||||
-- Verify the sender is authorized by the deck to unresolve a ticket
|
||||
capability <- do
|
||||
cap <-
|
||||
fromMaybeE
|
||||
maybeCapability
|
||||
"Asking to unresolve ticket 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)
|
||||
(GrantResourceDeck recipDeckID)
|
||||
|
||||
lift deleteFromDB
|
||||
|
||||
taskHash <- encodeKeyHashid taskID
|
||||
return
|
||||
( makeRecipientSet
|
||||
[LocalActorDeck recipDeckHash]
|
||||
[ LocalStageDeckFollowers recipDeckHash
|
||||
, LocalStageTicketFollowers recipDeckHash taskHash
|
||||
]
|
||||
, [ AudLocal
|
||||
[]
|
||||
[ LocalStageDeckFollowers recipDeckHash
|
||||
, LocalStageTicketFollowers recipDeckHash taskHash
|
||||
]
|
||||
, 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 recipDeckActorID
|
||||
(LocalActorDeck recipDeckHash) sieve undoID
|
||||
|
||||
|
||||
-- Prepare an Accept activity and insert to deck's outbox
|
||||
acceptID <- lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now
|
||||
(actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
lift . lift $ prepareAccept acceptAudience
|
||||
_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 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 "deckUndoF Accept HTTP delivery" deliverHttpAccept
|
||||
case maybeHttpFwdUndo of
|
||||
Nothing -> return "Undid, no inbox-forwarding to do"
|
||||
Just forwardHttpUndo -> do
|
||||
forkWorker "deckUndoF inbox-forwarding" forwardHttpUndo
|
||||
return "Undid and ran inbox-forwarding of the Undo"
|
||||
|
||||
where
|
||||
|
||||
tryUnfollow _ _ (Left _) = mzero
|
||||
tryUnfollow deckID deckFollowersID (Right remoteActivityID) = do
|
||||
Entity remoteFollowID remoteFollow <-
|
||||
MaybeT $ getBy $ UniqueRemoteFollowFollow remoteActivityID
|
||||
let followerID = remoteFollowActor remoteFollow
|
||||
followerSetID = remoteFollowTarget remoteFollow
|
||||
if followerSetID == deckFollowersID
|
||||
then pure ()
|
||||
else do
|
||||
ticketID <-
|
||||
MaybeT $ getKeyBy $ UniqueTicketFollowers followerSetID
|
||||
TicketDeck _ d <-
|
||||
MaybeT $ getValBy $ UniqueTicketDeck ticketID
|
||||
guard $ d == deckID
|
||||
return (remoteFollowID, followerID)
|
||||
|
||||
tryUnresolve deckID undone = do
|
||||
(deleteFromDB, ticketID) <- findTicket undone
|
||||
Entity taskID (TicketDeck _ d) <-
|
||||
MaybeT $ getBy $ UniqueTicketDeck ticketID
|
||||
guard $ d == deckID
|
||||
return (deleteFromDB, taskID)
|
||||
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
|
||||
|
||||
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)
|
||||
|
||||
{-
|
||||
getFollow (Left _) = return Nothing
|
||||
getFollow (Right ractid) = getBy $ UniqueRemoteFollowFollow ractid
|
||||
|
|
@ -850,108 +1062,6 @@ sharerUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
|||
return ([ticketFollowers], [audAuthor, audTicket])
|
||||
-}
|
||||
|
||||
{-
|
||||
projectUndoF
|
||||
:: KeyHashid Project
|
||||
-> UTCTime
|
||||
-> RemoteAuthor
|
||||
-> ActivityBody
|
||||
-> Maybe (LocalRecipientSet, ByteString)
|
||||
-> LocalURI
|
||||
-> Undo URIMode
|
||||
-> ExceptT Text Handler Text
|
||||
projectUndoF recipHash now author body mfwd luUndo (Undo uObj) = do
|
||||
error "projectUndoF temporarily disabled"
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
object <- parseActivity uObj
|
||||
mmmhttp <- runDBExcept $ do
|
||||
(Entity jid j, a) <- lift $ do
|
||||
sid <- getKeyBy404 $ UniqueSharer shrRecip
|
||||
ej@(Entity _ j) <- getBy404 $ UniqueProject prjRecip sid
|
||||
(ej,) <$> getJust (projectActor j)
|
||||
mractid <- lift $ insertToInbox now author body (actorInbox a) 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 (actorFollowers a) 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_J (actbBL body) ractid jid sig remoteRecips
|
||||
mremotesHttpAccept <- for macceptAuds $ \ acceptAuds -> do
|
||||
obiidAccept <- insertEmptyOutboxItem (actorOutbox a) now
|
||||
(docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
|
||||
insertAcceptOnUndo (LocalActorProject shrRecip prjRecip) author luUndo obiidAccept acceptAuds
|
||||
knownRemoteRecipsAccept <-
|
||||
deliverLocal'
|
||||
False
|
||||
(LocalActorProject shrRecip prjRecip)
|
||||
(actorInbox a)
|
||||
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 "projectUndoF inbox-forwarding" $
|
||||
deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes
|
||||
for_ mremotesHttpAccept $ \ (obiid, doc, fwdHosts, remotes) ->
|
||||
forkWorker "projectUndoF 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 (WorkItemProjectTicket shr prj ltid)
|
||||
| shr == shrRecip && prj == prjRecip = Just ltid
|
||||
myWorkItem _ = Nothing
|
||||
|
||||
prepareAccept ltid = do
|
||||
ltkhid <- encodeKeyHashid ltid
|
||||
ra <- getJust $ remoteAuthorId author
|
||||
let ObjURI hAuthor luAuthor = remoteAuthorURI author
|
||||
ticketFollowers =
|
||||
LocalPersonCollectionProjectTicketFollowers shrRecip prjRecip ltkhid
|
||||
audAuthor =
|
||||
AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra)
|
||||
audTicket =
|
||||
AudLocal [] [ticketFollowers]
|
||||
return ([ticketFollowers], [audAuthor, audTicket])
|
||||
-}
|
||||
|
||||
{-
|
||||
repoUndoF
|
||||
:: KeyHashid Repo
|
||||
|
|
|
|||
|
|
@ -212,10 +212,8 @@ postDeckInboxR recipDeckHash =
|
|||
_ -> return ("Unsupported offer object type for decks", Nothing)
|
||||
AP.ResolveActivity resolve ->
|
||||
deckResolveF now recipDeckHash author body mfwd luActivity resolve
|
||||
{-
|
||||
UndoActivity undo ->
|
||||
(,Nothing) <$> projectUndoF shrRecip prjRecip now remoteAuthor body mfwd luActivity undo
|
||||
-}
|
||||
AP.UndoActivity undo ->
|
||||
(,Nothing) <$> deckUndoF now recipDeckHash author body mfwd luActivity undo
|
||||
_ -> return ("Unsupported activity type for decks", Nothing)
|
||||
|
||||
getDeckOutboxR :: KeyHashid Deck -> Handler TypedContent
|
||||
|
|
|
|||
Loading…
Reference in a new issue