From 1a8ecb5995647c71d515abdfb5d759b80da21b9f Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Wed, 15 Jul 2020 09:58:59 +0000 Subject: [PATCH] S2S: Refactor projectOfferTicketF to use the new utils --- src/Vervis/Federation/Ticket.hs | 318 ++++++++++++-------------------- 1 file changed, 117 insertions(+), 201 deletions(-) diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 31d9532..a168a59 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/src/Vervis/Federation/Ticket.hs @@ -238,218 +238,134 @@ projectOfferTicketF -> AP.Ticket URIMode -> FedURI -> ExceptT Text Handler Text -projectOfferTicketF - now shrRecip prjRecip author body mfwd luOffer ticket uTarget = do - targetIsUs <- lift $ runExceptT checkTarget - case targetIsUs of - Left t -> do - logWarn $ T.concat - [ recip, " got Offer Ticket with target " - , renderObjURI uTarget - ] - return t - Right () -> do - hLocal <- getsYesod siteInstanceHost - {-deps <- -} - checkOffer ticket hLocal shrRecip prjRecip - let colls = - findRelevantCollections shrRecip prjRecip hLocal $ - activityAudience $ actbActivity body - mremotesHttp <- runDBExcept $ do - (sid, jid, ibid, fsid{-, tids-}) <- - getProjectAndDeps shrRecip prjRecip {-deps-} - lift $ do - mticket <- do - ra <- getJust $ remoteAuthorId author - insertTicket ra luOffer jid ibid {-tids-} - for mticket $ \ (ractid, obiidAccept, docAccept) -> do - msr <- for mfwd $ \ (_, sig) -> do - remoteRecips <- deliverFwdLocal ractid colls sid fsid - (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips - return (msr, obiidAccept, docAccept) - lift $ for_ mremotesHttp $ \ (msr, obiidAccept, docAccept) -> do - let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e) - for msr $ \ (sig, remotesHttp) -> do - forkHandler handler $ - deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp - forkHandler handler $ publishAccept luOffer obiidAccept docAccept - return $ recip <> " inserted new ticket" +projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarget = do + (target, summary, content, source) <- checkOfferTicket author ticket uTarget + mmhttp <- for (targetRelevance target) $ \ () -> lift $ runDB $ do + Entity jid j <- do + sid <- getKeyBy404 $ UniqueSharer shrRecip + getBy404 $ UniqueProject prjRecip sid + mractid <- insertToInbox now author body (projectInbox j) luOffer False + for mractid $ \ ractid -> 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 + (obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do + obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now + ltid <- insertTicket now author jid summary content source ractid obiidAccept + (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <- + insertAccept shrRecip prjRecip author luOffer ltid obiidAccept + knownRemoteRecipsAccept <- + deliverLocal' + False + (LocalActorProject shrRecip prjRecip) + (projectInbox j) + obiidAccept + localRecipsAccept + (obiidAccept,docAccept,fwdHostsAccept,) <$> + deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept + return (mremotesHttpFwd, obiidAccept, docAccept, fwdHostsAccept, recipsAccept) + case mmhttp of + Nothing -> return "Offer target isn't me, not using" + Just mhttp -> + case mhttp of + Nothing -> return "Activity already in my inbox, doing nothing" + Just (mremotesHttpFwd, obiid, doc, fwdHosts, remotes) -> do + for_ mremotesHttpFwd $ \ (sig, remotes) -> + forkWorker "projectOfferTicketF inbox-forwarding" $ + deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotes + forkWorker "projectOfferTicketF Accept HTTP delivery" $ + deliverRemoteHttp' fwdHosts obiid doc remotes + return $ + case mremotesHttpFwd of + Nothing -> "Accepted new ticket, no inbox-forwarding to do" + Just _ -> "Accepted new ticket and ran inbox-forwarding of the Offer" where - recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip] - checkTarget = do - let ObjURI h lu = uTarget - local <- hostIsLocal h - unless local $ - throwE $ recip <> " not using; target has different host" - route <- - case decodeRouteLocal lu of - Nothing -> - throwE $ - recip <> " not using; local target isn't a valid route" - Just r -> return r - (shrTarget, prjTarget) <- - case route of - ProjectR shr prj -> return (shr, prj) - _ -> throwE $ - recip <> - " not using; local target isn't a project route" - unless (shrTarget == shrRecip && prjTarget == prjRecip) $ - throwE $ recip <> " not using; local target is a different project" - insertTicket ra luOffer jid ibid {-deps-} = do - let iidAuthor = remoteAuthorInstance author - roid <- - either entityKey id <$> insertBy' (RemoteObject iidAuthor luOffer) - let raidAuthor = remoteAuthorId author - ractid <- either entityKey id <$> insertBy' RemoteActivity - { remoteActivityIdent = roid - , remoteActivityContent = persistJSONFromBL $ actbBL body - , remoteActivityReceived = now + targetRelevance (Left (shr, prj)) + | shr == shrRecip && prj == prjRecip = Just () + targetRelevance _ = Nothing + insertTicket now author jid summary content source ractidOffer obiidAccept = do + did <- insert Discussion + fsid <- insert FollowerSet + tid <- insert Ticket + { ticketNumber = Nothing + , ticketCreated = now + , ticketTitle = unTextHtml summary + , ticketSource = unTextPandocMarkdown source + , ticketDescription = unTextHtml content + , ticketAssignee = Nothing + , ticketStatus = TSNew + , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 + , ticketCloser = Nothing } - ibiid <- insert $ InboxItem False - mibirid <- insertUnique $ InboxItemRemote ibid ractid ibiid - case mibirid of - Nothing -> do - delete ibiid - return Nothing - Just _ibirid -> do - {- - next <- - ((subtract 1) . projectNextTicket) <$> - updateGet jid [ProjectNextTicket +=. 1] - -} - did <- insert Discussion - fsid <- insert FollowerSet - - obiidAccept <- do - obidProject <- do - sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip) - j <- fromJust <$> getValBy (UniqueProject prjRecip sid) - return $ projectOutbox j - hLocal <- asksSite siteInstanceHost - now <- liftIO getCurrentTime - insert OutboxItem - { outboxItemOutbox = obidProject - , outboxItemActivity = persistJSONObjectFromDoc $ Doc hLocal emptyActivity - , outboxItemPublished = now - } - - tid <- insert Ticket - { ticketNumber = Nothing - , ticketCreated = now - , ticketTitle = unTextHtml $ AP.ticketSummary ticket - , ticketSource = - unTextPandocMarkdown $ AP.ticketSource ticket - , ticketDescription = unTextHtml $ AP.ticketContent ticket - , ticketAssignee = Nothing - , ticketStatus = TSNew - , ticketClosed = UTCTime (ModifiedJulianDay 0) 0 - , ticketCloser = Nothing - } - ltid <- insert LocalTicket - { localTicketTicket = tid - , localTicketDiscuss = did - , localTicketFollowers = fsid - } - tclid <- insert TicketContextLocal - { ticketContextLocalTicket = tid - , ticketContextLocalAccept = obiidAccept - } - insert_ TicketProjectLocal - { ticketProjectLocalContext = tclid - , ticketProjectLocalProject = jid - } - insert_ TicketAuthorRemote - { ticketAuthorRemoteTicket = tclid - , ticketAuthorRemoteAuthor = raidAuthor - , ticketAuthorRemoteOpen = ractid - } - docAccept <- insertAccept ra luOffer ltid obiidAccept - -- insertMany_ $ map (TicketDependency tid) deps - --insert_ $ RemoteFollow raidAuthor fsid False True - return $ Just (ractid, obiidAccept, docAccept) - - insertAccept ra luOffer ltid obiid = do - let uAuthor@(ObjURI hAuthor luAuthor) = remoteAuthorURI author - ltkhid <- encodeKeyHashid ltid - summary <- - TextHtml . TL.toStrict . renderHtml <$> - withUrlRenderer - [hamlet| -

- - $maybe name <- remoteActorName ra - #{name} - $nothing - #{renderAuthority hAuthor}#{localUriPath luAuthor} - \'s ticket accepted by project # - - ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip} - \: # - - #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}. - |] - hLocal <- asksSite siteInstanceHost + ltid <- insert LocalTicket + { localTicketTicket = tid + , localTicketDiscuss = did + , localTicketFollowers = fsid + } + tclid <- insert TicketContextLocal + { ticketContextLocalTicket = tid + , ticketContextLocalAccept = obiidAccept + } + insert_ TicketProjectLocal + { ticketProjectLocalContext = tclid + , ticketProjectLocalProject = jid + } + insert_ TicketAuthorRemote + { ticketAuthorRemoteTicket = tclid + , ticketAuthorRemoteAuthor = remoteAuthorId author + , ticketAuthorRemoteOpen = ractidOffer + } + return ltid + insertAccept shr prj author luOffer ltid obiidAccept = do encodeRouteLocal <- getEncodeRouteLocal encodeRouteHome <- getEncodeRouteHome - obikhid <- encodeKeyHashid obiid - let recips = - remoteAuthorURI author : - map encodeRouteHome - [ ProjectTeamR shrRecip prjRecip - , ProjectFollowersR shrRecip prjRecip + + 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) + audProject = + AudLocal [] + [ LocalPersonCollectionProjectTeam shr prj + , LocalPersonCollectionProjectFollowers shr prj ] + + (recipientSet, remoteActors, fwdHosts, audLocal, audRemote) = + collectAudience [audAuthor, audProject] + + recips = map encodeRouteHome audLocal ++ audRemote doc = Doc hLocal Activity { activityId = Just $ encodeRouteLocal $ - ProjectOutboxItemR shrRecip prjRecip obikhid - , activityActor = - encodeRouteLocal $ ProjectR shrRecip prjRecip - , activitySummary = Just summary + ProjectOutboxItemR shr prj obikhidAccept + , activityActor = encodeRouteLocal $ ProjectR shr prj + , activitySummary = Nothing , activityAudience = Audience recips [] [] [] [] [] , activitySpecific = AcceptActivity Accept - { acceptObject = - ObjURI - (objUriAuthority $ remoteAuthorURI author) - luOffer + { acceptObject = ObjURI hAuthor luOffer , acceptResult = - Just $ encodeRouteLocal $ - ProjectTicketR shrRecip prjRecip ltkhid + Just $ encodeRouteLocal $ ProjectTicketR shr prj ltkhid } } - update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc] - return doc - - publishAccept luOffer obiid doc = do - now <- liftIO getCurrentTime - let dont = Authority "dont-do.any-forwarding" Nothing - remotesHttp <- runDB $ do - (sid, project) <- do - sid <- fromJust <$> getKeyBy (UniqueSharer shrRecip) - j <- fromJust <$> getValBy (UniqueProject prjRecip sid) - return (sid, j) - moreRemotes <- deliverLocal now sid (projectFollowers project) obiid - let raidAuthor = remoteAuthorId author - ra <- getJust raidAuthor - ro <- getJust $ remoteActorIdent ra - let raInfo = RemoteRecipient raidAuthor (remoteObjectIdent ro) (remoteActorInbox ra) (remoteActorErrorSince ra) - iidAuthor = remoteAuthorInstance author - hAuthor = objUriAuthority $ remoteAuthorURI author - hostSection = ((iidAuthor, hAuthor), raInfo :| []) - remotes = unionRemotes [hostSection] moreRemotes - deliverRemoteDB' dont obiid [] remotes - site <- askSite - liftIO $ runWorker (deliverRemoteHttp dont obiid doc remotesHttp) site - where - deliverLocal now sid fsid obiid = do - (pidsTeam, remotesTeam) <- getProjectTeam sid - (pidsFollowers, remotesFollowers) <- getFollowers fsid - let pids = LO.union pidsTeam pidsFollowers - remotes = unionRemotes remotesTeam remotesFollowers - for_ pids $ \ pid -> do - ibid <- personInbox <$> getJust pid - ibiid <- insert $ InboxItem True - insert_ $ InboxItemLocal ibid obiid ibiid - return remotes + update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc] + return (doc, recipientSet, remoteActors, fwdHosts) checkCreateTicket :: RemoteAuthor @@ -1159,7 +1075,7 @@ projectOfferDepF now shrRecip prjRecip author body mfwd luOffer dep uTarget = do doc = Doc hLocal Activity { activityId = Just $ encodeRouteLocal $ - SharerOutboxItemR shrRecip obikhidAccept + ProjectOutboxItemR shrRecip prjRecip obikhidAccept , activityActor = encodeRouteLocal $ ProjectR shrRecip prjRecip , activitySummary = Nothing , activityAudience = Audience recips [] [] [] [] [] @@ -1320,7 +1236,7 @@ repoOfferDepF now shrRecip rpRecip author body mfwd luOffer dep uTarget = do doc = Doc hLocal Activity { activityId = Just $ encodeRouteLocal $ - SharerOutboxItemR shrRecip obikhidAccept + RepoOutboxItemR shrRecip rpRecip obikhidAccept , activityActor = encodeRouteLocal $ RepoR shrRecip rpRecip , activitySummary = Nothing , activityAudience = Audience recips [] [] [] [] []