Render ticket description as Markdown

At the beginning the rendering was invalid because it parsed the entire
content as a single line. For some reason, when I read the ticket
description from the DB, all newlines are returned as CRLF. I don't know
why yet or whether it can or should be changed, but as a quick fix, I
made the handler function filter out the CRs from the text. Then the
rendering is correct.

This matches the documentation of Pandoc, which mentions the readers
assume newlines are encoded as LF.

src/Vervis/Handler/Repo.hs

@@ -183,7 +183,7 @@ getRepoSource repository user repo ref dir = do
                             parent = init dir
                             (base, ext) = breakExt name
                             mediaType = chooseMediaType parent base ext () ()
-                        in  renderSource mediaType (blobGetContent b)
+                        in  renderSourceBL mediaType (blobGetContent b)
                     Right (v, mr) -> return $ Right (map mkrow v, mr)
             let parent = if null dir then [] else init dir
                 dirs = zip parent (tail $ inits parent)

src/Vervis/Handler/Ticket.hs

@@ -41,12 +41,14 @@ import Yesod.Form.Functions (runFormPost)
 import Yesod.Form.Types (FormResult (..))
 import Yesod.Persist.Core (runDB, get404, getBy404)
 
-import qualified Data.Text as T (intercalate, pack)
+import qualified Data.Text as T (filter, intercalate, pack)
 import qualified Database.Esqueleto as E ((==.))
 
 import Vervis.Form.Ticket
 import Vervis.Foundation
+import Vervis.MediaType (MediaType (Markdown))
 import Vervis.Model
+import Vervis.Render (renderSourceT)
 import Vervis.Settings (widgetFile)
 
 getTicketsR :: Text -> Text -> Handler Html
@@ -116,6 +118,7 @@ getTicketR shar proj num = do
                     get404 $ personIdent person'
                 else return author
         return (author, closer, ticket)
+    let desc = renderSourceT Markdown $ T.filter (/= '\r') $ ticketDesc ticket
     defaultLayout $ do
         setTitle $ toHtml $ T.intercalate " :: "
             [shar, proj, "Tickets", T.pack ('#' : show num)]

src/Vervis/Readme.hs

@@ -34,7 +34,7 @@ import System.FilePath (isExtSeparator)
 
 import Vervis.Foundation (Widget)
 import Vervis.MediaType (chooseMediaType)
-import Vervis.Render (renderSource)
+import Vervis.Render (renderSourceBL)
 import Text.FilePath.Local (breakExt)
 
 -- | Check if the given filename should be considered as README file. Assumes
@@ -65,4 +65,4 @@ renderReadme :: [Text] -> Text -> ByteString -> Widget
 renderReadme dir name content =
     let (base, ext) = breakExt name
         mediaType = chooseMediaType dir base ext () ()
-    in  renderSource mediaType content
+    in  renderSourceBL mediaType content

src/Vervis/Render.hs

@@ -37,9 +37,8 @@
 -- (4) Not implemented
 -- (5) Not implmented
 module Vervis.Render
-    ( --renderPlain
+    ( renderSourceT
-    --, renderHighlight
+    , renderSourceBL
-      renderSource
     )
 where
 
@@ -62,8 +61,10 @@ import Text.Pandoc.Readers.Markdown
 import Text.Pandoc.Writers.HTML
 import Yesod.Core.Widget (whamlet, toWidget)
 
+import qualified Data.ByteString as B
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
 import qualified Data.Text.Encoding.Error as TE
 import qualified Data.Text.Lazy as TL
 import qualified Data.Text.Lazy.Encoding as TLE
@@ -72,24 +73,6 @@ import qualified Text.Highlighter.Lexers.Haskell as L.Haskell
 import Vervis.Foundation (Widget)
 import Vervis.MediaType (MediaType (..))
 
-renderPlain :: BL.ByteString -> Widget
-renderPlain content =
-    [whamlet|
-        <pre>
-            <code>#{TLE.decodeUtf8With TE.lenientDecode content}
-    |]
-
-{-renderHighlight
-    :: FilePath -> BL.ByteString -> Either (Maybe Lexer) (Lexer, Widget)
-renderHighlight name content =
-    case lexerFromFilename name of
-        Nothing    -> Left Nothing
-        Just lexer ->
-            case runLexer lexer $ BL.toStrict content of
-                Left err     -> Left $ Just lexer
-                Right tokens -> Right (lexer, toWidget $ format True tokens)
--}
-
 -- * File uploads and wiki attachments
 -- * Wiki pages
 -- * READMEs
@@ -128,15 +111,22 @@ renderHighlight name content =
 -- * [ ] asciidoc
 -- * [ ] groff manpage
 
-renderHighlight :: Lexer -> BL.ByteString -> Maybe Widget
+renderPlain :: TL.Text -> Widget
+renderPlain content =
+    [whamlet|
+        <pre>
+            <code>#{content}
+    |]
+
+renderHighlight :: Lexer -> B.ByteString -> Maybe Widget
 renderHighlight lexer content =
-    case runLexer lexer $ BL.toStrict content of
+    case runLexer lexer content of
         Left err     -> Nothing
         Right tokens -> Just $ toWidget $ format True tokens
 
-renderCode :: Lexer -> BL.ByteString -> Widget
+renderCode :: Lexer -> TL.Text -> B.ByteString -> Widget
-renderCode lexer content =
+renderCode lexer contentTL contentB =
-    fromMaybe (renderPlain content) $ renderHighlight lexer content
+    fromMaybe (renderPlain contentTL) $ renderHighlight lexer contentB
 
 readerOptions :: ReaderOptions
 readerOptions = def
@@ -221,21 +211,31 @@ renderPandoc =
     renderHtml .
     writeHtml writerOptions
 
-renderSource :: MediaType -> BL.ByteString -> Widget
+renderSourceT :: MediaType -> T.Text -> Widget
-renderSource mt content =
+renderSourceT mt contentT =
-    let contentBL = content
+    let contentB = TE.encodeUtf8 contentT
+        contentTL = TL.fromStrict contentT
+        contentS = T.unpack contentT
+    in  renderSource mt contentB contentTL contentS
+
+renderSourceBL :: MediaType -> BL.ByteString -> Widget
+renderSourceBL mt contentBL =
+    let contentB = BL.toStrict contentBL
         contentTL = TLE.decodeUtf8With TE.lenientDecode contentBL
         contentS = TL.unpack contentTL
+    in  renderSource mt contentB contentTL contentS
 
-        mtName = T.pack $ show mt
+renderSource :: MediaType -> B.ByteString -> TL.Text -> String -> Widget
+renderSource mt contentB contentTL contentS =
+    let mtName = T.pack $ show mt
 
         failed e =
             "Failed to parse " <> mtName <> "content: " <> T.pack (show e)
 
         -- Plain text with line numbers
-        plain = renderPlain content
+        plain = renderPlain contentTL
         -- Syntax highlighted source code with line numbers
-        code l = renderCode l content
+        code l = renderCode l contentTL contentB
         -- Rendered document from String source
         docS r =
             case r readerOptions contentS of
@@ -258,23 +258,3 @@ renderSource mt content =
             Haskell   -> code L.Haskell.lexer
             -- * Misc
             _         -> plain
-
-{-renderSource :: FilePath -> BL.ByteString -> Widget
-renderSource name content =
-    let plain = renderPlain content
-    in  case renderHighlight name content of
-            Left Nothing -> do
-                $logDebug $ "No lexer found for " <> pack name
-                plain
-            Left (Just lexer) -> do
-                $logWarn $ sformat
-                    ( "Failed to highlight " % string % " with lexer "
-                    % string
-                    )
-                    name (lName lexer)
-                plain
-            Right (lexer, widget) -> do
-                $logDebug $ sformat
-                    ("Lexed " % string % " with " % string) name (lName lexer)
-                widget
--}

templates/ticket/one.hamlet

@@ -33,9 +33,4 @@ $# <http://creativecommons.org/publicdomain/zero/1.0/>.
 
 <h2>#{ticketTitle ticket}
 
-<p>
+^{desc}
-  Below is the ticket description. It’s supposed to be rendered as Markdown,
-  but for now, temporarily, it’s shown here as plain text.
-
-<code>
-  <pre>#{ticketDesc ticket}