S2S: Refactor projectOfferTicketF to use the new utils

src/Vervis/Federation/Ticket.hs

@@ -238,108 +238,70 @@ projectOfferTicketF
     -> AP.Ticket URIMode
     -> FedURI
     -> ExceptT Text Handler Text
-projectOfferTicketF
+projectOfferTicketF now shrRecip prjRecip author body mfwd luOffer ticket uTarget = do
-    now shrRecip prjRecip author body mfwd luOffer ticket uTarget = do
+    (target, summary, content, source) <- checkOfferTicket author ticket uTarget
-        targetIsUs <- lift $ runExceptT checkTarget
+    mmhttp <- for (targetRelevance target) $ \ () -> lift $ runDB $ do
-        case targetIsUs of
+        Entity jid j <- do
-            Left t -> do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
-                logWarn $ T.concat
+            getBy404 $ UniqueProject prjRecip sid
-                    [ recip, " got Offer Ticket with target "
+        mractid <- insertToInbox now author body (projectInbox j) luOffer False
-                    , renderObjURI uTarget
+        for mractid $ \ ractid -> do
+            mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
+                let sieve =
+                        makeRecipientSet
+                            []
+                            [ LocalPersonCollectionProjectTeam shrRecip prjRecip
+                            , LocalPersonCollectionProjectFollowers shrRecip prjRecip
                             ]
-                return t
+                remoteRecips <-
-            Right () -> do
+                    insertRemoteActivityToLocalInboxes
-                hLocal <- getsYesod siteInstanceHost
+                        False ractid $
-                {-deps <- -}
+                            localRecipSieve'
-                checkOffer ticket hLocal shrRecip prjRecip
+                                sieve False False localRecips
-                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)
+            (obiidAccept, docAccept, fwdHostsAccept, recipsAccept) <- do
-                lift $ for_ mremotesHttp $ \ (msr, obiidAccept, docAccept) -> do
+                obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
-                    let handler e = logError $ "Project Accept sender: delivery failed! " <> T.pack (displayException e)
+                ltid <- insertTicket now author jid summary content source ractid obiidAccept
-                    for msr $ \ (sig, remotesHttp) -> do
+                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                        forkHandler handler $
+                    insertAccept shrRecip prjRecip author luOffer ltid obiidAccept
-                            deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig remotesHttp
+                knownRemoteRecipsAccept <-
-                    forkHandler handler $ publishAccept luOffer obiidAccept docAccept
+                    deliverLocal'
-                return $ recip <> " inserted new ticket"
+                        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]
+    targetRelevance (Left (shr, prj))
-    checkTarget = do
+        | shr == shrRecip && prj == prjRecip = Just ()
-        let ObjURI h lu = uTarget
+    targetRelevance _ = Nothing
-        local <- hostIsLocal h
+    insertTicket now author jid summary content source ractidOffer obiidAccept = do
-        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
-            }
-        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
+            , ticketTitle       = unTextHtml summary
-                    , ticketSource      =
+            , ticketSource      = unTextPandocMarkdown source
-                        unTextPandocMarkdown $ AP.ticketSource ticket
+            , ticketDescription = unTextHtml content
-                    , ticketDescription = unTextHtml $ AP.ticketContent ticket
             , ticketAssignee    = Nothing
             , ticketStatus      = TSNew
             , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
@@ -360,96 +322,50 @@ projectOfferTicketF
             }
         insert_ TicketAuthorRemote
             { ticketAuthorRemoteTicket = tclid
-                    , ticketAuthorRemoteAuthor = raidAuthor
+            , ticketAuthorRemoteAuthor = remoteAuthorId author
-                    , ticketAuthorRemoteOpen   = ractid
+            , ticketAuthorRemoteOpen   = ractidOffer
             }
-                docAccept <- insertAccept ra luOffer ltid obiidAccept
+        return ltid
-                -- insertMany_ $ map (TicketDependency tid) deps
+    insertAccept shr prj author luOffer ltid obiidAccept = do
-                --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|
-                        <p>
-                          <a href="#{renderObjURI uAuthor}">
-                            $maybe name <- remoteActorName ra
-                              #{name}
-                            $nothing
-                              #{renderAuthority hAuthor}#{localUriPath luAuthor}
-                          \'s ticket accepted by project #
-                          <a href=@{ProjectR shrRecip prjRecip}>
-                            ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
-                          \: #
-                          <a href=@{ProjectTicketR shrRecip prjRecip ltkhid}>
-                            #{preEscapedToHtml $ unTextHtml $ AP.ticketSummary ticket}.
-                    |]
-        hLocal <- asksSite siteInstanceHost
         encodeRouteLocal <- getEncodeRouteLocal
         encodeRouteHome <- getEncodeRouteHome
-        obikhid <- encodeKeyHashid obiid
+
-        let recips =
+        hLocal <- asksSite siteInstanceHost
-                remoteAuthorURI author :
+
-                map encodeRouteHome
+        obikhidAccept <- encodeKeyHashid obiidAccept
-                    [ ProjectTeamR shrRecip prjRecip
+        ltkhid <- encodeKeyHashid ltid
-                    , ProjectFollowersR shrRecip prjRecip
+
+        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
+                        ProjectOutboxItemR shr prj obikhidAccept
-                , activityActor    =
+                , activityActor    = encodeRouteLocal $ ProjectR shr prj
-                    encodeRouteLocal $ ProjectR shrRecip prjRecip
+                , activitySummary  = Nothing
-                , activitySummary  = Just summary
                 , activityAudience = Audience recips [] [] [] [] []
                 , activitySpecific = AcceptActivity Accept
-                    { acceptObject =
+                    { acceptObject = ObjURI hAuthor luOffer
-                        ObjURI
-                            (objUriAuthority $ remoteAuthorURI author)
-                            luOffer
                     , acceptResult =
-                        Just $ encodeRouteLocal $
+                        Just $ encodeRouteLocal $ ProjectTicketR shr prj ltkhid
-                            ProjectTicketR shrRecip prjRecip ltkhid
                     }
                 }
-        update obiid [OutboxItemActivity =. persistJSONObjectFromDoc doc]
+        update obiidAccept [OutboxItemActivity =. persistJSONObjectFromDoc doc]
-        return doc
+        return (doc, recipientSet, remoteActors, fwdHosts)
-
-    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
 
 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 [] [] [] [] []