{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RankNTypes #-}
module Text.Markdown
    ( -- * Functions
      markdown
      -- * Settings
    , MarkdownSettings
    , defaultMarkdownSettings
    , msXssProtect
    , msStandaloneHtml
    , msFencedHandlers
    , msBlockCodeRenderer
    , msLinkNewTab
    , msBlankBeforeBlockquote
    , msBlockFilter
    , msAddHeadingId
    , setNoFollowExternal
      -- * Newtype
    , Markdown (..)
      -- * Fenced handlers
    , FencedHandler (..)
    , codeFencedHandler
    , htmlFencedHandler
      -- * Convenience re-exports
    , def
    ) where

import Control.Arrow ((&&&))
import Text.Markdown.Inline
import Text.Markdown.Block
import Text.Markdown.Types
import Prelude hiding (sequence, takeWhile)
import Data.Char (isAlphaNum)
import Data.Default (Default (..))
import Data.List (intercalate, isInfixOf)
import Data.Maybe (isJust)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy as TL
import Text.Blaze (toValue)
import Text.Blaze.Html (ToMarkup (..), Html)
import Text.Blaze.Html.Renderer.Text (renderHtml)
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Monoid (Monoid (mappend, mempty, mconcat), (<>))
import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as HA
import Text.HTML.SanitizeXSS (sanitizeBalance)
import qualified Data.Map as Map
import Data.String (IsString)
import Data.Semigroup (Semigroup)

-- | A newtype wrapper providing a @ToHtml@ instance.
newtype Markdown = Markdown TL.Text
  deriving(Markdown -> Markdown -> Bool
(Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool) -> Eq Markdown
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Markdown -> Markdown -> Bool
$c/= :: Markdown -> Markdown -> Bool
== :: Markdown -> Markdown -> Bool
$c== :: Markdown -> Markdown -> Bool
Eq, Eq Markdown
Eq Markdown
-> (Markdown -> Markdown -> Ordering)
-> (Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Bool)
-> (Markdown -> Markdown -> Markdown)
-> (Markdown -> Markdown -> Markdown)
-> Ord Markdown
Markdown -> Markdown -> Bool
Markdown -> Markdown -> Ordering
Markdown -> Markdown -> Markdown
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Markdown -> Markdown -> Markdown
$cmin :: Markdown -> Markdown -> Markdown
max :: Markdown -> Markdown -> Markdown
$cmax :: Markdown -> Markdown -> Markdown
>= :: Markdown -> Markdown -> Bool
$c>= :: Markdown -> Markdown -> Bool
> :: Markdown -> Markdown -> Bool
$c> :: Markdown -> Markdown -> Bool
<= :: Markdown -> Markdown -> Bool
$c<= :: Markdown -> Markdown -> Bool
< :: Markdown -> Markdown -> Bool
$c< :: Markdown -> Markdown -> Bool
compare :: Markdown -> Markdown -> Ordering
$ccompare :: Markdown -> Markdown -> Ordering
$cp1Ord :: Eq Markdown
Ord, Semigroup Markdown
Markdown
Semigroup Markdown
-> Markdown
-> (Markdown -> Markdown -> Markdown)
-> ([Markdown] -> Markdown)
-> Monoid Markdown
[Markdown] -> Markdown
Markdown -> Markdown -> Markdown
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Markdown] -> Markdown
$cmconcat :: [Markdown] -> Markdown
mappend :: Markdown -> Markdown -> Markdown
$cmappend :: Markdown -> Markdown -> Markdown
mempty :: Markdown
$cmempty :: Markdown
$cp1Monoid :: Semigroup Markdown
Monoid, b -> Markdown -> Markdown
NonEmpty Markdown -> Markdown
Markdown -> Markdown -> Markdown
(Markdown -> Markdown -> Markdown)
-> (NonEmpty Markdown -> Markdown)
-> (forall b. Integral b => b -> Markdown -> Markdown)
-> Semigroup Markdown
forall b. Integral b => b -> Markdown -> Markdown
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Markdown -> Markdown
$cstimes :: forall b. Integral b => b -> Markdown -> Markdown
sconcat :: NonEmpty Markdown -> Markdown
$csconcat :: NonEmpty Markdown -> Markdown
<> :: Markdown -> Markdown -> Markdown
$c<> :: Markdown -> Markdown -> Markdown
Semigroup, String -> Markdown
(String -> Markdown) -> IsString Markdown
forall a. (String -> a) -> IsString a
fromString :: String -> Markdown
$cfromString :: String -> Markdown
IsString, Int -> Markdown -> ShowS
[Markdown] -> ShowS
Markdown -> String
(Int -> Markdown -> ShowS)
-> (Markdown -> String) -> ([Markdown] -> ShowS) -> Show Markdown
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Markdown] -> ShowS
$cshowList :: [Markdown] -> ShowS
show :: Markdown -> String
$cshow :: Markdown -> String
showsPrec :: Int -> Markdown -> ShowS
$cshowsPrec :: Int -> Markdown -> ShowS
Show)

instance ToMarkup Markdown where
    toMarkup :: Markdown -> Markup
toMarkup (Markdown Text
t) = MarkdownSettings -> Text -> Markup
markdown MarkdownSettings
forall a. Default a => a
def Text
t

-- | Convert the given textual markdown content to HTML.
--
-- >>> :set -XOverloadedStrings
-- >>> import Text.Blaze.Html.Renderer.Text
-- >>> renderHtml $ markdown def "# Hello World!"
-- "<h1>Hello World!</h1>"
--
-- >>> renderHtml $ markdown def { msXssProtect = False } "<script>alert('evil')</script>"
-- "<script>alert('evil')</script>"
markdown :: MarkdownSettings -> TL.Text -> Html
markdown :: MarkdownSettings -> Text -> Markup
markdown MarkdownSettings
ms Text
tl =
       Markup -> Markup
sanitize
     (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ ConduitT () Void Identity Markup -> Markup
forall r. ConduitT () Void Identity r -> r
runConduitPure
     (ConduitT () Void Identity Markup -> Markup)
-> ConduitT () Void Identity Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Block Markup] -> ConduitT () (Block Markup) Identity ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList [Block Markup]
blocksH
    ConduitT () (Block Markup) Identity ()
-> ConduitM (Block Markup) Void Identity Markup
-> ConduitT () Void Identity Markup
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| MarkdownSettings -> ConduitM (Block Markup) Markup Identity ()
forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM (Block Markup) Markup m ()
toHtmlB MarkdownSettings
ms
    ConduitM (Block Markup) Markup Identity ()
-> ConduitM Markup Void Identity Markup
-> ConduitM (Block Markup) Void Identity Markup
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Markup -> Markup -> Markup)
-> Markup -> ConduitM Markup Void Identity Markup
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold Markup -> Markup -> Markup
forall a. Monoid a => a -> a -> a
mappend Markup
forall a. Monoid a => a
mempty
  where
    sanitize :: Markup -> Markup
sanitize
        | MarkdownSettings -> Bool
msXssProtect MarkdownSettings
ms = Text -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToMarkup (Text -> Markup) -> (Markup -> Text) -> Markup -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sanitizeBalance (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Text
renderHtml
        | Bool
otherwise = Markup -> Markup
forall a. a -> a
id
    blocksH :: [Block Html]
    blocksH :: [Block Markup]
blocksH = [Block Text] -> [Block Markup]
processBlocks [Block Text]
blocks

    blocks :: [Block Text]
    blocks :: [Block Text]
blocks = ConduitT () Void Identity [Block Text] -> [Block Text]
forall r. ConduitT () Void Identity r -> r
runConduitPure
           (ConduitT () Void Identity [Block Text] -> [Block Text])
-> ConduitT () Void Identity [Block Text] -> [Block Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> ConduitT () Text Identity ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList (Text -> [Text]
TL.toChunks Text
tl)
          ConduitT () Text Identity ()
-> ConduitM Text Void Identity [Block Text]
-> ConduitT () Void Identity [Block Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| MarkdownSettings -> ConduitM Text (Block Text) Identity ()
forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM Text (Block Text) m ()
toBlocks MarkdownSettings
ms
          ConduitM Text (Block Text) Identity ()
-> ConduitM (Block Text) Void Identity [Block Text]
-> ConduitM Text Void Identity [Block Text]
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitM (Block Text) Void Identity [Block Text]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume

    processBlocks :: [Block Text] -> [Block Html]
    processBlocks :: [Block Text] -> [Block Markup]
processBlocks = (Block [Inline] -> Block Markup)
-> [Block [Inline]] -> [Block Markup]
forall a b. (a -> b) -> [a] -> [b]
map (([Inline] -> Markup) -> Block [Inline] -> Block Markup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Inline] -> Markup) -> Block [Inline] -> Block Markup)
-> ([Inline] -> Markup) -> Block [Inline] -> Block Markup
forall a b. (a -> b) -> a -> b
$ MarkdownSettings -> [Inline] -> Markup
toHtmlI MarkdownSettings
ms)
                  ([Block [Inline]] -> [Block Markup])
-> ([Block Text] -> [Block [Inline]])
-> [Block Text]
-> [Block Markup]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarkdownSettings -> [Block [Inline]] -> [Block [Inline]]
msBlockFilter MarkdownSettings
ms
                  ([Block [Inline]] -> [Block [Inline]])
-> ([Block Text] -> [Block [Inline]])
-> [Block Text]
-> [Block [Inline]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block [[Inline]] -> Block [Inline])
-> [Block [[Inline]]] -> [Block [Inline]]
forall a b. (a -> b) -> [a] -> [b]
map (([[Inline]] -> [Inline]) -> Block [[Inline]] -> Block [Inline]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([[Inline]] -> [Inline]) -> Block [[Inline]] -> Block [Inline])
-> ([[Inline]] -> [Inline]) -> Block [[Inline]] -> Block [Inline]
forall a b. (a -> b) -> a -> b
$ [Inline] -> [[Inline]] -> [Inline]
forall a. [a] -> [[a]] -> [a]
intercalate [Text -> Inline
InlineHtml Text
"<br>"])
                  ([Block [[Inline]]] -> [Block [Inline]])
-> ([Block Text] -> [Block [[Inline]]])
-> [Block Text]
-> [Block [Inline]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block [Text] -> Block [[Inline]])
-> [Block [Text]] -> [Block [[Inline]]]
forall a b. (a -> b) -> [a] -> [b]
map (([Text] -> [[Inline]]) -> Block [Text] -> Block [[Inline]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Text] -> [[Inline]]) -> Block [Text] -> Block [[Inline]])
-> ([Text] -> [[Inline]]) -> Block [Text] -> Block [[Inline]]
forall a b. (a -> b) -> a -> b
$ (Text -> [Inline]) -> [Text] -> [[Inline]]
forall a b. (a -> b) -> [a] -> [b]
map ((Text -> [Inline]) -> [Text] -> [[Inline]])
-> (Text -> [Inline]) -> [Text] -> [[Inline]]
forall a b. (a -> b) -> a -> b
$ RefMap -> Text -> [Inline]
toInline RefMap
refs)
                  ([Block [Text]] -> [Block [[Inline]]])
-> ([Block Text] -> [Block [Text]])
-> [Block Text]
-> [Block [[Inline]]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block Text -> Block [Text]) -> [Block Text] -> [Block [Text]]
forall a b. (a -> b) -> [a] -> [b]
map Block Text -> Block [Text]
toBlockLines

    refs :: RefMap
refs =
        [RefMap] -> RefMap
forall (f :: * -> *) k a.
(Foldable f, Ord k) =>
f (Map k a) -> Map k a
Map.unions ([RefMap] -> RefMap) -> [RefMap] -> RefMap
forall a b. (a -> b) -> a -> b
$ (Block Text -> RefMap) -> [Block Text] -> [RefMap]
forall a b. (a -> b) -> [a] -> [b]
map Block Text -> RefMap
forall inline. Block inline -> RefMap
toRef [Block Text]
blocks
      where
        toRef :: Block inline -> RefMap
toRef (BlockReference Text
x Text
y) = Text -> Text -> RefMap
forall k a. k -> a -> Map k a
Map.singleton Text
x Text
y
        toRef Block inline
_ = RefMap
forall k a. Map k a
Map.empty

data MState = NoState | InList ListType

toHtmlB :: Monad m => MarkdownSettings -> ConduitM (Block Html) Html m ()
toHtmlB :: MarkdownSettings -> ConduitM (Block Markup) Markup m ()
toHtmlB MarkdownSettings
ms =
    MState -> ConduitM (Block Markup) Markup m ()
forall (m :: * -> *).
Monad m =>
MState -> ConduitT (Block Markup) Markup m ()
loop MState
NoState
  where
    loop :: MState -> ConduitT (Block Markup) Markup m ()
loop MState
state = ConduitT (Block Markup) Markup m (Maybe (Block Markup))
forall (m :: * -> *) i. Monad m => Consumer i m (Maybe i)
await ConduitT (Block Markup) Markup m (Maybe (Block Markup))
-> (Maybe (Block Markup) -> ConduitT (Block Markup) Markup m ())
-> ConduitT (Block Markup) Markup m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConduitT (Block Markup) Markup m ()
-> (Block Markup -> ConduitT (Block Markup) Markup m ())
-> Maybe (Block Markup)
-> ConduitT (Block Markup) Markup m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
        (MState -> ConduitT (Block Markup) Markup m ()
forall (m :: * -> *) i. Monad m => MState -> ConduitT i Markup m ()
closeState MState
state)
        (\Block Markup
x -> do
            MState
state' <- MState -> Block Markup -> ConduitT (Block Markup) Markup m MState
forall (m :: * -> *) inline i.
Monad m =>
MState -> Block inline -> ConduitT i Markup m MState
getState MState
state Block Markup
x
            Markup -> ConduitT (Block Markup) Markup m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Markup -> ConduitT (Block Markup) Markup m ())
-> Markup -> ConduitT (Block Markup) Markup m ()
forall a b. (a -> b) -> a -> b
$ Block Markup -> Markup
go Block Markup
x
            MState -> ConduitT (Block Markup) Markup m ()
loop MState
state')

    closeState :: MState -> ConduitT i Markup m ()
closeState MState
NoState = () -> ConduitT i Markup m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    closeState (InList ListType
Unordered) = Markup -> ConduitT i Markup m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Markup -> ConduitT i Markup m ())
-> Markup -> ConduitT i Markup m ()
forall a b. (a -> b) -> a -> b
$ Text -> Markup
escape Text
"</ul>"
    closeState (InList ListType
Ordered) = Markup -> ConduitT i Markup m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Markup -> ConduitT i Markup m ())
-> Markup -> ConduitT i Markup m ()
forall a b. (a -> b) -> a -> b
$ Text -> Markup
escape Text
"</ol>"

    getState :: MState -> Block inline -> ConduitT i Markup m MState
getState MState
NoState (BlockList ListType
ltype Either inline [Block inline]
_) = do
        Markup -> ConduitT i Markup m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield (Markup -> ConduitT i Markup m ())
-> Markup -> ConduitT i Markup m ()
forall a b. (a -> b) -> a -> b
$ Text -> Markup
escape (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$
            case ListType
ltype of
                ListType
Unordered -> Text
"<ul>"
                ListType
Ordered -> Text
"<ol>"
        MState -> ConduitT i Markup m MState
forall (m :: * -> *) a. Monad m => a -> m a
return (MState -> ConduitT i Markup m MState)
-> MState -> ConduitT i Markup m MState
forall a b. (a -> b) -> a -> b
$ ListType -> MState
InList ListType
ltype
    getState MState
NoState Block inline
_ = MState -> ConduitT i Markup m MState
forall (m :: * -> *) a. Monad m => a -> m a
return MState
NoState
    getState state :: MState
state@(InList ListType
lt1) b :: Block inline
b@(BlockList ListType
lt2 Either inline [Block inline]
_)
        | ListType
lt1 ListType -> ListType -> Bool
forall a. Eq a => a -> a -> Bool
== ListType
lt2 = MState -> ConduitT i Markup m MState
forall (m :: * -> *) a. Monad m => a -> m a
return MState
state
        | Bool
otherwise = MState -> ConduitT i Markup m ()
forall (m :: * -> *) i. Monad m => MState -> ConduitT i Markup m ()
closeState MState
state ConduitT i Markup m ()
-> ConduitT i Markup m MState -> ConduitT i Markup m MState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MState -> Block inline -> ConduitT i Markup m MState
getState MState
NoState Block inline
b
    getState state :: MState
state@(InList ListType
_) Block inline
_ = MState -> ConduitT i Markup m ()
forall (m :: * -> *) i. Monad m => MState -> ConduitT i Markup m ()
closeState MState
state ConduitT i Markup m ()
-> ConduitT i Markup m MState -> ConduitT i Markup m MState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MState -> ConduitT i Markup m MState
forall (m :: * -> *) a. Monad m => a -> m a
return MState
NoState

    go :: Block Markup -> Markup
go (BlockPara Markup
h) = Markup -> Markup
H.p Markup
h
    go (BlockPlainText Markup
h) = Markup
h
    go (BlockList ListType
_ (Left Markup
h)) = Markup -> Markup
H.li Markup
h
    go (BlockList ListType
_ (Right [Block Markup]
bs)) = Markup -> Markup
H.li (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Block Markup] -> Markup
forall (t :: * -> *). Foldable t => t (Block Markup) -> Markup
blocksToHtml [Block Markup]
bs
    go (BlockHtml Text
t) = Text -> Markup
escape Text
t
    go (BlockCode Maybe Text
a Text
b) = MarkdownSettings -> Maybe Text -> (Text, Markup) -> Markup
msBlockCodeRenderer MarkdownSettings
ms Maybe Text
a (Text -> Text
forall a. a -> a
id (Text -> Text) -> (Text -> Markup) -> Text -> (Text, Markup)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Text -> Markup
forall a. ToMarkup a => a -> Markup
toMarkup (Text -> (Text, Markup)) -> Text -> (Text, Markup)
forall a b. (a -> b) -> a -> b
$ Text
b)
    go (BlockQuote [Block Markup]
bs) = Markup -> Markup
H.blockquote (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Block Markup] -> Markup
forall (t :: * -> *). Foldable t => t (Block Markup) -> Markup
blocksToHtml [Block Markup]
bs
    go Block Markup
BlockRule = Markup
H.hr
    go (BlockHeading Int
level Markup
h)
        | MarkdownSettings -> Bool
msAddHeadingId MarkdownSettings
ms = Int -> Markup -> Markup
forall a. (Eq a, Num a) => a -> Markup -> Markup
wrap Int
level (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.id (Markup -> AttributeValue
clean Markup
h) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
h
        | Bool
otherwise         = Int -> Markup -> Markup
forall a. (Eq a, Num a) => a -> Markup -> Markup
wrap Int
level Markup
h
      where
       wrap :: a -> Markup -> Markup
wrap a
1 = Markup -> Markup
H.h1
       wrap a
2 = Markup -> Markup
H.h2
       wrap a
3 = Markup -> Markup
H.h3
       wrap a
4 = Markup -> Markup
H.h4
       wrap a
5 = Markup -> Markup
H.h5
       wrap a
_ = Markup -> Markup
H.h6

       isValidChar :: Char -> Bool
isValidChar Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf [Char
c] String
"-_:."

       clean :: Markup -> AttributeValue
clean = Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
toValue (Text -> AttributeValue)
-> (Markup -> Text) -> Markup -> AttributeValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
TL.filter Char -> Bool
isValidChar (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text -> Text
TL.replace Text
" " Text
"-") (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toLower (Text -> Text) -> (Markup -> Text) -> Markup -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markup -> Text
renderHtml



    go BlockReference{} = () -> Markup
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    blocksToHtml :: t (Block Markup) -> Markup
blocksToHtml t (Block Markup)
bs = ConduitT () Void Identity Markup -> Markup
forall r. ConduitT () Void Identity r -> r
runConduitPure (ConduitT () Void Identity Markup -> Markup)
-> ConduitT () Void Identity Markup -> Markup
forall a b. (a -> b) -> a -> b
$ (Block Markup -> ConduitT () (Block Markup) Identity ())
-> t (Block Markup) -> ConduitT () (Block Markup) Identity ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Block Markup -> ConduitT () (Block Markup) Identity ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield t (Block Markup)
bs ConduitT () (Block Markup) Identity ()
-> ConduitM (Block Markup) Void Identity Markup
-> ConduitT () Void Identity Markup
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| MarkdownSettings -> ConduitM (Block Markup) Markup Identity ()
forall (m :: * -> *).
Monad m =>
MarkdownSettings -> ConduitM (Block Markup) Markup m ()
toHtmlB MarkdownSettings
ms ConduitM (Block Markup) Markup Identity ()
-> ConduitM Markup Void Identity Markup
-> ConduitM (Block Markup) Void Identity Markup
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (Markup -> Markup -> Markup)
-> Markup -> ConduitM Markup Void Identity Markup
forall (m :: * -> *) b a o.
Monad m =>
(b -> a -> b) -> b -> ConduitT a o m b
CL.fold Markup -> Markup -> Markup
forall a. Monoid a => a -> a -> a
mappend Markup
forall a. Monoid a => a
mempty

escape :: Text -> Html
escape :: Text -> Markup
escape = Text -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToMarkup

toHtmlI :: MarkdownSettings -> [Inline] -> Html
toHtmlI :: MarkdownSettings -> [Inline] -> Markup
toHtmlI MarkdownSettings
ms [Inline]
is0
    | MarkdownSettings -> Bool
msXssProtect MarkdownSettings
ms = Text -> Markup
escape (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Text
sanitizeBalance (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text
TL.toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Markup -> Text
renderHtml Markup
final
    | Bool
otherwise = Markup
final
  where
    final :: Markup
final = [Inline] -> Markup
gos [Inline]
is0
    gos :: [Inline] -> Markup
gos = [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat ([Markup] -> Markup)
-> ([Inline] -> [Markup]) -> [Inline] -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Markup) -> [Inline] -> [Markup]
forall a b. (a -> b) -> [a] -> [b]
map Inline -> Markup
go

    go :: Inline -> Markup
go (InlineText Text
t) = Text -> Markup
forall a. ToMarkup a => a -> Markup
toMarkup Text
t
    go (InlineItalic [Inline]
is) = Markup -> Markup
H.i (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Inline] -> Markup
gos [Inline]
is
    go (InlineBold [Inline]
is) = Markup -> Markup
H.b (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Inline] -> Markup
gos [Inline]
is
    go (InlineCode Text
t) = Markup -> Markup
H.code (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
forall a. ToMarkup a => a -> Markup
toMarkup Text
t
    go (InlineLink Text
url Maybe Text
mtitle [Inline]
content) =
        Markup -> Markup
H.a
        (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url)
        (Markup -> Markup) -> (Bool, Attribute) -> Markup -> Markup
forall h. Attributable h => h -> (Bool, Attribute) -> h
H.!? (MarkdownSettings -> Bool
msLinkNewTab MarkdownSettings
ms, AttributeValue -> Attribute
HA.target AttributeValue
"_blank")
        (Markup -> Markup) -> (Bool, Attribute) -> Markup -> Markup
forall h. Attributable h => h -> (Bool, Attribute) -> h
H.!? (MarkdownSettings -> Bool
msNoFollowExternal MarkdownSettings
ms Bool -> Bool -> Bool
&& Text -> Bool
isExternalLink Text
url, AttributeValue -> Attribute
HA.rel AttributeValue
"nofollow")
        (Markup -> Markup) -> (Bool, Attribute) -> Markup -> Markup
forall h. Attributable h => h -> (Bool, Attribute) -> h
H.!? (Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
mtitle, AttributeValue -> Attribute
HA.title (AttributeValue -> Attribute) -> AttributeValue -> Attribute
forall a b. (a -> b) -> a -> b
$ AttributeValue
-> (Text -> AttributeValue) -> Maybe Text -> AttributeValue
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> AttributeValue
forall a. HasCallStack => String -> a
error String
"impossible") Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Maybe Text
mtitle)
        (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Inline] -> Markup
gos [Inline]
content
    go (InlineImage Text
url Maybe Text
Nothing Text
content) = Markup
H.img Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.src (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url) Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.alt (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
content)
    go (InlineImage Text
url (Just Text
title) Text
content) = Markup
H.img Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.src (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
url) Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.alt (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
content) Markup -> Attribute -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.title (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue Text
title)
    go (InlineHtml Text
t) = Text -> Markup
escape Text
t
    go (InlineFootnoteRef Integer
x) = let ishown :: Text
ishown = String -> Text
TL.pack (Integer -> String
forall a. Show a => a -> String
show Integer
x)
                                in Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Text
"#footnote-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown)
                                       (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.id (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Text
"ref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
forall a. ToMarkup a => a -> Markup
H.toHtml (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"
    go (InlineFootnote Integer
x) = let ishown :: Text
ishown = String -> Text
TL.pack (Integer -> String
forall a. Show a => a -> String
show Integer
x)
                             in Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.href (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Text
"#ref-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown)
                                    (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
H.! AttributeValue -> Attribute
HA.id (Text -> AttributeValue
forall a. ToValue a => a -> AttributeValue
H.toValue (Text -> AttributeValue) -> Text -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Text
"footnote-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Text -> Markup
forall a. ToMarkup a => a -> Markup
H.toHtml (Text -> Markup) -> Text -> Markup
forall a b. (a -> b) -> a -> b
$ Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ishown Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

-- | For external links, add the rel="nofollow" attribute
--
-- @since 0.1.16
setNoFollowExternal :: MarkdownSettings -> MarkdownSettings
setNoFollowExternal :: MarkdownSettings -> MarkdownSettings
setNoFollowExternal MarkdownSettings
ms = MarkdownSettings
ms { msNoFollowExternal :: Bool
msNoFollowExternal = Bool
True }

-- | Is the given URL an external link?
isExternalLink :: Text -> Bool
isExternalLink :: Text -> Bool
isExternalLink = Text -> Text -> Bool
T.isInfixOf Text
"//"