forge/Vervis
1
0
Fork 0
Code Pull requests Activity

Add ticketDescription DB entity field, containing pandoc-rendered HTML

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

25
config/models
View file

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

18
migrations/2019_06_03.model Normal file
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

11
src/Vervis/Form/Ticket.hs
View file

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

46
src/Vervis/Handler/Ticket.hs
View file

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

16
src/Vervis/Migration.hs
View file

@ -504,7 +504,7 @@ changes hLocal ctx =
msgs <- selectList ([] :: [Filter Message201906]) []
for_ msgs $ \ (Entity mid 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
Right content ->
update mid
@ -513,6 +513,20 @@ changes hLocal ctx =
]
-- 88
, 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))

5
src/Vervis/Migration/Model.hs
View file

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