{-# 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 Options
opts 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
<> Html
"\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 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 a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
  where renderBlock :: Block -> Html
        renderBlock :: Block -> Html
renderBlock (Header Int
n Inlines
ils)
          | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 Bool -> Bool -> Bool
&& Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
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. HasCallStack => [a] -> Int -> a
!! (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 Inlines
ils) = Html -> Html
H.p (Options -> Inlines -> Html
renderInlines Options
opts Inlines
ils)
        renderBlock (Block
HRule) = Html
H.hr
        renderBlock (Blockquote 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 CodeAttr
attr 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
<> Text
"\n")
          -- add newline because Markdown.pl does
        renderBlock (List Bool
tight (Bullet Char
_) [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 Bool
tight (Numbered NumWrapper
_ Int
n) [Blocks]
items) =
          if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 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 Bool
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 a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
        li Bool
False = Blocks -> Html
toLi
        renderBlockTight :: Block -> Html
renderBlockTight (Para Inlines
zs) = Options -> Inlines -> Html
renderInlines Options
opts Inlines
zs
        renderBlockTight Block
x         = Block -> Html
renderBlock Block
x
        toLi :: Blocks -> Html
toLi 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 = Html
"\n"
        blocksep :: Html
blocksep = Html
"\n"

-- Render a sequence of inlines as HTML5.
renderInlines :: Options -> Inlines -> Html
renderInlines :: Options -> Inlines -> Html
renderInlines Options
opts = (Inline -> Html) -> Inlines -> Html
forall m a. Monoid m => (a -> m) -> Seq a -> m
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 Text
t) = Text -> Html
forall a. ToMarkup a => a -> Html
toHtml Text
t
        renderInline Inline
Space   = Html
" "
        renderInline Inline
SoftBreak
          | Options -> Bool
preserveHardBreaks Options
opts = Html
H.br Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
"\n"
          | Bool
otherwise               = Html
"\n"
          -- this preserves the line breaks in the
          -- markdown document; replace with " " if this isn't wanted.
        renderInline Inline
LineBreak = Html
H.br Html -> Html -> Html
forall a. Semigroup a => a -> a -> a
<> Html
"\n"
        renderInline (Emph 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 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 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 Inlines
ils Text
url 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 Inlines
ils Text
url 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 Text
t) = Text -> Html
forall a. ToMarkup a => a -> Html
H.preEscapedToMarkup Text
t
        renderInline (RawHtml 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' = [Char] -> AttributeValue
forall a. ToValue a => a -> AttributeValue
preEscapedToValue ([Char] -> AttributeValue)
-> (Text -> [Char]) -> Text -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
gentleEscape ([Char] -> [Char]) -> (Text -> [Char]) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

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