S2S: projectCreateTicketF: Refactor to use new utils

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
+    (context, ticketData, published, title, desc, src) <- checkTicket ticket
-    (, ticketData, published) <$> checkTargetAndContext mtarget context
+    (, 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
+    checkTicket (AP.Ticket mlocal attrib mpublished mupdated muContext summary
-                           _content _source muAssigned resolved mmr) = do
+                           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
+    (targetAndContext, tlocal, published, title, desc, src) <- checkCreateTicket author ticket muTarget
-    case targetAndContext of
+    mmhttp <- for (targetRelevance targetAndContext) $ \ () -> lift $ runDB $ do
-        Left (_, shrContext, prjContext)
+        Entity jid j <- do
-            | shrRecip == shrContext && prjRecip == prjContext -> do
+            sid <- getKeyBy404 $ UniqueSharer shrRecip
-                msgOrRecips <- lift $ runDB $ do
+            getBy404 $ UniqueProject prjRecip sid
-                    (sidProject, jid, obidProject, ibidProject, fsidProject) <- getProject
+        mractid <- insertToInbox now author body (projectInbox j) luCreate False
-                    mractidCreate <- insertCreate luCreate ibidProject
+        for mractid $ \ ractid -> do
-                    case mractidCreate of
+            obiidAccept <- insertEmptyOutboxItem (projectOutbox j) now
-                        Nothing -> return $ Left "Already have this activity in project inbox, ignoring"
+            result <- insertTicket jid author (AP.ticketId tlocal) published title desc src ractid obiidAccept
-                        Just ractidCreate -> do
+            unless (isRight result) $ delete obiidAccept
-                            (obiidAccept, docAccept, localRecipsAccept, remoteRecipsAccept, fwdAccept) <- insertAccept obidProject luCreate tlocal
+            for result $ \ () -> do
-                            result <- insertTicket jid (AP.ticketId tlocal) published ractidCreate obiidAccept
+                mremotesHttpFwd <- for mfwd $ \ (localRecips, sig) -> do
-                            case result of
+                    let sieve =
-                                Left False -> do
+                            makeRecipientSet
-                                    delete obiidAccept
+                                []
-                                    return $ Left "Already have a ticket opened by this activity, ignoring"
+                                [ LocalPersonCollectionProjectTeam shrRecip prjRecip
-                                Left True -> do
+                                , LocalPersonCollectionProjectFollowers shrRecip prjRecip
-                                    delete obiidAccept
+                                ]
-                                    return $ Left "Already have this ticket, ignoring"
+                    remoteRecips <-
-                                Right () -> do
+                        insertRemoteActivityToLocalInboxes
-                                    hLocal <- getsYesod siteInstanceHost
+                            False ractid $
-                                    let colls = findRelevantCollections shrRecip prjRecip hLocal $ activityAudience $ actbActivity body
+                                localRecipSieve'
-                                    mremoteRecipsHttpCreateFwd <- for mfwd $ \ (_, sig) -> do
+                                    sieve False False localRecips
-                                        remoteRecips <- deliverFwdLocal ractidCreate colls sidProject fsidProject
+                    (sig,) <$> deliverRemoteDB_J (actbBL body) ractid jid sig remoteRecips
-                                        (sig,) <$> deliverRemoteDB_J (actbBL body) ractidCreate jid sig remoteRecips
+                (docAccept, localRecipsAccept, remoteRecipsAccept, fwdHostsAccept) <-
-                                    remoteRecipsHttpAccept <- do
+                    insertAccept shrRecip prjRecip author luCreate tlocal obiidAccept
-                                        moreRemoteRecipsAccept <- deliverLocal' False (LocalActorProject shrRecip prjRecip) ibidProject obiidAccept localRecipsAccept
+                knownRemoteRecipsAccept <-
-                                        deliverRemoteDB' fwdAccept obiidAccept remoteRecipsAccept moreRemoteRecipsAccept
+                    deliverLocal'
-                                    return $ Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept)
+                        False
-                case msgOrRecips of
+                        (LocalActorProject shrRecip prjRecip)
-                    Left msg -> return msg
+                        (projectInbox j)
-                    Right (mremoteRecipsHttpCreateFwd, remoteRecipsHttpAccept, obiidAccept, docAccept, fwdAccept) -> do
+                        obiidAccept
-                        for_ mremoteRecipsHttpCreateFwd $ \ (sig, recips) -> forkWorker "projectCreateTicketF inbox forwarding" $ deliverRemoteHTTP_J now shrRecip prjRecip (actbBL body) sig recips
+                        localRecipsAccept
-                        forkWorker "projectCreateTicketF deliver Accept" $ deliverRemoteHttp fwdAccept obiidAccept docAccept remoteRecipsHttpAccept
+                (mremotesHttpFwd,obiidAccept,docAccept,fwdHostsAccept,) <$>
-                        return "Accepting and listing new remote author hosted ticket"
+                    deliverRemoteDB'' fwdHostsAccept obiidAccept remoteRecipsAccept knownRemoteRecipsAccept
-        _ -> return "Create/Ticket against different project, ignoring"
+    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
+    targetRelevance (Left (_, shr, prj))
-        sid <- getKeyBy404 $ UniqueSharer shrRecip
+        | shr == shrRecip && prj == prjRecip = Just ()
-        Entity jid j <- getBy404 $ UniqueProject prjRecip sid
+    targetRelevance _ = Nothing
-        return (sid, jid, projectOutbox j, projectInbox j, projectFollowers j)
+    insertTicket jid author luTicket published summary content source ractidCreate obiidAccept = do
-
-    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|
-                        <p>
-                          <a href="#{renderObjURI uAuthor}">
-                            $maybe name <- remoteActorName ra
-                              #{name}
-                            $nothing
-                              #{renderAuthority hAuthor}#{localUriPath luAuthor}
-                          \'s ticket accepted and listed by project #
-                          <a href=@{ProjectR shrRecip prjRecip}>
-                            ./s/#{shr2text shrRecip}/p/#{prj2text prjRecip}
-                          \: #
-                          <a href="#{renderObjURI $ ObjURI hAuthor $ AP.ticketId tlocal}">
-                            #{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
         tid <- insert Ticket
             { ticketNumber      = Nothing
             , ticketCreated     = published
-            , ticketTitle       = unTextHtml $ AP.ticketSummary ticket
+            , ticketTitle       = unTextHtml summary
-            , ticketSource      = unTextPandocMarkdown $ AP.ticketSource ticket
+            , ticketSource      = unTextPandocMarkdown source
-            , ticketDescription = unTextHtml $ AP.ticketContent ticket
+            , 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