vervis/src/Vervis/Render.hs

{- This file is part of Vervis.
 -
 - Written in 2016, 2018 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

{-# Language CPP #-}

-- | Tools for rendering repository file contents and other source files.
--
-- There are several ways to render a file:
--
-- (1) As a source file, plain text and with line numbers
-- (2) As a source file, syntax highlighted and with line numbers
-- (3) As a plain text document
-- (4) As a document rendered to HTML, e.g. Markdown is a popular format
-- (5) As a document rendered to a custom format, e.g. presentation
--
-- The difference between 3 and 5 is line numbers and font (3 would use regular
-- text font, while 5 would use monospaced font).
--
-- At the time of writing, not all rendering modes are implemented. The current
-- status, assuming I'm keeping it updated, is:
--
-- (1) Partially implemented: No line numbers
-- (2) Implemented, using line numbers generated by @highlighter2@ formatter
-- (3) Not implemented
-- (4) Not implemented
-- (5) Not implmented
module Vervis.Render
    ( renderSourceT
    , renderSourceBL
    )
where

import Prelude

import Control.Monad.Catch (throwM)
import Control.Monad.Logger (logDebug, logWarn)
import Data.Foldable (for_)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
--import Formatting hiding (format)
import Text.Blaze.Html (preEscapedToMarkup)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Text.Highlighter (lexerFromFilename, runLexer, Lexer (lName))
import Text.Highlighter.Formatters.Html (format)
import Skylighting.Styles (tango)
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Text.Pandoc.Class (runPure)
import Text.Pandoc.Definition (Pandoc)
import Text.Pandoc.Options
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
import qualified Text.Highlighter.Lexers.Haskell as L.Haskell

import Vervis.Foundation (Widget)
import Vervis.MediaType (MediaType (..))

-- * File uploads and wiki attachments
-- * Wiki pages
-- * READMEs
-- * Source files which happen to be documents, e.g. Markdown, manpages,
--   OrgMode, LaTeX, and
-- * Literate Haskell files
--
-- For now, let's ignore the first two. Which source files, README or other, do
-- we want to offer to display as HTML rendering?
--
-- * [ ] native
-- * [ ] json
-- * [x] markdown
-- * [ ] markdown_strict
-- * [ ] markdown_phpextra
-- * [ ] markdown_github
-- * [ ] markdown_mmd
-- * [ ] commonmark
-- * [ ] rst
-- * [ ] mediawiki
-- * [ ] docbook
-- * [ ] opml
-- * [ ] org
-- * [ ] textile
-- * [ ] html
-- * [ ] latex
-- * [ ] haddock
-- * [ ] twiki
-- * [ ] docx
-- * [ ] odt
-- * [ ] t2t
-- * [ ] epub
--
-- Any others not in this list, maybe using other libraries?
--
-- * [ ] asciidoc
-- * [ ] groff manpage

renderPlain :: TL.Text -> Widget
renderPlain content =
    [whamlet|
        <pre>
            <code>#{content}
    |]

renderHighlight :: Lexer -> B.ByteString -> Maybe Widget
renderHighlight lexer content =
    case runLexer lexer content of
        Left err     -> Nothing
        Right tokens -> Just $ toWidget $ format True tokens

renderCode :: Lexer -> TL.Text -> B.ByteString -> Widget
renderCode lexer contentTL contentB =
    fromMaybe (renderPlain contentTL) $ renderHighlight lexer contentB

readerOptions :: ReaderOptions
readerOptions = def
    { readerExtensions            = pandocExtensions
    , readerStandalone            = False
    , readerColumns               = 80
    , readerTabStop               = 4
--  , readerIndentedCodeClasses   = []
--  , readerAbbreviations         = defaultAbbrevs
--  , readerDefaultImageExtension = ""
--  , readerTrackChanges          = AcceptChanges
--  , readerStripComments         = False
    }

writerOptions :: WriterOptions
writerOptions = def
    {
--    writerTemplate          = Nothing
--  , writerVariables         = []
      writerTabStop           = 4
    , writerTableOfContents   = True
--  , writerIncremental       = False
--  , writerHTMLMathMethod    = PlainMath
--  , writerNumberSections    = False
--  , writerNumberOffset      = [0,0,0,0,0,0]
--  , writerSectionDivs       = False
    , writerExtensions        = pandocExtensions
--  , writerReferenceLinks    = False
--  , writerDpi               = 96
    , writerWrapText          = WrapAuto
    , writerColumns           = 79
    , writerEmailObfuscation  = ReferenceObfuscation
--  , writerIdentifierPrefix  = ""
--  , writerCiteMethod        = Citeproc
--  , writerHtmlQTags         = False
--  , writerSlideLevel        = Nothing
--  , writerTopLevelDivision  = TopLevelDefault
--  , writerListings          = False
    , writerHighlightStyle    = Just tango
--  , writerSetextHeaders     = True
--  , writerEpubSubdirectory  = "EPUB"
--  , writerEpubMetadata      = Nothing
--  , writerEpubFonts         = []
--  , writerEpubChapterLevel  = 1
--  , writerTOCDepth          = 3
--  , writerReferenceDoc      = Nothing
--  , writerReferenceLocation = EndOfDocument
--  , writerSyntaxMap         = defaultSyntaxMap
    }

renderPandoc :: Pandoc -> Widget
renderPandoc
    = either throwM toWidget
    . fmap
        ( preEscapedToMarkup
        . sanitizeBalance
        . TL.toStrict
        . renderHtml
        )
    . runPure
    . writeHtml5 writerOptions

renderSourceT :: MediaType -> Text -> Widget
renderSourceT mt contentT =
    let contentB = TE.encodeUtf8 contentT
        contentTL = TL.fromStrict contentT
    in  renderSource mt contentB contentTL contentT

renderSourceBL :: MediaType -> BL.ByteString -> Widget
renderSourceBL mt contentBL =
    let contentB = BL.toStrict contentBL
        contentTL = TLE.decodeUtf8With TE.lenientDecode contentBL
        contentT = TL.toStrict contentTL
    in  renderSource mt contentB contentTL contentT

renderSource :: MediaType -> B.ByteString -> TL.Text -> Text -> Widget
renderSource mt contentB contentTL contentT =
    let mtName = T.pack $ show mt

        failed e =
            "Failed to parse " <> mtName <> "content: " <> T.pack (show e)

        -- Plain text with line numbers
        plain = renderPlain contentTL
        -- Syntax highlighted source code with line numbers
        code l = renderCode l contentTL contentB
        -- Rendered document from Text source
        docT r =
            case runPure $ r readerOptions contentT of
                Left err  -> $logWarn (failed err) >> plain
                Right doc -> renderPandoc doc
    in  case mt of
            -- * Documents
            PlainText -> plain
            Markdown  -> docT readMarkdown
            -- * Programming languages
            -- ** Haskell
            Haskell   -> code L.Haskell.lexer
            -- * Misc
            _         -> plain