From 648204ef809bac7c3a9f9f0d29429aaaa6bd5cd9 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Tue, 25 Oct 2022 18:49:19 +0000 Subject: [PATCH] S2S: Implement loomResolveF, allowing to close MR without Applying --- src/Vervis/Federation/Ticket.hs | 286 +++++++++++++------------------- src/Vervis/Handler/Loom.hs | 2 + 2 files changed, 117 insertions(+), 171 deletions(-) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index b1f034a..6446d80 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -13,6 +13,8 @@ - . -} +{-# LANGUAGE RankNTypes #-} + module Vervis.Federation.Ticket ( --personOfferTicketF deckOfferTicketF @@ -26,7 +28,7 @@ module Vervis.Federation.Ticket --, repoOfferDepF , deckResolveF - --, repoResolveF + , loomResolveF ) where @@ -1864,29 +1866,50 @@ insertResolve author ltid ractid obiidAccept = do } -} -deckResolveF - :: UTCTime - -> KeyHashid Deck +trackerResolveF + :: ( PersistRecordBackend r SqlBackend, ToBackendKey SqlBackend r + , ToBackendKey SqlBackend wi + ) + => (Route App -> Maybe (KeyHashid wi)) + -> (r -> ActorId) + -> ( Key r + -> Key wi + -> ExceptT Text AppDB + ( TicketId + , Maybe + ( Entity TicketResolve + , Either + (Entity TicketResolveLocal) + (Entity TicketResolveRemote) + ) + ) + ) + -> (Key r -> GrantResourceBy Key) + -> (KeyHashid r -> LocalStageBy KeyHashid) + -> (KeyHashid r -> KeyHashid wi -> LocalStageBy KeyHashid) + -> (forall f. f r -> LocalActorBy f) + -> UTCTime + -> KeyHashid r -> RemoteAuthor -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI -> AP.Resolve URIMode -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) -deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do +trackerResolveF maybeWorkItem grabActor getWorkItem makeResource trackerFollowers itemFollowers makeLocalActor now recipHash author body mfwd luResolve (AP.Resolve uObject) = (,Nothing) <$> do -- Check input - recipDeckID <- decodeKeyHashid404 recipDeckHash - taskID <- nameExceptT "Resolve object" $ do + recipID <- decodeKeyHashid404 recipHash + wiID <- 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" + case maybeWorkItem route of + Nothing -> throwE "Local route but not a work item of mine" + Just wiHash -> + decodeKeyHashidE wiHash "Invalid work item keyhashid" -- Verify the capability URI is one of: -- * Outbox item URI of a local actor, i.e. a local activity @@ -1900,64 +1923,62 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = maybeHttp <- runDBExcept $ do - -- 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 + -- Find recipient tracker in DB, returning 404 if doesn't exist because + -- we're in the tracker's inbox post handler + recip <- lift $ get404 recipID + let recipActorID = grabActor recip + recipActor <- lift $ getJust recipActorID - -- Insert the Resolve to deck's inbox - mractid <- lift $ insertToInbox now author body (actorInbox recipDeckActor) luResolve False + -- Insert the Resolve to tracker's inbox + mractid <- lift $ insertToInbox now author body (actorInbox recipActor) 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" + (ticketID, maybeResolve) <- getWorkItem recipID wiID unless (isNothing maybeResolve) $ - throwE "Ticket is already resolved" + throwE "Work item is already resolved" return ticketID - -- Verify the sender is authorized by the deck to resolve a ticket + -- Verify the sender is authorized by the tracker 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" + Right _ -> throwE "Capability is a remote URI, i.e. not authored by the local tracker" verifyCapability capability (Right $ remoteAuthorId author) - (GrantResourceDeck recipDeckID) + (makeResource recipID) -- 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 + wiHash <- encodeKeyHashid wiID let sieve = makeRecipientSet [] - [ LocalStageDeckFollowers recipDeckHash - , LocalStageTicketFollowers recipDeckHash taskHash + [ trackerFollowers recipHash + , itemFollowers recipHash wiHash ] forwardActivityDB - (actbBL body) localRecips sig recipDeckActorID - (LocalActorDeck recipDeckHash) sieve resolveID + (actbBL body) localRecips sig recipActorID + (makeLocalActor recipHash) sieve resolveID -- Mark ticket in DB as resolved by the Resolve acceptID <- - lift $ insertEmptyOutboxItem (actorOutbox recipDeckActor) now + lift $ insertEmptyOutboxItem (actorOutbox recipActor) now lift $ insertResolve ticketID resolveID acceptID - -- Prepare an Accept activity and insert to deck's outbox + -- Prepare an Accept activity and insert to tracker's outbox (actionAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- - lift $ prepareAccept taskID - _luAccept <- lift $ updateOutboxItem (LocalActorDeck recipDeckID) acceptID actionAccept + lift $ prepareAccept wiID + _luAccept <- lift $ updateOutboxItem (makeLocalActor recipID) acceptID actionAccept -- Deliver the Accept to local recipients, and schedule delivery -- for unavailable remote recipients deliverHttpAccept <- deliverActivityDB - (LocalActorDeck recipDeckHash) recipDeckActorID + (makeLocalActor recipHash) recipActorID localRecipsAccept remoteRecipsAccept fwdHostsAccept acceptID actionAccept @@ -1973,8 +1994,8 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = 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 + forkWorker "trackerResolveF inbox-forwarding" + forkWorker "trackerResolveF Accept HTTP delivery" deliverHttpAccept return $ case maybeHttpFwdResolve of Nothing -> "Resolved ticket, no inbox-forwarding to do" @@ -1994,10 +2015,10 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = , ticketResolveRemoteActor = remoteAuthorId author } - prepareAccept taskID = do + prepareAccept wiID = do encodeRouteHome <- getEncodeRouteHome - taskHash <- encodeKeyHashid taskID + wiHash <- encodeKeyHashid wiID ra <- getJust $ remoteAuthorId author @@ -2010,8 +2031,8 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = audTracker = AudLocal [] - [ LocalStageDeckFollowers recipDeckHash - , LocalStageTicketFollowers recipDeckHash taskHash + [ trackerFollowers recipHash + , itemFollowers recipHash wiHash ] (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = @@ -2031,139 +2052,62 @@ deckResolveF now recipDeckHash author body mfwd luResolve (AP.Resolve uObject) = return (action, recipientSet, remoteActors, fwdHosts) -repoResolveF +deckResolveF :: UTCTime - -> KeyHashid Repo + -> KeyHashid Deck -> RemoteAuthor -> ActivityBody -> Maybe (RecipientRoutes, ByteString) -> LocalURI - -> Resolve URIMode - -> ExceptT Text Handler Text -repoResolveF now recipHash author body mfwd luResolve (Resolve uObject) = do - error "repoResolveF temporarily disabled" + -> AP.Resolve URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +deckResolveF now deckHash = + trackerResolveF + (\case + TicketR trackerHash taskHash | trackerHash == deckHash -> + Just taskHash + _ -> Nothing + ) + deckActor + (\ deckID taskID -> do + maybeTicket <- lift $ getTicket deckID taskID + (_deck, _task, Entity ticketID _, _author, maybeResolve) <- + fromMaybeE maybeTicket "I don't have such a ticket in DB" + return (ticketID, maybeResolve) + ) + GrantResourceDeck + LocalStageDeckFollowers + LocalStageTicketFollowers + LocalActorDeck + now + deckHash - - -{- - - - object <- parseWorkItem "Resolve object" uObject - mmmmhttp <- runDBExcept $ do - Entity ridRecip repoRecip <- lift $ do - sid <- getKeyBy404 $ UniqueSharer shrRecip - getBy404 $ UniqueRepo rpRecip sid - 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 (repoInbox repoRecip) luResolve False - lift $ for mractid $ \ ractid -> for mltid $ \ (ltid, tid) -> do - mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do - ltkhid <- encodeKeyHashid ltid - let sieve = - makeRecipientSet - [] - [ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid - , LocalPersonCollectionRepoTeam shrRecip rpRecip - , LocalPersonCollectionRepoFollowers shrRecip rpRecip - ] - remoteRecips <- - insertRemoteActivityToLocalInboxes - False ractid $ - localRecipSieve' - sieve False False localRecips - (sig,) <$> deliverRemoteDB_R (actbBL body) ractid ridRecip sig remoteRecips - obiidAccept <- insertEmptyOutboxItem (repoOutbox repoRecip) 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 - (LocalActorRepo shrRecip rpRecip) - (repoInbox repoRecip) - 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 "repoResolveF inbox-forwarding" $ - deliverRemoteHTTP_R now shrRecip rpRecip (actbBL body) sig remotes - forkWorker "repoResolveF 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" - where - relevantObject (Left (WorkItemRepoProposal shr rp ltid)) - | shr == shrRecip && rp == rpRecip = Just ltid - relevantObject _ = Nothing - - getObjectLtid ltid = do - (_, _, Entity tid _, _, _, _, _, _, _) <- do - mticket <- lift $ getRepoProposal shrRecip rpRecip ltid - fromMaybeE mticket $ "Object" <> ": No such repo-patch" - return tid - - insertAccept luResolve ltid obiidAccept = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - obikhidAccept <- encodeKeyHashid obiidAccept - ltkhid <- encodeKeyHashid ltid - ra <- getJust $ remoteAuthorId author - let ObjURI hAuthor luAuthor = remoteAuthorURI author - - audAuthor = - AudRemote hAuthor [luAuthor] (maybeToList $ remoteActorFollowers ra) - - audTicket = - AudLocal - [] - [ LocalPersonCollectionRepoProposalFollowers shrRecip rpRecip ltkhid - , LocalPersonCollectionRepoTeam shrRecip rpRecip - , LocalPersonCollectionRepoFollowers shrRecip rpRecip - ] - - (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = - collectAudience [audAuthor, audTicket] - - recips = map encodeRouteHome audLocal ++ audRemote - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - RepoOutboxItemR shrRecip rpRecip obikhidAccept - , activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip - , activityCapability = Nothing - , activitySummary = Nothing - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = ObjURI hAuthor luResolve - , acceptResult = Nothing - } - } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return (doc, recipientSet, remoteActors, fwdHosts) --} +loomResolveF + :: UTCTime + -> KeyHashid Loom + -> RemoteAuthor + -> ActivityBody + -> Maybe (RecipientRoutes, ByteString) + -> LocalURI + -> AP.Resolve URIMode + -> ExceptT Text Handler (Text, Maybe (ExceptT Text Worker Text)) +loomResolveF now loomHash = + trackerResolveF + (\case + ClothR trackerHash clothHash | trackerHash == loomHash -> + Just clothHash + _ -> Nothing + ) + loomActor + (\ loomID clothID -> do + maybeCloth <- lift $ getCloth loomID clothID + (_loom, _cloth, Entity ticketID _, _author, maybeResolve, _merge) <- + fromMaybeE maybeCloth "I don't have such a MR in DB" + return (ticketID, maybeResolve) + ) + GrantResourceLoom + LocalStageLoomFollowers + LocalStageClothFollowers + LocalActorLoom + now + loomHash diff --git a/src/Vervis/Handler/Loom.hs b/src/Vervis/Handler/Loom.hs index 356dac2..d62b6cd 100644 --- a/src/Vervis/Handler/Loom.hs +++ b/src/Vervis/Handler/Loom.hs @@ -166,6 +166,8 @@ postLoomInboxR recipLoomHash = AP.OfferTicket ticket -> loomOfferTicketF now recipLoomHash author body mfwd luActivity ticket target _ -> return ("Unsupported offer object type for looms", Nothing) + AP.ResolveActivity resolve -> + loomResolveF now recipLoomHash author body mfwd luActivity resolve _ -> return ("Unsupported activity type for looms", Nothing) getLoomOutboxR :: KeyHashid Loom -> Handler TypedContent