Handle Offer{Ticket} in project inbox, and turn DB ticketTitle into HTML

config/models

@@ -295,7 +295,7 @@ Ticket
     project     ProjectId
     number      Int
     created     UTCTime
-    title       Text
+    title       Text                -- HTML
     source      Text                -- Pandoc Markdown
     description Text                -- HTML
     assignee    PersonId      Maybe

src/Vervis/ActivityPub.hs

@@ -30,33 +30,50 @@ module Vervis.ActivityPub
     , isInstanceErrorP
     , isInstanceErrorG
     , deliverHttp
+    , deliverRemoteDB
+    , deliverRemoteHTTP
+    , checkForward
     )
 where
 
-import Control.Exception hiding (try)
+import Control.Exception hiding (Handler, try)
 import Control.Monad
 import Control.Monad.IO.Class
 import Control.Monad.IO.Unlift
+import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Control.Monad.Trans.Reader
 import Data.Bifunctor
+import Data.ByteString (ByteString)
+import Data.Foldable
 import Data.Function
-import Data.List.NonEmpty (NonEmpty, nonEmpty)
+import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
+import Data.Maybe
 import Data.Semigroup
 import Data.Text (Text)
+import Data.Text.Encoding
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
 import Database.Persist.Sql
 import Network.HTTP.Client
 import Network.TLS -- hiding (SHA256)
 import UnliftIO.Exception (try)
+import Yesod.Core.Handler
+import Yesod.Persist.Core
 
+import qualified Data.ByteString.Lazy as BL
+import qualified Data.CaseInsensitive as CI
 import qualified Data.List.NonEmpty as NE
 import qualified Data.List.Ordered as LO
+import qualified Data.Text as T
 import qualified Database.Esqueleto as E
 
+import Yesod.HttpSignature
+
 import Network.FedURI
+import Network.HTTP.Digest
 import Web.ActivityPub
 import Yesod.ActivityPub
 import Yesod.MonadSite
@@ -66,6 +83,7 @@ import Yesod.Hashids
 import Control.Monad.Trans.Except.Local
 import Data.Either.Local
 import Data.List.NonEmpty.Local
+import Data.Tuple.Local
 import Database.Persist.Local
 
 import Vervis.Foundation
@@ -247,3 +265,99 @@ deliverHttp
     -> m (Either APPostError (Response ()))
 deliverHttp doc mfwd h luInbox =
     deliverActivity (l2f h luInbox) (l2f h <$> mfwd) doc
+
+deliverRemoteDB
+    :: BL.ByteString
+    -> RemoteActivityId
+    -> ProjectId
+    -> ByteString
+    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    -> AppDB
+        [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+deliverRemoteDB body ractid jid sig recips = do
+    let body' = BL.toStrict body
+        deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
+    fetchedDeliv <- for recips $ \ (i, rs) ->
+        (i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
+    return $ takeNoError4 fetchedDeliv
+    where
+    takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
+    takeNoError4 = takeNoError noError
+        where
+        noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
+        noError ((_ , _  , _  , Just _ ), _  ) = Nothing
+
+deliverRemoteHTTP
+    :: UTCTime
+    -> ShrIdent
+    -> PrjIdent
+    -> BL.ByteString
+    -> ByteString
+    -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
+    -> Handler ()
+deliverRemoteHTTP now shrRecip prjRecip body sig fetched = do
+    let deliver h inbox =
+            let sender = ProjectR shrRecip prjRecip
+            in  forwardActivity (l2f h inbox) sig sender body
+    traverse_ (fork . deliverFetched deliver now) fetched
+    where
+    fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
+    deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
+        let (raid, _luActor, luInbox, fwid) = r
+        e <- deliver h luInbox
+        let e' = case e of
+                    Left err ->
+                        if isInstanceErrorP err
+                            then Nothing
+                            else Just False
+                    Right _resp -> Just True
+        case e' of
+            Nothing -> runDB $ do
+                let recips' = NE.toList recips
+                updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
+            Just success -> do
+                runDB $
+                    if success
+                        then delete fwid
+                        else do
+                            updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                            update fwid [ForwardingRunning =. False]
+                for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
+                    fork $ do
+                        e <- deliver h luInbox
+                        runDB $
+                            case e of
+                                Left _err -> do
+                                    updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
+                                    update fwid [ForwardingRunning =. False]
+                                Right _resp -> delete fwid
+
+checkForward shrRecip prjRecip = join <$> do
+    let hSig = hForwardingSignature
+    msig <- maybeHeader hSig
+    for msig $ \ sig -> do
+        _proof <- withExceptT (T.pack . displayException) $ ExceptT $
+            let requires = [hDigest, hActivityPubForwarder]
+            in  prepareToVerifyHttpSigWith hSig False requires [] Nothing
+        forwarder <- requireHeader hActivityPubForwarder
+        renderUrl <- getUrlRender
+        let project = renderUrl $ ProjectR shrRecip prjRecip
+        return $
+            if forwarder == encodeUtf8 project
+                then Just sig
+                else Nothing
+    where
+    maybeHeader n = do
+        let n' = decodeUtf8 $ CI.original n
+        hs <- lookupHeaders n
+        case hs of
+            [] -> return Nothing
+            [h] -> return $ Just h
+            _ -> throwE $ n' <> " multiple headers found"
+    requireHeader n = do
+        let n' = decodeUtf8 $ CI.original n
+        mh <- maybeHeader n
+        case mh of
+            Nothing -> throwE $ n' <> " header not found"
+            Just h -> return h

src/Vervis/Federation.hs

@@ -237,6 +237,8 @@ handleProjectInbox now shrRecip prjRecip auth body = do
     case activitySpecific $ actbActivity body of
         CreateActivity (Create note) ->
             projectCreateNoteF now shrRecip prjRecip remoteAuthor body note
+        OfferActivity offer ->
+            projectOfferTicketF now shrRecip prjRecip remoteAuthor body offer
         _ -> return "Unsupported activity type"
 
 fixRunningDeliveries :: (MonadIO m, MonadLogger m, IsSqlBackend backend) => ReaderT backend m ()

src/Vervis/Federation/Discussion.hs

@@ -216,7 +216,7 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
             if shr /= shrRecip || prj /= prjRecip
                 then return $ recip <> " not using; context is a different project"
                 else do
-                    msig <- checkForward
+                    msig <- checkForward shrRecip prjRecip
                     hLocal <- getsYesod $ appInstanceHost . appSettings
                     let colls =
                             findRelevantCollections hLocal num $
@@ -229,40 +229,13 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
                                 updateOrphans luNote did mid
                                 for msig $ \ sig -> do
                                     remoteRecips <- deliverLocal ractid colls sid fsidProject fsidTicket
-                                    (sig,) <$> deliverRemoteDB ractid jid sig remoteRecips
+                                    (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
                     lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
                         let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
-                        forkHandler handler $ deliverRemoteHttp sig remotesHttp
+                        forkHandler handler $
+                            deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
                     return $ recip <> " inserted new ticket comment"
     where
-    checkForward = join <$> do
-        let hSig = hForwardingSignature
-        msig <- maybeHeader hSig
-        for msig $ \ sig -> do
-            _proof <- withExceptT (T.pack . displayException) $ ExceptT $
-                let requires = [hDigest, hActivityPubForwarder]
-                in  prepareToVerifyHttpSigWith hSig False requires [] Nothing
-            forwarder <- requireHeader hActivityPubForwarder
-            renderUrl <- getUrlRender
-            let project = renderUrl $ ProjectR shrRecip prjRecip
-            return $
-                if forwarder == encodeUtf8 project
-                    then Just sig
-                    else Nothing
-        where
-        maybeHeader n = do
-            let n' = decodeUtf8 $ CI.original n
-            hs <- lookupHeaders n
-            case hs of
-                [] -> return Nothing
-                [h] -> return $ Just h
-                _ -> throwE $ n' <> " multiple headers found"
-        requireHeader n = do
-            let n' = decodeUtf8 $ CI.original n
-            mh <- maybeHeader n
-            case mh of
-                Nothing -> throwE $ n' <> " header not found"
-                Just h -> return h
     findRelevantCollections hLocal numCtx = nub . mapMaybe decide . concatRecipients
         where
         decide u = do
@@ -404,66 +377,3 @@ projectCreateNoteF now shrRecip prjRecip author body (Note mluNote _ _ muParent
             when (isNothing mibrid) $
                 delete ibiid
         return remotes
-
-    deliverRemoteDB
-        :: RemoteActivityId
-        -> ProjectId
-        -> ByteString
-        -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
-        -> AppDB
-            [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
-    deliverRemoteDB ractid jid sig recips = do
-        let body' = BL.toStrict $ actbBL body
-            deliv raid msince = Forwarding raid ractid body' jid sig $ isNothing msince
-        fetchedDeliv <- for recips $ \ (i, rs) ->
-            (i,) <$> insertMany' (\ (raid, _, _, msince) -> deliv raid msince) rs
-        return $ takeNoError4 fetchedDeliv
-        where
-        takeNoError noError = mapMaybe $ \ (i, rs) -> (i,) <$> nonEmpty (mapMaybe noError $ NE.toList rs)
-        takeNoError4 = takeNoError noError
-            where
-            noError ((ak, luA, luI, Nothing), dlk) = Just (ak, luA, luI, dlk)
-            noError ((_ , _  , _  , Just _ ), _  ) = Nothing
-
-    deliverRemoteHttp
-        :: ByteString
-        -> [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, ForwardingId))]
-        -> Handler ()
-    deliverRemoteHttp sig fetched = do
-        let deliver h inbox =
-                let sender = ProjectR shrRecip prjRecip
-                in  forwardActivity (l2f h inbox) sig sender (actbBL body)
-        now <- liftIO getCurrentTime
-        traverse_ (fork . deliverFetched deliver now) fetched
-        where
-        fork = forkHandler $ \ e -> logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
-        deliverFetched deliver now ((_, h), recips@(r :| rs)) = do
-            let (raid, _luActor, luInbox, fwid) = r
-            e <- deliver h luInbox
-            let e' = case e of
-                        Left err ->
-                            if isInstanceErrorP err
-                                then Nothing
-                                else Just False
-                        Right _resp -> Just True
-            case e' of
-                Nothing -> runDB $ do
-                    let recips' = NE.toList recips
-                    updateWhere [RemoteActorId <-. map fst4 recips', RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
-                    updateWhere [ForwardingId <-. map fourth4 recips'] [ForwardingRunning =. False]
-                Just success -> do
-                    runDB $
-                        if success
-                            then delete fwid
-                            else do
-                                updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
-                                update fwid [ForwardingRunning =. False]
-                    for_ rs $ \ (raid, _luActor, luInbox, fwid) ->
-                        fork $ do
-                            e <- deliver h luInbox
-                            runDB $
-                                case e of
-                                    Left _err -> do
-                                        updateWhere [RemoteActorId ==. raid, RemoteActorErrorSince ==. Nothing] [RemoteActorErrorSince =. Just now]
-                                        update fwid [ForwardingRunning =. False]
-                                    Right _resp -> delete fwid

src/Vervis/Federation/Ticket.hs

@@ -15,26 +15,42 @@
 
 module Vervis.Federation.Ticket
     ( sharerOfferTicketF
+    , projectOfferTicketF
     )
 where
 
+import Control.Exception hiding (Handler)
 import Control.Monad
+import Control.Monad.Logger.CallStack
 import Control.Monad.Trans.Class
 import Control.Monad.Trans.Except
 import Data.Aeson
+import Data.Bifunctor
 import Data.Foldable
+import Data.Function
+import Data.List (nub, union)
+import Data.List.NonEmpty (NonEmpty)
 import Data.Maybe
 import Data.Text (Text)
+import Data.Time.Calendar
 import Data.Time.Clock
+import Data.Traversable
 import Database.Persist
+import Yesod.Core.Handler
 import Yesod.Persist.Core
 
 import Database.Persist.JSON
 import Network.FedURI
-import Web.ActivityPub
+import Web.ActivityPub hiding (Ticket (..))
+import Yesod.ActivityPub
 import Yesod.FedURI
 
+import qualified Data.List.NonEmpty as NE
+import qualified Data.Text as T
+import qualified Web.ActivityPub as AP
+
 import Control.Monad.Trans.Except.Local
+import Data.Tuple.Local
 import Database.Persist.Local
 import Yesod.Persist.Local
 
@@ -43,6 +59,39 @@ import Vervis.Federation.Auth
 import Vervis.Foundation
 import Vervis.Model
 import Vervis.Model.Ident
+import Vervis.Model.Ticket
+
+checkOffer
+    :: AP.Ticket -> Text -> ShrIdent -> PrjIdent -> ExceptT Text Handler [Int]
+checkOffer ticket hProject shrProject prjProject = do
+    verifyNothingE (AP.ticketLocal ticket) "Ticket with 'id'"
+    _published <-
+        fromMaybeE (AP.ticketPublished ticket) "Ticket without '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"
+    unless (null $ AP.ticketDependedBy ticket) $ throwE "Ticket has rdeps"
+    traverse checkDep $ AP.ticketDependsOn ticket
+    where
+    checkDep u = do
+        let (h, lu) = f2l u
+        unless (h == hProject) $
+            throwE "Dep belongs to different host"
+        (shrTicket, prjTicket, num) <- parseTicket lu
+        unless (shrTicket == shrProject) $
+            throwE "Dep belongs to different sharer under same host"
+        unless (prjTicket == prjProject) $
+            throwE "Dep belongs to different project under same sharer"
+        return num
+        where
+        parseTicket lu = do
+            route <- case decodeRouteLocal lu of
+                Nothing -> throwE "Expected ticket route, got invalid route"
+                Just r -> return r
+            case route of
+                TicketR shr prj num -> return (shr, prj, num)
+                _ -> throwE "Expected ticket route, got non-ticket route"
 
 sharerOfferTicketF
     :: UTCTime
@@ -52,16 +101,8 @@ sharerOfferTicketF
     -> Offer
     -> ExceptT Text Handler Text
 sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
-    verifyNothingE (ticketLocal ticket) "Ticket with 'id'"
-    _published <-
-        fromMaybeE (ticketPublished ticket) "Ticket without 'published'"
-    verifyNothingE (ticketName ticket) "Ticket with 'name'"
-    verifyNothingE (ticketAssignedTo ticket) "Ticket with 'assignedTo'"
-    when (ticketIsResolved ticket) $ throwE "Ticket resolved"
     (hProject, shrProject, prjProject) <- parseTarget uTarget
-    unless (null $ ticketDependedBy ticket) $ throwE "Ticket has rdeps"
+    deps <- checkOffer ticket hProject shrProject prjProject
-    let checkDep' = checkDep hProject shrProject prjProject
-    deps <- traverse checkDep' $ ticketDependsOn ticket
     local <- hostIsLocal hProject
     runDBExcept $ do
         ibidRecip <- lift $ do
@@ -83,24 +124,6 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
             case route of
                 ProjectR shr prj -> return (shr, prj)
                 _ -> throwE "Expected project route, got non-project route"
-    checkDep hProject shrProject prjProject u = do
-        let (h, lu) = f2l u
-        unless (h == hProject) $
-            throwE "Dep belongs to different host"
-        (shrTicket, prjTicket, num) <- parseTicket lu
-        unless (shrTicket == shrProject) $
-            throwE "Dep belongs to different sharer under same host"
-        unless (prjTicket == prjProject) $
-            throwE "Dep belongs to different project under same sharer"
-        return num
-        where
-        parseTicket lu = do
-            route <- case decodeRouteLocal lu of
-                Nothing -> throwE "Expected ticket route, got invalid route"
-                Just r -> return r
-            case route of
-                TicketR shr prj num -> return (shr, prj, num)
-                _ -> throwE "Expected ticket route, got non-ticket route"
     checkTargetAndDeps shrProject prjProject deps = do
         msid <- lift $ getKeyBy $ UniqueSharer shrProject
         sid <- fromMaybeE msid "Offer target: no such local sharer"
@@ -124,3 +147,161 @@ sharerOfferTicketF now shrRecip author body (Offer ticket uTarget) = do
                 delete ibiid
                 return $ "Activity already exists in inbox of /s/" <> recip
             Just _ -> return $ "Activity inserted to inbox of /s/" <> recip
+
+data OfferTicketRecipColl
+    = OfferTicketRecipProjectFollowers
+    | OfferTicketRecipProjectTeam
+    deriving Eq
+
+projectOfferTicketF
+    :: UTCTime
+    -> ShrIdent
+    -> PrjIdent
+    -> RemoteAuthor
+    -> ActivityBody
+    -> Offer
+    -> ExceptT Text Handler Text
+projectOfferTicketF
+    now shrRecip prjRecip author body (Offer ticket uTarget) = do
+        targetIsUs <- lift $ runExceptT checkTarget
+        case targetIsUs of
+            Left t -> do
+                logWarn $ T.concat
+                    [ recip, " got Offer Ticket with target "
+                    , renderFedURI uTarget
+                    ]
+                return t
+            Right () -> do
+                hLocal <- getsYesod siteInstanceHost
+                deps <- checkOffer ticket hLocal shrRecip prjRecip
+                msig <- checkForward shrRecip prjRecip
+                let colls =
+                        findRelevantCollections hLocal $
+                            activityAudience $ actbActivity body
+                mremotesHttp <- runDBExcept $ do
+                    (sid, jid, ibid, fsid, next, tids) <-
+                        getProjectAndDeps deps
+                    lift $ join <$> do
+                        mractid <- insertTicket jid ibid next tids
+                        for mractid $ \ ractid -> for msig $ \ sig -> do
+                            remoteRecips <- deliverLocal ractid colls sid fsid
+                            (sig,) <$> deliverRemoteDB (actbBL body) ractid jid sig remoteRecips
+                lift $ for_ mremotesHttp $ \ (sig, remotesHttp) -> do
+                    let handler e = logError $ "Project inbox handler: delivery failed! " <> T.pack (displayException e)
+                    forkHandler handler $
+                        deliverRemoteHTTP now shrRecip prjRecip (actbBL body) sig remotesHttp
+                return $ recip <> " inserted new ticket"
+    where
+    recip = T.concat ["/s/", shr2text shrRecip, "/p/", prj2text prjRecip]
+    checkTarget = do
+        let (h, lu) = f2l 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"
+    findRelevantCollections hLocal = nub . mapMaybe decide . concatRecipients
+        where
+        decide u = do
+            let (h, lu) = f2l 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
+    getProjectAndDeps deps = do
+        msid <- lift $ getKeyBy $ UniqueSharer shrRecip
+        sid <- fromMaybeE msid "Offer target: no such local sharer"
+        mej <- lift $ getBy $ UniqueProject prjRecip sid
+        Entity jid j <- fromMaybeE mej "Offer target: no such local project"
+        tids <- for deps $ \ dep -> do
+            mtid <- lift $ getKeyBy $ UniqueTicket jid dep
+            fromMaybeE mtid "Local dep: No such ticket number in DB"
+        return
+            ( sid, jid, projectInbox j, projectFollowers j, projectNextTicket j
+            , tids
+            )
+    insertTicket jid ibid next deps = do
+        let iidAuthor = remoteAuthorInstance author
+            raidAuthor = remoteAuthorId author
+        ractid <- either entityKey id <$> insertBy' RemoteActivity
+            { remoteActivityInstance = iidAuthor
+            , remoteActivityIdent    = activityId $ actbActivity body
+            , remoteActivityContent  = PersistJSON $ actbObject 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
+                update jid [ProjectNextTicket +=. 1]
+                did <- insert Discussion
+                fsid <- insert FollowerSet
+                tid <- insert Ticket
+                    { ticketProject     = jid
+                    , ticketNumber      = next
+                    , 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
+                    , ticketDiscuss     = did
+                    , ticketFollowers   = fsid
+                    }
+                insert_ TicketAuthorRemote
+                    { ticketAuthorRemoteTicket = tid
+                    , ticketAuthorRemoteAuthor = raidAuthor
+                    , ticketAuthorRemoteOffer  = ractid
+                    }
+                insertMany_ $ map (TicketDependency tid) deps
+                return $ Just ractid
+
+    deliverLocal
+        :: RemoteActivityId
+        -> [OfferTicketRecipColl]
+        -> SharerId
+        -> FollowerSetId
+        -> AppDB [((InstanceId, Text), NonEmpty (RemoteActorId, LocalURI, LocalURI, Maybe UTCTime))]
+    deliverLocal 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
+            -- TODO inefficient, see the other TODOs about mergeConcat
+            remotes = map (second $ NE.nubBy ((==) `on` fst4)) $ mergeConcat 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

src/Vervis/Form/Ticket.hs

@@ -32,6 +32,7 @@ import Data.Text (Text)
 import Data.Time.Calendar (Day (..))
 import Data.Time.Clock (getCurrentTime, UTCTime (..))
 import Database.Persist
+import Text.HTML.SanitizeXSS
 import Yesod.Form
 import Yesod.Persist.Core (runDB)
 
@@ -121,7 +122,9 @@ editTicketContentAForm ticket = Ticket
     <$> pure (ticketProject ticket)
     <*> pure (ticketNumber ticket)
     <*> pure (ticketCreated ticket)
-    <*> areq textField "Title*" (Just $ ticketTitle ticket)
+    <*> ( sanitizeBalance <$>
+          areq textField "Title*" (Just $ ticketTitle ticket)
+        )
     <*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
           aopt
             textareaField

src/Vervis/Handler/Ticket.hs

@@ -72,6 +72,7 @@ import Database.Persist
 import Network.HTTP.Types (StdMethod (DELETE, POST))
 import Text.Blaze.Html (Html, toHtml)
 import Text.Blaze.Html.Renderer.Text
+import Text.HTML.SanitizeXSS
 import Yesod.Auth (requireAuthId, maybeAuthId)
 import Yesod.Core
 import Yesod.Core.Handler
@@ -165,7 +166,7 @@ postTicketsR shar proj = do
                         { ticketProject     = pid
                         , ticketNumber      = projectNextTicket project
                         , ticketCreated     = now
-                        , ticketTitle       = ntTitle nt
+                        , ticketTitle       = sanitizeBalance $ ntTitle nt
                         , ticketSource      = source
                         , ticketDescription = descHtml
                         , ticketAssignee    = Nothing
@@ -338,9 +339,7 @@ getTicketR shar proj num = do
             , AP.ticketPublished    = Just $ ticketCreated ticket
             , AP.ticketUpdated      = Nothing
             , AP.ticketName         = Just $ "#" <> T.pack (show num)
-            , AP.ticketSummary      =
+            , AP.ticketSummary      = TextHtml $ ticketTitle ticket
-                TextHtml $ TL.toStrict $ renderHtml $ toHtml $
-                    ticketTitle ticket
             , AP.ticketContent      = TextHtml $ ticketDescription ticket
             , AP.ticketSource       = TextPandocMarkdown $ ticketSource ticket
             , AP.ticketAssignedTo   =

src/Vervis/Migration.hs

@@ -835,6 +835,13 @@ changes hLocal ctx =
         "Outbox"
       -- 122
     , addUnique "Project" $ Unique "UniqueProjectOutbox" ["outbox"]
+      -- 123
+    , unchecked $ lift $ do
+        ts <- selectList ([] :: [Filter Ticket20190612]) []
+        for_ ts $ \ (Entity tid t) ->
+            let title =
+                    TL.toStrict $ renderHtml $ toHtml $ ticket20190612Title t
+            in  update tid [Ticket20190612Title =. title]
     ]
 
 migrateDB