{-# LANGUAGE CPP, OverloadedStrings #-}
module Cheapskate.Html (renderDoc, renderBlocks, renderInlines) where
import Cheapskate.Types
import Data.Text (Text)
import Data.Char (isDigit, isHexDigit, isAlphaNum)
import qualified Text.Blaze.XHtml5 as H
import qualified Text.Blaze.Html5.Attributes as A
import qualified Text.Blaze.Html.Renderer.Text as BT
import Text.Blaze.Html hiding(contents)
import Data.Monoid
#if !(MIN_VERSION_base(4,8,0))
import Data.Foldable (foldMap)
#endif
import Data.Foldable (toList)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Data.List (intersperse)
import Text.HTML.SanitizeXSS (sanitizeBalance)

-- | Render a markdown document as 'Html'.  (This can be turned
-- into a 'Text' or 'ByteString' using a renderer from the @blaze-html@
-- library.)
renderDoc :: Doc -> Html
renderDoc :: Doc -> Html
renderDoc (Doc opts :: Options
opts body :: Blocks
body) = Html -> Html
mbsanitize (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ (Options -> Blocks -> Html
renderBlocks Options
opts Blocks
body Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> "\n")
  where mbsanitize :: Html -> Html
mbsanitize = if Options -> Bool
sanitize Options
opts
                        then Text -> Html
forall a. ToMarkup a => a -> Html
preEscapedToMarkup (Text -> Html) -> (Html -> Text) -> Html -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sanitizeBalance (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                             Text -> Text
TL.toStrict (Text -> Text) -> (Html -> Text) -> Html -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Text
BT.renderHtml
                        else Html -> Html
forall a. a -> a
id
  -- note: less efficient to do this at the whole document level,
  -- rather than on individual raw html bits and attributes, but
  -- this is needed for cases where open tags in one raw HTML
  -- section are balanced by close tags in another.

-- Render a sequence of blocks as HTML5.  Currently a single
-- newline is used between blocks, and a newline is used as a
-- separator e.g. for list items. These can be changed by adjusting
-- nl and blocksep.  Eventually we probably want these as parameters
-- or options.
renderBlocks :: Options -> Blocks -> Html
renderBlocks :: Options -> Blocks -> Html
renderBlocks opts :: Options
opts = [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> (Blocks -> [Html]) -> Blocks -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
intersperse Html
blocksep ([Html] -> [Html]) -> (Blocks -> [Html]) -> Blocks -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> Html) -> [Block] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Html
renderBlock ([Block] -> [Html]) -> (Blocks -> [Block]) -> Blocks -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocks -> [Block]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where renderBlock :: Block -> Html
        renderBlock :: Block -> Html
renderBlock (Header n :: Int
n ils :: Inlines
ils)
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 1 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= 6 = ([Html -> Html
H.h1,Html -> Html
H.h2,Html -> Html
H.h3,Html -> Html
H.h4,Html -> Html
H.h5,Html -> Html
H.h6] [Html -> Html] -> Int -> Html -> Html
forall a. [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1))
                                  (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Options -> Inlines -> Html
renderInlines Options
opts Inlines
ils
          | Bool
otherwise        = Html -> Html
H.p (Options -> Inlines -> Html
renderInlines Options
opts Inlines
ils)
        renderBlock (Para ils :: Inlines
ils) = Html -> Html
H.p (Options -> Inlines -> Html
renderInlines Options
opts Inlines
ils)
        renderBlock (Block
HRule) = Html
H.hr
        renderBlock (Blockquote bs :: Blocks
bs) = Html -> Html
H.blockquote (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
nl Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Options -> Blocks -> Html
renderBlocks Options
opts Blocks
bs Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
nl
        renderBlock (CodeBlock attr :: CodeAttr
attr t :: Text
t) =
          if Text -> Bool
T.null (CodeAttr -> Text
codeLang CodeAttr
attr)
             then Html
base
             else Html
base Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.class_ (Text -> AttributeValue
toValue' (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ CodeAttr -> Text
codeLang CodeAttr
attr)
          where base :: Html
base = Html -> Html
H.pre (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html -> Html
H.code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml (Text
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "\n")
          -- add newline because Markdown.pl does
        renderBlock (List tight :: Bool
tight (Bullet _) items :: [Blocks]
items) =
          Html -> Html
H.ul (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
nl Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Blocks -> Html) -> [Blocks] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Blocks -> Html
li Bool
tight) [Blocks]
items
        renderBlock (List tight :: Bool
tight (Numbered _ n :: Int
n) items :: [Blocks]
items) =
          if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 1 then Html
base else Html
base Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.start (Int -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue Int
n)
          where base :: Html
base = Html -> Html
H.ol (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Html
nl Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> (Blocks -> Html) -> [Blocks] -> Html
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> Blocks -> Html
li Bool
tight) [Blocks]
items
        renderBlock (HtmlBlock raw :: Text
raw) =
          if Options -> Bool
allowRawHtml Options
opts
             then Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToMarkup Text
raw
             else Text -> Html
forall a. ToMarkup a => a -> Html
toHtml Text
raw
        li :: Bool -> Blocks -> Html  -- tight list handling
        li :: Bool -> Blocks -> Html
li True = (Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
nl) (Html -> Html) -> (Blocks -> Html) -> Blocks -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> Html
H.li (Html -> Html) -> (Blocks -> Html) -> Blocks -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Html] -> Html
forall a. Monoid a => [a] -> a
mconcat ([Html] -> Html) -> (Blocks -> [Html]) -> Blocks -> Html
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Html -> [Html] -> [Html]
forall a. a -> [a] -> [a]
intersperse Html
blocksep ([Html] -> [Html]) -> (Blocks -> [Html]) -> Blocks -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                      (Block -> Html) -> [Block] -> [Html]
forall a b. (a -> b) -> [a] -> [b]
map Block -> Html
renderBlockTight ([Block] -> [Html]) -> (Blocks -> [Block]) -> Blocks -> [Html]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocks -> [Block]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        li False = Blocks -> Html
toLi
        renderBlockTight :: Block -> Html
renderBlockTight (Para zs :: Inlines
zs) = Options -> Inlines -> Html
renderInlines Options
opts Inlines
zs
        renderBlockTight x :: Block
x         = Block -> Html
renderBlock Block
x
        toLi :: Blocks -> Html
toLi x :: Blocks
x = (Html -> Html
H.li (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Options -> Blocks -> Html
renderBlocks Options
opts Blocks
x) Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
nl
        nl :: Html
nl = "\n"
        blocksep :: Html
blocksep = "\n"

-- Render a sequence of inlines as HTML5.
renderInlines :: Options -> Inlines -> Html
renderInlines :: Options -> Inlines -> Html
renderInlines opts :: Options
opts = (Inline -> Html) -> Inlines -> Html
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Inline -> Html
renderInline
  where renderInline :: Inline -> Html
        renderInline :: Inline -> Html
renderInline (Str t :: Text
t) = Text -> Html
forall a. ToMarkup a => a -> Html
toHtml Text
t
        renderInline Space   = " "
        renderInline SoftBreak
          | Options -> Bool
preserveHardBreaks Options
opts = Html
H.br Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> "\n"
          | Bool
otherwise               = "\n"
          -- this preserves the line breaks in the
          -- markdown document; replace with " " if this isn't wanted.
        renderInline LineBreak = Html
H.br Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> "\n"
        renderInline (Emph ils :: Inlines
ils) = Html -> Html
H.em (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Options -> Inlines -> Html
renderInlines Options
opts Inlines
ils
        renderInline (Strong ils :: Inlines
ils) = Html -> Html
H.strong (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Options -> Inlines -> Html
renderInlines Options
opts Inlines
ils
        renderInline (Code t :: Text
t) = Html -> Html
H.code (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Text -> Html
forall a. ToMarkup a => a -> Html
toHtml Text
t
        renderInline (Link ils :: Inlines
ils url :: Text
url tit :: Text
tit) =
          if Text -> Bool
T.null Text
tit then Html
base else Html
base Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title (Text -> AttributeValue
toValue' Text
tit)
          where base :: Html
base = Html -> Html
H.a (Html -> Html) -> Attribute -> Html -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.href (Text -> AttributeValue
toValue' Text
url) (Html -> Html) -> Html -> Html
forall a b. (a -> b) -> a -> b
$ Options -> Inlines -> Html
renderInlines Options
opts Inlines
ils
        renderInline (Image ils :: Inlines
ils url :: Text
url tit :: Text
tit) =
          if Text -> Bool
T.null Text
tit then Html
base else Html
base Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.title (Text -> AttributeValue
toValue' Text
tit)
          where base :: Html
base = Html
H.img Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.src (Text -> AttributeValue
toValue' Text
url)
                             Html -> Attribute -> Html
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
A.alt (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue
                                (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Html -> Text
BT.renderHtml (Html -> Text) -> Html -> Text
forall a b. (a -> b) -> a -> b
$ Options -> Inlines -> Html
renderInlines Options
opts Inlines
ils)
        renderInline (Entity t :: Text
t) = Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToMarkup Text
t
        renderInline (RawHtml t :: Text
t) =
          if Options -> Bool
allowRawHtml Options
opts
             then Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToMarkup Text
t
             else Text -> Html
forall a. ToMarkup a => a -> Html
toHtml Text
t

toValue' :: Text -> AttributeValue
toValue' :: Text -> AttributeValue
toValue' = String -> AttributeValue
forall a. ToValue a => a -> AttributeValue
preEscapedToValue (String -> AttributeValue)
-> (Text -> String) -> Text -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
gentleEscape (String -> String) -> (Text -> String) -> Text -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

-- preserve existing entities
gentleEscape :: String -> String
gentleEscape :: String -> String
gentleEscape [] = []
gentleEscape ('"':xs :: String
xs) = "&quot;" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gentleEscape String
xs
gentleEscape ('\'':xs :: String
xs) = "&#39;" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gentleEscape String
xs
gentleEscape ('&':'#':x :: Char
x:xs :: String
xs)
  | Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'x' Bool -> Bool -> Bool
|| Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== 'X' =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isHexDigit String
xs of
       (ys :: String
ys,';':zs :: String
zs) | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ys) Bool -> Bool -> Bool
&& String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ys Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 6 ->
         '&'Char -> String -> String
forall a. a -> [a] -> [a]
:'#'Char -> String -> String
forall a. a -> [a] -> [a]
:Char
xChar -> String -> String
forall a. a -> [a] -> [a]
:String
ys String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gentleEscape String
zs
       _ -> "&amp;#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
gentleEscape String
xs)
gentleEscape ('&':'#':xs :: String
xs) =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isDigit String
xs of
       (ys :: String
ys,';':zs :: String
zs) | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ys) Bool -> Bool -> Bool
&& String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ys Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 6 ->
         '&'Char -> String -> String
forall a. a -> [a] -> [a]
:'#'Char -> String -> String
forall a. a -> [a] -> [a]
:String
ys String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gentleEscape String
zs
       _ -> "&amp;#" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gentleEscape String
xs
gentleEscape ('&':xs :: String
xs) =
  case (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Char -> Bool
isAlphaNum String
xs of
       (ys :: String
ys,';':zs :: String
zs) | Bool -> Bool
not (String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
ys) Bool -> Bool -> Bool
&& String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
ys Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 11 ->
         '&'Char -> String -> String
forall a. a -> [a] -> [a]
:String
ys String -> String -> String
forall a. [a] -> [a] -> [a]
++ ";" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gentleEscape String
zs
       _ -> "&amp;" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
gentleEscape String
xs
gentleEscape (x :: Char
x:xs :: String
xs) = Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
gentleEscape String
xs