Add ticketDescription DB entity field, containing pandoc-rendered HTML

This commit is contained in:
fr33domlover 2019-06-03 12:45:02 +00:00
parent 17fe163c09
commit f7432e515c
6 changed files with 89 additions and 32 deletions

View file

@ -278,18 +278,19 @@ TicketParamEnum
UniqueTicketParamEnum ticket field value UniqueTicketParamEnum ticket field value
Ticket Ticket
project ProjectId project ProjectId
number Int number Int
created UTCTime created UTCTime
creator PersonId creator PersonId
title Text title Text
desc Text -- Assume this is Pandoc Markdown source Text -- Pandoc Markdown
assignee PersonId Maybe description Text -- HTML
status TicketStatus assignee PersonId Maybe
closed UTCTime status TicketStatus
closer PersonId closed UTCTime
discuss DiscussionId closer PersonId
followers FollowerSetId discuss DiscussionId
followers FollowerSetId
UniqueTicket project number UniqueTicket project number
UniqueTicketDiscussion discuss UniqueTicketDiscussion discuss

View file

@ -0,0 +1,18 @@
Ticket
project Int64
number Int
created UTCTime
creator Int64
title Text
source Text -- Pandoc Markdown
description Text -- HTML
assignee Int64 Maybe
status Text
closed UTCTime
closer Int64
discuss Int64
followers Int64
UniqueTicket project number
UniqueTicketDiscussion discuss
UniqueTicketFollowers followers

View file

@ -37,7 +37,7 @@ import Database.Persist
import Yesod.Form import Yesod.Form
import Yesod.Persist.Core (runDB) import Yesod.Persist.Core (runDB)
import qualified Data.Text as T (snoc) import qualified Data.Text as T
import Vervis.Field.Ticket import Vervis.Field.Ticket
import Vervis.Foundation (App, Form, Handler) import Vervis.Foundation (App, Form, Handler)
@ -112,7 +112,7 @@ newTicketForm wid html = do
return (tfs, efs) return (tfs, efs)
flip renderDivs html $ NewTicket flip renderDivs html $ NewTicket
<$> areq textField "Title*" Nothing <$> areq textField "Title*" Nothing
<*> ( maybe "" unTextarea <$> <*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
aopt textareaField "Description (Markdown)" Nothing aopt textareaField "Description (Markdown)" Nothing
) )
<*> (catMaybes <$> traverse tfield tfs) <*> (catMaybes <$> traverse tfield tfs)
@ -125,12 +125,15 @@ editTicketContentAForm ticket = Ticket
<*> pure (ticketCreated ticket) <*> pure (ticketCreated ticket)
<*> pure (ticketCreator ticket) <*> pure (ticketCreator ticket)
<*> areq textField "Title*" (Just $ ticketTitle ticket) <*> areq textField "Title*" (Just $ ticketTitle ticket)
<*> ( maybe "" unTextarea <$> <*> ( maybe "" (T.filter (/= '\r') . unTextarea) <$>
aopt aopt
textareaField textareaField
"Description (Markdown)" "Description (Markdown)"
(Just $ Just $ Textarea $ ticketSource ticket) (Just $ Just $ Textarea $
T.intercalate "\r\n" $ T.lines $ ticketSource ticket
)
) )
<*> pure (ticketDescription ticket)
<*> pure (ticketAssignee ticket) <*> pure (ticketAssignee ticket)
<*> pure (ticketStatus ticket) <*> pure (ticketStatus ticket)
<*> pure (ticketClosed ticket) <*> pure (ticketClosed ticket)

View file

@ -103,7 +103,7 @@ import Vervis.Model
import Vervis.Model.Ident import Vervis.Model.Ident
import Vervis.Model.Ticket import Vervis.Model.Ticket
import Vervis.Model.Workflow import Vervis.Model.Workflow
import Vervis.Render (renderSourceT) import Vervis.Render
import Vervis.Settings import Vervis.Settings
import Vervis.Style import Vervis.Style
import Vervis.Ticket import Vervis.Ticket
@ -143,23 +143,31 @@ postTicketsR shar proj = do
FormSuccess nt -> do FormSuccess nt -> do
author <- requireAuthId author <- requireAuthId
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
let source = ntDesc nt
descHtml <-
case renderPandocMarkdown source of
Left err -> do
setMessage $ toHtml err
redirect $ TicketNewR shar proj
Right t -> return t
tnum <- runDB $ do tnum <- runDB $ do
update pid [ProjectNextTicket +=. 1] update pid [ProjectNextTicket +=. 1]
did <- insert Discussion did <- insert Discussion
fsid <- insert FollowerSet fsid <- insert FollowerSet
let ticket = Ticket let ticket = Ticket
{ ticketProject = pid { ticketProject = pid
, ticketNumber = projectNextTicket project , ticketNumber = projectNextTicket project
, ticketCreated = now , ticketCreated = now
, ticketCreator = author , ticketCreator = author
, ticketTitle = ntTitle nt , ticketTitle = ntTitle nt
, ticketSource = ntDesc nt , ticketSource = source
, ticketAssignee = Nothing , ticketDescription = descHtml
, ticketStatus = TSNew , ticketAssignee = Nothing
, ticketClosed = UTCTime (ModifiedJulianDay 0) 0 , ticketStatus = TSNew
, ticketCloser = author , ticketClosed = UTCTime (ModifiedJulianDay 0) 0
, ticketDiscuss = did , ticketCloser = author
, ticketFollowers = fsid , ticketDiscuss = did
, ticketFollowers = fsid
} }
tid <- insert ticket tid <- insert ticket
let mktparam (fid, v) = TicketParamText let mktparam (fid, v) = TicketParamText
@ -253,7 +261,8 @@ getTicketR shar proj num = do
, deps, rdeps , deps, rdeps
) )
encodeHid <- getEncodeKeyHashid encodeHid <- getEncodeKeyHashid
let desc = renderSourceT Markdown $ T.filter (/= '\r') $ ticketSource ticket let desc :: Widget
desc = toWidget $ preEscapedToMarkup $ ticketDescription ticket
discuss = discuss =
discussionW discussionW
(return $ ticketDiscuss ticket) (return $ ticketDiscuss ticket)
@ -280,8 +289,15 @@ putTicketR shar proj num = do
runFormPost $ editTicketContentForm tid ticket wid runFormPost $ editTicketContentForm tid ticket wid
case result of case result of
FormSuccess (ticket', tparams, eparams) -> do FormSuccess (ticket', tparams, eparams) -> do
newDescHtml <-
case renderPandocMarkdown $ ticketSource ticket' of
Left err -> do
setMessage $ toHtml err
redirect $ TicketEditR shar proj num
Right t -> return t
let ticket'' = ticket' { ticketDescription = newDescHtml }
runDB $ do runDB $ do
replace tid ticket' replace tid ticket''
let (tdel, tins, tupd) = partitionMaybePairs tparams let (tdel, tins, tupd) = partitionMaybePairs tparams
deleteWhere [TicketParamTextId <-. tdel] deleteWhere [TicketParamTextId <-. tdel]
let mktparam (fid, v) = TicketParamText let mktparam (fid, v) = TicketParamText

View file

@ -504,7 +504,7 @@ changes hLocal ctx =
msgs <- selectList ([] :: [Filter Message201906]) [] msgs <- selectList ([] :: [Filter Message201906]) []
for_ msgs $ \ (Entity mid m) -> for_ msgs $ \ (Entity mid m) ->
let source = T.filter (/= '\r') $ message201906Source m let source = T.filter (/= '\r') $ message201906Source m
in case renderPandocMarkdown $ message201906Source m of in case renderPandocMarkdown source of
Left err -> liftIO $ throwIO $ userError $ T.unpack err Left err -> liftIO $ throwIO $ userError $ T.unpack err
Right content -> Right content ->
update mid update mid
@ -513,6 +513,20 @@ changes hLocal ctx =
] ]
-- 88 -- 88
, renameField "Ticket" "desc" "source" , renameField "Ticket" "desc" "source"
-- 89
, addFieldPrimRequired "Ticket" ("" :: Text) "description"
-- 90
, unchecked $ lift $ do
tickets <- selectList ([] :: [Filter Ticket201906]) []
for_ tickets $ \ (Entity tid t) ->
let source = T.filter (/= '\r') $ ticket201906Source t
in case renderPandocMarkdown source of
Left err -> liftIO $ throwIO $ userError $ T.unpack err
Right content ->
update tid
[ Ticket201906Source =. source
, Ticket201906Description =. content
]
] ]
migrateDB :: MonadIO m => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int)) migrateDB :: MonadIO m => Text -> HashidsContext -> ReaderT SqlBackend m (Either Text (Int, Int))

View file

@ -55,6 +55,8 @@ module Vervis.Migration.Model
, RemoteMessage201905Generic (..) , RemoteMessage201905Generic (..)
, Message201906Generic (..) , Message201906Generic (..)
, Message201906 , Message201906
, Ticket201906Generic (..)
, Ticket201906
) )
where where
@ -141,3 +143,6 @@ makeEntitiesMigration "201905"
makeEntitiesMigration "201906" makeEntitiesMigration "201906"
$(modelFile "migrations/2019_06_02.model") $(modelFile "migrations/2019_06_02.model")
makeEntitiesMigration "201906"
$(modelFile "migrations/2019_06_03.model")