From ebe676d94bec708329f8101a2540589e6c4b547c Mon Sep 17 00:00:00 2001 From: Pere Lev Date: Sun, 5 Nov 2023 17:41:16 +0200 Subject: [PATCH] Client: Port/implement pseudo-client for unresolve-a-ticket --- src/Vervis/Client.hs | 226 ++++++++++++++++++++++++++----------------- 1 file changed, 135 insertions(+), 91 deletions(-) diff --git a/src/Vervis/Client.hs b/src/Vervis/Client.hs index 01a16d1..c17fe8f 100644 --- a/src/Vervis/Client.hs +++ b/src/Vervis/Client.hs @@ -26,11 +26,11 @@ module Vervis.Client --, followRepo , offerIssue , resolve + , unresolve --, undoFollowSharer --, undoFollowProject --, undoFollowTicket --, undoFollowRepo - --, unresolve , offerPatches , offerMerge , applyPatches @@ -92,10 +92,13 @@ import Vervis.Data.Ticket import Vervis.FedURI import Vervis.Foundation import Vervis.Model -import Vervis.Recipient +import Vervis.Persist.Actor +import Vervis.Recipient (Aud (..), LocalStageBy (..), collectAudience, renderLocalActor, localActorFollowers) import Vervis.RemoteActorStore import Vervis.Ticket +import qualified Vervis.Recipient as VR + makeServerInput :: (MonadSite m, SiteEnv m ~ App) => Maybe FedURI @@ -370,28 +373,26 @@ resolve -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Resolve URIMode) resolve senderHash uObject = do - manager <- asksSite appHttpManager - AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left uObject) - uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context" - audFollowers <- do - (hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id" - let luFollowers = AP.ticketParticipants tl - routeOrRemote <- parseFedURIOld $ ObjURI hFollowers luFollowers + encodeRouteHome <- getEncodeRouteHome + (uTracker, audFollowers) <- do + routeOrRemote <- parseFedURIOld uObject case routeOrRemote of - Left route -> - case route of - TicketFollowersR d t -> - return $ - AudLocal - [] - [LocalStageTicketFollowers d t] - ClothFollowersR l c -> - return $ - AudLocal - [] - [LocalStageClothFollowers l c] - _ -> throwE "Not a tickets followers route" - Right u@(ObjURI h lu) -> return $ AudRemote h [] [lu] + Left route -> do + wih <- fromMaybeE (parseWorkItem route) "Not a work item route" + wi <- runActE $ unhashWorkItemE wih "Work item invalid keyhashid" + let uTracker = + encodeRouteHome $ renderLocalActor $ workItemActor wih + audFollowers = AudLocal [] [workItemFollowers wih] + return (uTracker, audFollowers) + Right u -> do + manager <- asksSite appHttpManager + AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left u) + uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context" + audFollowers <- do + (hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id" + let luFollowers = AP.ticketParticipants tl + return $ AudRemote hFollowers [] [luFollowers] + return (uTracker, audFollowers) tracker <- do tracker <- runActE $ checkTracker uTracker @@ -428,6 +429,116 @@ resolve senderHash uObject = do return (Nothing, audience, AP.Resolve uObject) +unresolve + :: KeyHashid Person + -> FedURI + -> ExceptT Text Handler (Maybe HTML, [Aud URIMode], AP.Undo URIMode) +unresolve senderHash uTicket = do + + encodeRouteHome <- getEncodeRouteHome + (uTracker, audFollowers, uResolve) <- do + routeOrRemote <- parseFedURIOld uTicket + case routeOrRemote of + Left route -> do + wih <- fromMaybeE (parseWorkItem route) "Not a work item route" + wi <- runActE $ unhashWorkItemE wih "Work item invalid keyhashid" + let uTracker = + encodeRouteHome $ renderLocalActor $ workItemActor wih + audFollowers = AudLocal [] [workItemFollowers wih] + resolved <- runDBExcept $ do + mresolved <- + case wi of + WorkItemTicket d t -> do + (_, _, _, _, mresolved) <- do + mt <- lift $ getTicket d t + fromMaybeE mt "No such ticket in DB" + return mresolved + WorkItemCloth l c -> do + (_, _, _, _, mresolved, _) <- do + mc <- lift $ getCloth l c + fromMaybeE mc "No such MR in DB" + return mresolved + (_, etrx) <- fromMaybeE mresolved "Ticket not resolved" + lift $ bitraverse + (\ (Entity _ trl) -> do + let obiid = ticketResolveLocalActivity trl + obid <- outboxItemOutbox <$> getJust obiid + actorID <- do + maybeActorID <- getKeyBy $ UniqueActorOutbox obid + case maybeActorID of + Nothing -> error "Found outbox not used by any actor" + Just a -> return a + actor <- getLocalActor actorID + return (actor, obiid) + ) + (\ (Entity _ trr) -> do + roid <- + remoteActivityIdent <$> + getJust (ticketResolveRemoteActivity trr) + ro <- getJust roid + i <- getJust $ remoteObjectInstance ro + return (i, ro) + ) + etrx + hashItem <- getEncodeKeyHashid + hashActor <- VR.getHashLocalActor + let uResolve = + case resolved of + Left (actor, obiid) -> + encodeRouteHome $ + activityRoute (hashActor actor) (hashItem obiid) + Right (i, ro) -> + ObjURI (instanceHost i) (remoteObjectIdent ro) + return (uTracker, audFollowers, uResolve) + Right u -> do + manager <- asksSite appHttpManager + AP.Doc _ t <- withExceptT T.pack $ fetchAP manager (Left u) + uTracker <- fromMaybeE (AP.ticketContext t) "Ticket without context" + audFollowers <- do + (hFollowers, tl) <- fromMaybeE (AP.ticketLocal t) "Ticket without id" + let luFollowers = AP.ticketParticipants tl + return $ AudRemote hFollowers [] [luFollowers] + uResolve <- + case AP.ticketResolved t of + Just (Just u, _) -> return u + _ -> throwE "No ticket resolve URI specified" + return (uTracker, audFollowers, uResolve) + + tracker <- do + tracker <- runActE $ checkTracker uTracker + case tracker of + TrackerDeck deckID -> Left . Left <$> encodeKeyHashid deckID + TrackerLoom loomID -> Left . Right <$> encodeKeyHashid loomID + TrackerRemote (ObjURI hTracker luTracker) -> Right <$> do + instanceID <- lift $ runDB $ either entityKey id <$> insertBy' (Instance hTracker) + result <- ExceptT $ first (T.pack . displayException) <$> fetchRemoteActor instanceID hTracker luTracker + case result of + Left Nothing -> throwE "Tracker @id mismatch" + Left (Just err) -> throwE $ T.pack $ displayException err + Right Nothing -> throwE "Tracker isn't an actor" + Right (Just actor) -> return (entityVal actor, uTracker) + + let audAuthor = + AudLocal [] [LocalStagePersonFollowers senderHash] + audTracker = + case tracker of + Left (Left deckHash) -> + AudLocal + [LocalActorDeck deckHash] + [LocalStageDeckFollowers deckHash] + Left (Right loomHash) -> + AudLocal + [LocalActorLoom loomHash] + [LocalStageLoomFollowers loomHash] + Right (remoteActor, ObjURI hTracker luTracker) -> + AudRemote hTracker + [luTracker] + (maybeToList $ remoteActorFollowers remoteActor) + + audience = [audAuthor, audTracker, audFollowers] + + return (Nothing, audience, AP.Undo uResolve) + {- undoFollow :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) @@ -568,73 +679,6 @@ undoFollowRepo shrAuthor pidAuthor shrFollowee rpFollowee = repoFollowers <$> fromMaybeE mr "Unfollow target no such local repo" -} - -unresolve - :: (MonadUnliftIO m, MonadHandler m, HandlerSite m ~ App, MonadSite m, SiteEnv m ~ App) - => ShrIdent - -> FedURI - -> m (Either Text (Maybe TextHtml, Audience URIMode, Undo URIMode)) -unresolve shrUser uTicket = runExceptT $ do - error "Temporarily disabled" - {- - encodeRouteHome <- getEncodeRouteHome - wiFollowers <- askWorkItemFollowers - ticket <- parseWorkItem "Ticket" uTicket - WorkItemDetail ident context author <- runWorkerExcept $ getWorkItemDetail "Ticket" ticket - uResolve <- - case ident of - Left (_, ltid) -> runSiteDBExcept $ do - mtrid <- lift $ getKeyBy $ UniqueTicketResolve ltid - trid <- fromMaybeE mtrid "Ticket already isn't resolved" - trx <- - lift $ - requireEitherAlt - (getValBy $ UniqueTicketResolveLocal trid) - (getValBy $ UniqueTicketResolveRemote trid) - "No TRX" - "Both TRL and TRR" - case trx of - Left trl -> lift $ do - let obiid = ticketResolveLocalActivity trl - obid <- outboxItemOutbox <$> getJust obiid - ent <- getOutboxActorEntity obid - obikhid <- encodeKeyHashid obiid - encodeRouteHome . flip outboxItemRoute obikhid <$> - actorEntityPath ent - Right trr -> lift $ do - roid <- - remoteActivityIdent <$> - getJust (ticketResolveRemoteActivity trr) - ro <- getJust roid - i <- getJust $ remoteObjectInstance ro - return $ ObjURI (instanceHost i) (remoteObjectIdent ro) - Right (u, _) -> do - manager <- asksSite appHttpManager - Doc _ t <- withExceptT T.pack $ AP.fetchAP manager $ Left u - case ticketResolved t of - Nothing -> throwE "Ticket already isn't resolved" - Just (muBy, _) -> fromMaybeE muBy "Ticket doesn't specify 'resolvedBy'" - let audAuthor = - AudLocal - [LocalActorSharer shrUser] - [LocalPersonCollectionSharerFollowers shrUser] - audTicketContext = contextAudience context - audTicketAuthor = authorAudience author - audTicketFollowers = - case ident of - Left (wi, _ltid) -> AudLocal [] [wiFollowers wi] - Right (ObjURI h _, luFollowers) -> AudRemote h [] [luFollowers] - - (_, _, _, audLocal, audRemote) = - collectAudience $ - audAuthor : - audTicketAuthor : - audTicketFollowers : - audTicketContext - - recips = map encodeRouteHome audLocal ++ audRemote - return (Nothing, Audience recips [] [] [] [] [], Undo uResolve) - -} -} offerPatches @@ -1315,7 +1359,7 @@ acceptProjectInvite personID component project uInvite = do encodeRouteHome <- getEncodeRouteHome theater <- asksSite appTheater env <- asksSite appEnv - component' <- Vervis.Recipient.hashLocalActor component + component' <- VR.hashLocalActor component project' <- bitraverse encodeKeyHashid pure project let activity = AP.Accept uInvite Nothing