diff --git a/src/Vervis/Federation/Offer.hs b/src/Vervis/Federation/Offer.hs index ee2ba3f..e4177aa 100644 --- a/src/Vervis/Federation/Offer.hs +++ b/src/Vervis/Federation/Offer.hs @@ -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 diff --git a/src/Vervis/Handler/Deck.hs b/src/Vervis/Handler/Deck.hs index c356d1b..73d24a1 100644 --- a/src/Vervis/Handler/Deck.hs +++ b/src/Vervis/Handler/Deck.hs @@ -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