mirror of
https://code.naskya.net/repos/ndqEd
synced 2025-01-10 16:26:46 +09:00
297 lines
9.7 KiB
Haskell
297 lines
9.7 KiB
Haskell
{- This file is part of Vervis.
|
|
-
|
|
- Written in 2016, 2018, 2019, 2022 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 Yesod.RenderSource
|
|
( renderSourceT
|
|
, renderSourceBL
|
|
, renderPandocMarkdown
|
|
, renderPrettyJSON
|
|
, renderPrettyJSON'
|
|
, renderPrettyJSONSkylighting
|
|
, renderPrettyJSONSkylighting'
|
|
)
|
|
where
|
|
|
|
import Control.Exception
|
|
import Control.Monad.Catch (throwM)
|
|
import Control.Monad.Logger (logDebug, logWarn)
|
|
import Data.Aeson
|
|
import Data.Foldable (for_)
|
|
import Data.Maybe (fromMaybe)
|
|
import Data.Monoid ((<>))
|
|
import Data.Text (Text)
|
|
--import Formatting hiding (format)
|
|
import Skylighting
|
|
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 Text.HTML.SanitizeXSS (sanitizeBalance)
|
|
import Text.Pandoc.Class (runPure)
|
|
import Text.Pandoc.Definition (Pandoc)
|
|
import Text.Pandoc.Highlighting
|
|
import Text.Pandoc.Options
|
|
import Text.Pandoc.Readers.Markdown
|
|
import Text.Pandoc.Writers.HTML
|
|
import Yesod.Core.Widget
|
|
|
|
import qualified Data.ByteString as B
|
|
import qualified Data.ByteString.Lazy as BL
|
|
import qualified Data.Map.Strict as M
|
|
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.Builder as TLB
|
|
import qualified Data.Text.Lazy.Encoding as TLE
|
|
import qualified Text.Highlighter.Lexers.DarcsPatch as L.DarcsPatch
|
|
import qualified Text.Highlighter.Lexers.Diff as L.Diff
|
|
import qualified Text.Highlighter.Lexers.Haskell as L.Haskell
|
|
import qualified Text.Highlighter.Lexers.Javascript as L.JS
|
|
|
|
import Data.Aeson.Encode.Pretty.ToEncoding
|
|
import Data.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 -> WidgetFor site ()
|
|
renderPlain content =
|
|
[whamlet|
|
|
<pre>
|
|
<code>#{content}
|
|
|]
|
|
|
|
renderHighlight :: Lexer -> B.ByteString -> Maybe (WidgetFor site ())
|
|
renderHighlight lexer content =
|
|
case runLexer lexer content of
|
|
Left err -> Nothing
|
|
Right tokens -> Just $ toWidget $ format True tokens
|
|
|
|
renderCode :: Lexer -> TL.Text -> B.ByteString -> WidgetFor site ()
|
|
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 -> WidgetFor site ()
|
|
renderPandoc
|
|
= either throwM toWidget
|
|
. fmap
|
|
( preEscapedToMarkup
|
|
. sanitizeBalance
|
|
. TL.toStrict
|
|
. renderHtml
|
|
)
|
|
. runPure
|
|
. writeHtml5 writerOptions
|
|
|
|
renderSourceT :: MediaType -> Text -> WidgetFor site ()
|
|
renderSourceT mt contentT =
|
|
let contentB = TE.encodeUtf8 contentT
|
|
contentTL = TL.fromStrict contentT
|
|
in renderSource mt contentB contentTL contentT
|
|
|
|
renderSourceBL :: MediaType -> BL.ByteString -> WidgetFor site ()
|
|
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 -> WidgetFor site ()
|
|
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
|
|
-- * Development files
|
|
Diff -> code L.Diff.lexer
|
|
DarcsPatch -> code L.DarcsPatch.lexer
|
|
-- * Misc
|
|
_ -> plain
|
|
|
|
renderPandocMarkdown :: Text -> Either Text Text
|
|
renderPandocMarkdown input =
|
|
case parse input of
|
|
Left err ->
|
|
Left $
|
|
"Failed to parse Markdown: " <> T.pack (displayException err)
|
|
Right doc ->
|
|
case render doc of
|
|
Left err ->
|
|
Left $
|
|
"Failed to render Markdown: " <>
|
|
T.pack (displayException err)
|
|
Right output -> Right output
|
|
where
|
|
parse = runPure . readMarkdown readerOptions
|
|
render
|
|
= fmap (sanitizeBalance . TL.toStrict . renderHtml)
|
|
. runPure
|
|
. writeHtml5 writerOptions
|
|
|
|
renderPrettyJSON :: ToJSON a => a -> WidgetFor site ()
|
|
renderPrettyJSON = renderPrettyJSON' . encodePretty
|
|
|
|
renderPrettyJSON' :: BL.ByteString -> WidgetFor site ()
|
|
renderPrettyJSON' prettyBL =
|
|
let prettyB = BL.toStrict prettyBL
|
|
prettyTL = TLE.decodeUtf8 prettyBL
|
|
in renderCode L.JS.lexer prettyTL prettyB
|
|
|
|
renderPrettyJSONSkylighting' :: BL.ByteString -> WidgetFor site ()
|
|
renderPrettyJSONSkylighting' prettyBL =
|
|
case tokenizeJSON prettyBL of
|
|
Left e -> error $ "Tokenizing JSON failed: " ++ e
|
|
Right sls -> do
|
|
toWidgetHead $ CssBuilder $ TLB.fromString $ styleToCss zenburn
|
|
toWidget $ formatHtmlBlock options sls
|
|
where
|
|
tokenizeJSON = tokenize config jsonSyntax . TE.decodeUtf8 . BL.toStrict
|
|
where
|
|
syntaxMap = defaultSyntaxMap
|
|
jsonSyntax =
|
|
case M.lookup "JSON" syntaxMap of
|
|
Nothing -> error "Skylighting JSON syntax not found"
|
|
Just s -> s
|
|
config = TokenizerConfig syntaxMap False
|
|
options = defaultFormatOpts { numberLines = True }
|
|
|
|
renderPrettyJSONSkylighting :: ToJSON a => a -> WidgetFor site ()
|
|
renderPrettyJSONSkylighting = renderPrettyJSONSkylighting' . encodePretty
|