diff --git a/config/models b/config/models index ef05986..9d4db56 100644 --- a/config/models +++ b/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 diff --git a/src/Vervis/ActivityPub.hs b/src/Vervis/ActivityPub.hs index d40011f..34837a1 100644 --- a/src/Vervis/ActivityPub.hs +++ b/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 diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 7594908..f684aae 100644 --- a/src/Vervis/Federation.hs +++ b/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 () diff --git a/src/Vervis/Federation/Discussion.hs b/src/Vervis/Federation/Discussion.hs index fe70188..3eeb428 100644 --- a/src/Vervis/Federation/Discussion.hs +++ b/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 diff --git a/src/Vervis/Federation/Ticket.hs b/src/Vervis/Federation/Ticket.hs index 7a09aac..3fb9711 100644 --- a/src/Vervis/Federation/Ticket.hs +++ b/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" - let checkDep' = checkDep hProject shrProject prjProject - deps <- traverse checkDep' $ ticketDependsOn ticket + deps <- checkOffer ticket hProject shrProject prjProject 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 diff --git a/src/Vervis/Form/Ticket.hs b/src/Vervis/Form/Ticket.hs index 539c027..6bde33a 100644 --- a/src/Vervis/Form/Ticket.hs +++ b/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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 67d5d7a..18cedc8 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/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 = - TextHtml $ TL.toStrict $ renderHtml $ toHtml $ - ticketTitle ticket + , AP.ticketSummary = TextHtml $ ticketTitle ticket , AP.ticketContent = TextHtml $ ticketDescription ticket , AP.ticketSource = TextPandocMarkdown $ ticketSource ticket , AP.ticketAssignedTo = diff --git a/src/Vervis/Migration.hs b/src/Vervis/Migration.hs index 0e4a090..4cb1246 100644 --- a/src/Vervis/Migration.hs +++ b/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