Add ticketDescription DB entity field, containing pandoc-rendered HTML

config/models

@@ -283,7 +283,8 @@ Ticket
     created     UTCTime
     creator     PersonId
     title       Text
-    desc     Text -- Assume this is Pandoc Markdown
+    source      Text                -- Pandoc Markdown
+    description Text                -- HTML
     assignee    PersonId      Maybe
     status      TicketStatus
     closed      UTCTime

migrations/2019_06_03.model

@@ -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

src/Vervis/Form/Ticket.hs

@@ -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)

src/Vervis/Handler/Ticket.hs

@@ -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,6 +143,13 @@ 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
@@ -153,7 +160,8 @@ postTicketsR shar proj = do
                         , ticketCreated     = now
                         , ticketCreator     = author
                         , ticketTitle       = ntTitle nt
-                        , ticketSource   = ntDesc nt
+                        , ticketSource      = source
+                        , ticketDescription = descHtml
                         , ticketAssignee    = Nothing
                         , ticketStatus      = TSNew
                         , ticketClosed      = UTCTime (ModifiedJulianDay 0) 0
@@ -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

src/Vervis/Migration.hs

@@ -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))

src/Vervis/Migration/Model.hs

@@ -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")