From c78becaf5e713e5a1d96ffd351fa62a5322c6a32 Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 15 Jul 2020 11:20:11 +0000 Subject: [PATCH] S2S: projectCreateTicketF: Refactor to use new utils --- src/Vervis/Federation/Ticket.hs | 324 +++++++++++--------------------- 1 file changed, 114 insertions(+), 210 deletions(-) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 026c501..e2e1282 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -37,6 +37,7 @@ import Data.Aeson import Data.Bifunctor import Data.Bitraversable import Data.ByteString (ByteString) +import Data.Either import Data.Foldable import Data.Function import Data.List (nub, union) @@ -87,21 +88,6 @@ import Vervis.Patch import Vervis.Ticket import Vervis.WorkItem -checkOffer - :: AP.Ticket URIMode - -> Host - -> ShrIdent - -> PrjIdent - -> ExceptT Text Handler () -checkOffer ticket hProject shrProject prjProject = do - verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'" - verifyNothingE (AP.ticketPublished ticket) "Ticket with 'published'" - verifyNothingE (AP.ticketUpdated ticket) "Ticket with 'updated'" - -- verifyNothingE (AP.ticketName ticket) "Ticket with 'name'" - verifyNothingE (AP.ticketAssignedTo ticket) "Ticket with 'assignedTo'" - when (AP.ticketIsResolved ticket) $ throwE "Ticket resolved" - verifyNothingE (AP.ticketAttachment ticket) "Ticket with 'attachment'" - checkOfferTicket :: RemoteAuthor -> AP.Ticket URIMode @@ -180,53 +166,6 @@ sharerOfferTicketF now shrRecip author body mfwd luOffer ticket uTarget = do Nothing -> "Activity already exists in my inbox" Just _ -> "Activity inserted to my inbox" -data OfferTicketRecipColl - = OfferTicketRecipProjectFollowers - | OfferTicketRecipProjectTeam - deriving Eq - -findRelevantCollections shrRecip prjRecip hLocal = nub . mapMaybe decide . concatRecipients - where - decide u = do - let ObjURI h lu = u - guard $ h == hLocal - route <- decodeRouteLocal lu - case route of - ProjectTeamR shr prj - | shr == shrRecip && prj == prjRecip - -> Just OfferTicketRecipProjectTeam - ProjectFollowersR shr prj - | shr == shrRecip && prj == prjRecip - -> Just OfferTicketRecipProjectFollowers - _ -> Nothing - --- | Perform inbox forwarding, delivering a remote activity we received to --- local inboxes -deliverFwdLocal - :: RemoteActivityId - -> [OfferTicketRecipColl] - -> SharerId - -> FollowerSetId - -> AppDB [((InstanceId, Host), NonEmpty RemoteRecipient)] -deliverFwdLocal ractid recips sid fsid = do - (teamPids, teamRemotes) <- - if OfferTicketRecipProjectTeam `elem` recips - then getTicketTeam sid - else return ([], []) - (fsPids, fsRemotes) <- - if OfferTicketRecipProjectFollowers `elem` recips - then getFollowers fsid - else return ([], []) - let pids = union teamPids fsPids - remotes = unionRemotes teamRemotes fsRemotes - for_ pids $ \ pid -> do - ibid <- personInbox <$> getJust pid - ibiid <- insert $ InboxItem True - mibrid <- insertUnique $ InboxItemRemote ibid ractid ibiid - when (isNothing mibrid) $ - delete ibiid - return remotes - projectOfferTicketF :: UTCTime -> ShrIdent @@ -377,11 +316,15 @@ checkCreateTicket ( (Either (Bool, ShrIdent, PrjIdent) (Host, Maybe LocalURI, LocalURI)) , TicketLocal , UTCTime + , TextHtml + , TextHtml + , TextPandocMarkdown ) checkCreateTicket author ticket muTarget = do mtarget <- traverse (checkTracker "Create target") muTarget - (context, ticketData, published) <- checkTicket ticket - (, ticketData, published) <$> checkTargetAndContext mtarget context + (context, ticketData, published, title, desc, src) <- checkTicket ticket + (, ticketData, published, title, desc, src) <$> + checkTargetAndContext mtarget context where checkTracker name u@(ObjURI h lu) = do hl <- hostIsLocal h @@ -400,8 +343,8 @@ checkCreateTicket author ticket muTarget = do \route" else return $ Right u - checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext _summary - _content _source muAssigned resolved mmr) = do + checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary + content source muAssigned resolved mmr) = do (hTicket, tlocal) <- fromMaybeE mlocal "Ticket without 'id'" hl <- hostIsLocal hTicket when hl $ throwE "Remote author claims to create local ticket" @@ -418,7 +361,7 @@ checkCreateTicket author ticket muTarget = do when resolved $ throwE "Ticket is resolved" verifyNothingE mmr "Ticket has 'attachment'" - return (context, tlocal, pub) + return (context, tlocal, pub, summary, content, source) checkTargetAndContext Nothing context = return $ @@ -453,7 +396,8 @@ sharerCreateTicketF -> Maybe FedURI -> ExceptT Text Handler Text sharerCreateTicketF now shrRecip author body mfwd luCreate ticket muTarget = do - (targetAndContext, _, _) <- checkCreateTicket author ticket muTarget + (targetAndContext, _, _, _, _, _) <- + checkCreateTicket author ticket muTarget mractid <- runDBExcept $ do ibidRecip <- lift $ do sid <- getKeyBy404 $ UniqueSharer shrRecip @@ -484,152 +428,71 @@ projectCreateTicketF -> Maybe FedURI -> ExceptT Text Handler Text projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTarget = do - (targetAndContext, tlocal, published) <- checkCreateTicket author ticket muTarget - case targetAndContext of - Left (_, shrContext, prjContext) - | shrRecip == shrContext && prjRecip == prjContext -> do - msgOrRecips <- lift $ runDB $ do - (sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject - mractidCreate <- insertCreate luCreate ibidProject - case mractidCreate of - Nothing -> return $ Left "Already have this activity in project inbox, ignoring" - Just ractidCreate -> do - (obiidAccept, docAccept, localRecipsAccept, remoteRecipsAccept, fwdAccept) <- insertAccept obidProject luCreate tlocal - result <- insertTicket jid (AP.ticketId tlocal) published ractidCreate obiidAccept - case result of - Left False -> do - delete obiidAccept - return $ Left "Already have a ticket opened by this activity, ignoring" - Left True -> do - delete obiidAccept - return $ Left "Already have this ticket, ignoring" - Right () -> do - hLocal <- getsYesod siteInstanceHost - let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body - mremoteRecipsHttpCreateFwd <- for mfwd $ \ (_, sig) -> do - remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject - (sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips - remoteRecipsHttpAccept <- do - moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept - deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept - return $ Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) - case msgOrRecips of - Left msg -> return msg - Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do - for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig recips - forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept - return "Accepting and listing new remote author hosted ticket" - _ -> return "Create/Ticket against different project, ignoring" + (targetAndContext, tlocal, published, title, desc, src) <- checkCreateTicket author ticket muTarget + mmhttp <- for (targetRelevance targetAndContext) $ \ () -> lift $ runDB $ do + Entity jid j <- do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getBy404 $ UniqueProject prjRecip sid + mractid <- insertToInbox now author body (projectInbox j) luCreate False + for mractid $ \ ractid -> do + obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now + result <- insertTicket jid author (AP.ticketId tlocal) published title desc src ractid obiidAccept + unless (isRight result) $ delete obiidAccept + for result $ \ () -> do + mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do + let sieve = + makeRecipientSet + [] + [ LocalPersonCollectionProjectTeam shrRecip prjRecip + , LocalPersonCollectionProjectFollowers shrRecip prjRecip + ] + remoteRecips <- + insertRemoteActivityToLocalInboxes + False ractid $ + localRecipSieve' + sieve False False localRecips + (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAccept shrRecip prjRecip author luCreate tlocal obiidAccept + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorProject shrRecip prjRecip) + (projectInbox j) + obiidAccept + localRecipsAccept + (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + case mmhttp of + Nothing -> return "Create/Ticket against different project, not using" + Just mhttp -> + case mhttp of + Nothing -> return "Activity already in my inbox, doing nothing" + Just e -> + case e of + Left False -> return "Already have a ticket opened by this activity, ignoring" + Left True -> return "Already have this ticket, ignoring" + Right (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "projectCreateTicketF inbox-forwarding" $ + deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes + forkWorker "projectCreateTicketF Accept HTTP delivery" $ + deliverRemoteHttp' fwdHosts obiid doc remotes + return $ + case mremotesHttpFwd of + Nothing -> "Accepted and listed ticket, no inbox-forwarding to do" + Just _ -> "Accepted and listed ticket and ran inbox-forwarding of the Create" where - getProject = do - sid <- getKeyBy404 $ UniqueSharer shrRecip - Entity jid j <- getBy404 $ UniqueProject prjRecip sid - return (sid, jid, projectOutbox j, projectInbox j, projectFollowers j) - - insertCreate luCreate ibidProject = do - roid <- either entityKey id <$> insertBy' RemoteObject - { remoteObjectInstance = remoteAuthorInstance author - , remoteObjectIdent = luCreate - } - let raidAuthor = remoteAuthorId author - ractidCreate <- either entityKey id <$> insertBy' RemoteActivity - { remoteActivityIdent = roid - , remoteActivityContent = persistJSONFromBL $ actbBL body - , remoteActivityReceived = now - } - ibiid <- insert $ InboxItem False - mibirid <- - insertUnique $ InboxItemRemote ibidProject ractidCreate ibiid - case mibirid of - Nothing -> do - delete ibiid - return Nothing - Just _ -> return $ Just ractidCreate - - insertAccept obidProject luCreate tlocal = do - encodeRouteLocal <- getEncodeRouteLocal - encodeRouteHome <- getEncodeRouteHome - hLocal <- asksSite siteInstanceHost - obiidAccept <- insert OutboxItem - { outboxItemOutbox = obidProject - , outboxItemActivity = - persistJSONObjectFromDoc $ Doc hLocal emptyActivity - , outboxItemPublished = now - } - obikhidAccept <- encodeKeyHashid obiidAccept - ra <- getJust $ remoteAuthorId author - summary <- do - let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author - TextHtml . TL.toStrict . renderHtml <$> - withUrlRenderer - [hamlet| -

- - $maybe name <- remoteActorName ra - #{name} - $nothing - #{renderAuthority hAuthor}#{localUriPath luAuthor} - \'s ticket accepted and listed by project # - - ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip} - \: # - - #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. - |] - let localRecipsA = - [ - ] - localRecipsC = - [ LocalPersonCollectionProjectTeam shrRecip prjRecip - , LocalPersonCollectionProjectFollowers shrRecip prjRecip - ] - remoteRecipsA = - objUriLocal (remoteAuthorURI author) :| [] - remoteRecipsC = catMaybes - [ remoteActorFollowers ra - , Just $ AP.ticketParticipants tlocal - , AP.ticketTeam tlocal - ] - localRecips = - map encodeRouteHome $ - map renderLocalActor localRecipsA ++ - map renderLocalPersonCollection localRecipsC - remoteRecips = - map (ObjURI $ objUriAuthority $ remoteAuthorURI author) $ - NE.toList remoteRecipsA ++ remoteRecipsC - recips = localRecips ++ remoteRecips - doc = Doc hLocal Activity - { activityId = - Just $ encodeRouteLocal $ - ProjectOutboxItemR shrRecip prjRecip obikhidAccept - , activityActor = - encodeRouteLocal $ ProjectR shrRecip prjRecip - , activitySummary = Just summary - , activityAudience = Audience recips [] [] [] [] [] - , activitySpecific = AcceptActivity Accept - { acceptObject = - ObjURI - (objUriAuthority $ remoteAuthorURI author) - luCreate - , acceptResult = Nothing - } - } - update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return - ( obiidAccept - , doc - , makeRecipientSet localRecipsA localRecipsC - , [(objUriAuthority $ remoteAuthorURI author, remoteRecipsA)] - , objUriAuthority $ remoteAuthorURI author - ) - - insertTicket jid luTicket published ractidCreate obiidAccept = do + targetRelevance (Left (_, shr, prj)) + | shr == shrRecip && prj == prjRecip = Just () + targetRelevance _ = Nothing + insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do tid <- insert Ticket { ticketNumber = Nothing , ticketCreated = published - , ticketTitle = unTextHtml $ AP.ticketSummary ticket - , ticketSource = unTextPandocMarkdown $ AP.ticketSource ticket - , ticketDescription = unTextHtml $ AP.ticketContent ticket + , ticketTitle = unTextHtml summary + , ticketSource = unTextPandocMarkdown source + , ticketDescription = unTextHtml content , ticketAssignee = Nothing , ticketStatus = TSNew , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 @@ -678,6 +541,47 @@ projectCreateTicketF now shrRecip prjRecip author body mfwd luCreate ticket muTa delete tid return $ Left True Just _rtid -> return $ Right () + insertAccept shr prj author luCreate tlocal obiidAccept = do + encodeRouteLocal <- getEncodeRouteLocal + encodeRouteHome <- getEncodeRouteHome + + hLocal <- asksSite siteInstanceHost + + obikhidAccept <- encodeKeyHashid obiidAccept + + ra <- getJust $ remoteAuthorId author + + let ObjURI hAuthor luAuthor = remoteAuthorURI author + + audAuthorAndTicket = + AudRemote hAuthor [luAuthor] $ catMaybes + [ remoteActorFollowers ra + , Just $ AP.ticketParticipants tlocal + ] + audProject = + AudLocal [] + [ LocalPersonCollectionProjectTeam shr prj + , LocalPersonCollectionProjectFollowers shr prj + ] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audAuthorAndTicket, audProject] + + recips = map encodeRouteHome audLocal ++ audRemote + doc = Doc hLocal Activity + { activityId = + Just $ encodeRouteLocal $ + ProjectOutboxItemR shr prj obikhidAccept + , activityActor = encodeRouteLocal $ ProjectR shr prj + , activitySummary = Nothing + , activityAudience = Audience recips [] [] [] [] [] + , activitySpecific = AcceptActivity Accept + { acceptObject = ObjURI hAuthor luCreate + , acceptResult = Nothing + } + } + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) sharerOfferDepF :: UTCTime