From e4d7156cbc7beffd759b8d610173a6d19d6ac2e9 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Mon, 31 Oct 2022 14:13:18 +0000 Subject: [PATCH] S2S: Implement repoUndoF, loomUndoF, personUndoF --- src/Vervis/Federation/Offer.hs | 721 +++++++++++++++++++++------------ src/Vervis/Handler/Loom.hs | 2 + src/Vervis/Handler/Person.hs | 4 +- src/Vervis/Handler/Repo.hs | 8 +- 4 files changed, 476 insertions(+), 259 deletions(-) diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index e4177aa..d001ef0 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -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 - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - obikhid <- encodeKeyHashid obiid - let hAuthor = objUriAuthority $ remoteAuthorURI author + 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) - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience auds + 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 + ) - 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 + 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 + } } - } - 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 + + -- Insert the Undo to repo's inbox + mractid <- lift $ insertToInbox now author body (actorInbox recipRepoActor) 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 + (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 + 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" - 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 - prepareAccept ltid = do - ltkhid <- encodeKeyHashid ltid - ra <- 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]) --} + 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) diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 5f6ab16..4f5c75b 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -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 diff --git a/src/Vervis/Handler/Person.hs b/src/Vervis/Handler/Person.hs index 0161ac7..5e1cfc9 100644 --- a/src/Vervis/Handler/Person.hs +++ b/src/Vervis/Handler/Person.hs @@ -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 diff --git a/src/Vervis/Handler/Repo.hs b/src/Vervis/Handler/Repo.hs index 19a65d0..4e79ae1 100644 --- a/src/Vervis/Handler/Repo.hs +++ b/src/Vervis/Handler/Repo.hs @@ -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