{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}

module Yesod.Markdown
  ( Markdown(..)
  -- * Wrappers
  , markdownToHtml
  , markdownToHtmlTrusted
  , markdownToHtmlWithExtensions
  , markdownToHtmlWith
  , markdownFromFile
  -- * Conversions
  , parseMarkdown
  , writePandoc
  , writePandocTrusted
  -- * Option sets
  , yesodDefaultWriterOptions
  , yesodDefaultReaderOptions
  , yesodDefaultExtensions
  -- * Form helper
  , markdownField
  ) where

import Control.Monad ((<=<))
import Data.String (IsString)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Database.Persist (PersistField, SqlType(SqlString))
import Database.Persist.Sql (PersistFieldSql(..))
import System.Directory (doesFileExist)
import Text.Blaze (ToMarkup(toMarkup))
import Text.Blaze.Html (preEscapedToMarkup)
import Text.Hamlet (Html, hamlet)
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Text.Pandoc hiding (handleError)
import Yesod.Core (HandlerSite, RenderMessage)
import Yesod.Core.Widget (toWidget)
import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Types

import qualified Data.ByteString as B
import qualified Data.Text as T

#if !MIN_VERSION_base(4,11,0)
import Data.Semigroup
#endif

newtype Markdown = Markdown { Markdown -> Text
unMarkdown :: 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, 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, ReadPrec [Markdown]
ReadPrec Markdown
Int -> ReadS Markdown
ReadS [Markdown]
(Int -> ReadS Markdown)
-> ReadS [Markdown]
-> ReadPrec Markdown
-> ReadPrec [Markdown]
-> Read Markdown
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Markdown]
$creadListPrec :: ReadPrec [Markdown]
readPrec :: ReadPrec Markdown
$creadPrec :: ReadPrec Markdown
readList :: ReadS [Markdown]
$creadList :: ReadS [Markdown]
readsPrec :: Int -> ReadS Markdown
$creadsPrec :: Int -> ReadS Markdown
Read, PersistValue -> Either Text Markdown
Markdown -> PersistValue
(Markdown -> PersistValue)
-> (PersistValue -> Either Text Markdown) -> PersistField Markdown
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text Markdown
$cfromPersistValue :: PersistValue -> Either Text Markdown
toPersistValue :: Markdown -> PersistValue
$ctoPersistValue :: Markdown -> PersistValue
PersistField, String -> Markdown
(String -> Markdown) -> IsString Markdown
forall a. (String -> a) -> IsString a
fromString :: String -> Markdown
$cfromString :: String -> Markdown
IsString, 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)

instance PersistFieldSql Markdown where
    sqlType :: Proxy Markdown -> SqlType
sqlType Proxy Markdown
_ = SqlType
SqlString

instance ToMarkup Markdown where
    -- | Sanitized by default
    toMarkup :: Markdown -> Markup
toMarkup = Either PandocError Markup -> Markup
forall a. Either PandocError a -> a
handleError (Either PandocError Markup -> Markup)
-> (Markdown -> Either PandocError Markup) -> Markdown -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> Either PandocError Markup
markdownToHtml

markdownField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Markdown
markdownField :: Field m Markdown
markdownField = Field :: forall (m :: * -> *) a.
([Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe a)))
-> FieldViewFunc m a -> Enctype -> Field m a
Field
    { fieldParse :: [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Markdown))
fieldParse = (Text -> Either FormMessage Markdown)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Markdown))
forall (m :: * -> *) site a.
(Monad m, RenderMessage site FormMessage) =>
(Text -> Either FormMessage a)
-> [Text] -> [FileInfo] -> m (Either (SomeMessage site) (Maybe a))
parseHelper ((Text -> Either FormMessage Markdown)
 -> [Text]
 -> [FileInfo]
 -> m (Either (SomeMessage (HandlerSite m)) (Maybe Markdown)))
-> (Text -> Either FormMessage Markdown)
-> [Text]
-> [FileInfo]
-> m (Either (SomeMessage (HandlerSite m)) (Maybe Markdown))
forall a b. (a -> b) -> a -> b
$ Markdown -> Either FormMessage Markdown
forall a b. b -> Either a b
Right (Markdown -> Either FormMessage Markdown)
-> (Text -> Markdown) -> Text -> Either FormMessage Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Markdown
Markdown (Text -> Markdown) -> (Text -> Text) -> Text -> Markdown
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\r')
    , fieldView :: FieldViewFunc m Markdown
fieldView  = \Text
theId Text
name [(Text, Text)]
attrs Either Text Markdown
val Bool
_isReq -> (RY (HandlerSite m) -> Markup) -> WidgetFor (HandlerSite m) ()
forall site a (m :: * -> *).
(ToWidget site a, MonadWidget m, HandlerSite m ~ site) =>
a -> m ()
toWidget
        [hamlet|$newline never
<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unMarkdown val}
|]
    , fieldEnctype :: Enctype
fieldEnctype = Enctype
UrlEncoded
    }

-- | Process Markdown using our options and sanitization
markdownToHtml :: Markdown -> Either PandocError Html
markdownToHtml :: Markdown -> Either PandocError Markup
markdownToHtml = ReaderOptions
-> WriterOptions -> Markdown -> Either PandocError Markup
markdownToHtmlWith
    ReaderOptions
yesodDefaultReaderOptions
    WriterOptions
yesodDefaultWriterOptions

-- | No HTML sanitization
--
-- **NOTE**: Use only with /fully-trusted/ input.
--
markdownToHtmlTrusted :: Markdown -> Either PandocError Html
markdownToHtmlTrusted :: Markdown -> Either PandocError Markup
markdownToHtmlTrusted = (Text -> Text)
-> ReaderOptions
-> WriterOptions
-> Markdown
-> Either PandocError Markup
markdownToHtmlWith' Text -> Text
forall a. a -> a
id
    ReaderOptions
yesodDefaultReaderOptions
    WriterOptions
yesodDefaultWriterOptions

-- | Process markdown with given extensions
--
-- Uses our options, and overrides extensions only.
--
-- > markdownToHtmlWithExtensions githubMarkdownExtensions
--
markdownToHtmlWithExtensions
    :: Extensions
    -> Markdown
    -> Either PandocError Html
markdownToHtmlWithExtensions :: Extensions -> Markdown -> Either PandocError Markup
markdownToHtmlWithExtensions Extensions
exts = ReaderOptions
-> WriterOptions -> Markdown -> Either PandocError Markup
markdownToHtmlWith
    ReaderOptions
yesodDefaultReaderOptions { readerExtensions :: Extensions
readerExtensions = Extensions
exts }
    WriterOptions
yesodDefaultWriterOptions { writerExtensions :: Extensions
writerExtensions = Extensions
exts }

-- | Fully controllable Markdown processing
markdownToHtmlWith
    :: ReaderOptions
    -> WriterOptions
    -> Markdown
    -> Either PandocError Html
markdownToHtmlWith :: ReaderOptions
-> WriterOptions -> Markdown -> Either PandocError Markup
markdownToHtmlWith = (Text -> Text)
-> ReaderOptions
-> WriterOptions
-> Markdown
-> Either PandocError Markup
markdownToHtmlWith' Text -> Text
sanitizeBalance

-- | Internal function, the only way to skip sanitization
markdownToHtmlWith'
    :: (Text -> Text)
    -> ReaderOptions
    -> WriterOptions
    -> Markdown
    -> Either PandocError Html
markdownToHtmlWith' :: (Text -> Text)
-> ReaderOptions
-> WriterOptions
-> Markdown
-> Either PandocError Markup
markdownToHtmlWith' Text -> Text
sanitize ReaderOptions
ropts WriterOptions
wopts =
    (Text -> Text)
-> WriterOptions -> Pandoc -> Either PandocError Markup
writePandocWith Text -> Text
sanitize WriterOptions
wopts (Pandoc -> Either PandocError Markup)
-> (Markdown -> Either PandocError Pandoc)
-> Markdown
-> Either PandocError Markup
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ReaderOptions -> Markdown -> Either PandocError Pandoc
parseMarkdown ReaderOptions
ropts

-- | Returns the empty string if the file does not exist
markdownFromFile :: FilePath -> IO Markdown
markdownFromFile :: String -> IO Markdown
markdownFromFile String
f = do
    Bool
exists <- String -> IO Bool
doesFileExist String
f
    Text -> Markdown
Markdown (Text -> Markdown) -> IO Text -> IO Markdown
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if Bool
exists
        then String -> IO Text
readFileUtf8 String
f
        else Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""

  where
    readFileUtf8 :: FilePath -> IO Text
    readFileUtf8 :: String -> IO Text
readFileUtf8 String
fp = OnDecodeError -> ByteString -> Text
decodeUtf8With OnDecodeError
lenientDecode (ByteString -> Text) -> IO ByteString -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
B.readFile String
fp

writePandoc :: WriterOptions -> Pandoc -> Either PandocError Html
writePandoc :: WriterOptions -> Pandoc -> Either PandocError Markup
writePandoc = (Text -> Text)
-> WriterOptions -> Pandoc -> Either PandocError Markup
writePandocWith Text -> Text
sanitizeBalance
{-# DEPRECATED writePandoc "Don't use this directly" #-}

writePandocTrusted :: WriterOptions -> Pandoc -> Either PandocError Html
writePandocTrusted :: WriterOptions -> Pandoc -> Either PandocError Markup
writePandocTrusted = (Text -> Text)
-> WriterOptions -> Pandoc -> Either PandocError Markup
writePandocWith Text -> Text
forall a. a -> a
id
{-# DEPRECATED writePandocTrusted "Don't use this directly" #-}

writePandocWith
    :: (Text -> Text)
    -> WriterOptions
    -> Pandoc
    -> Either PandocError Html
writePandocWith :: (Text -> Text)
-> WriterOptions -> Pandoc -> Either PandocError Markup
writePandocWith Text -> Text
f WriterOptions
wo
    = (Text -> Markup
forall a. ToMarkup a => a -> Markup
preEscapedToMarkup (Text -> Markup) -> (Text -> Text) -> Text -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
f (Text -> Markup)
-> Either PandocError Text -> Either PandocError Markup
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
    (Either PandocError Text -> Either PandocError Markup)
-> (Pandoc -> Either PandocError Text)
-> Pandoc
-> Either PandocError Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocPure Text -> Either PandocError Text
forall a. PandocPure a -> Either PandocError a
runPure
    (PandocPure Text -> Either PandocError Text)
-> (Pandoc -> PandocPure Text) -> Pandoc -> Either PandocError Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterOptions -> Pandoc -> PandocPure Text
forall (m :: * -> *).
PandocMonad m =>
WriterOptions -> Pandoc -> m Text
writeHtml5String WriterOptions
wo

parseMarkdown :: ReaderOptions -> Markdown -> Either PandocError Pandoc
parseMarkdown :: ReaderOptions -> Markdown -> Either PandocError Pandoc
parseMarkdown ReaderOptions
ro = PandocPure Pandoc -> Either PandocError Pandoc
forall a. PandocPure a -> Either PandocError a
runPure (PandocPure Pandoc -> Either PandocError Pandoc)
-> (Markdown -> PandocPure Pandoc)
-> Markdown
-> Either PandocError Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderOptions -> Text -> PandocPure Pandoc
forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Text -> m Pandoc
readMarkdown ReaderOptions
ro (Text -> PandocPure Pandoc)
-> (Markdown -> Text) -> Markdown -> PandocPure Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Markdown -> Text
unMarkdown
{-# DEPRECATED parseMarkdown "Don't use this directly" #-}

-- | Defaults minus WrapText, plus our extensions
yesodDefaultWriterOptions :: WriterOptions
yesodDefaultWriterOptions :: WriterOptions
yesodDefaultWriterOptions = WriterOptions
forall a. Default a => a
def
    { writerWrapText :: WrapOption
writerWrapText = WrapOption
WrapNone
    , writerExtensions :: Extensions
writerExtensions = [Extension] -> Extensions
extensionsFromList [Extension]
yesodDefaultExtensions
    }

-- | Defaults plus our extensions, see @'yesodDefaultExtensions'@
yesodDefaultReaderOptions :: ReaderOptions
yesodDefaultReaderOptions :: ReaderOptions
yesodDefaultReaderOptions = ReaderOptions
forall a. Default a => a
def
    { readerExtensions :: Extensions
readerExtensions = [Extension] -> Extensions
extensionsFromList [Extension]
yesodDefaultExtensions
    }

-- | @raw_html@ and @auto_identifiers@
yesodDefaultExtensions :: [Extension]
yesodDefaultExtensions :: [Extension]
yesodDefaultExtensions =
    [ Extension
Ext_raw_html
    , Extension
Ext_auto_identifiers
    ]

-- | Unsafely handle a @'PandocError'@
--
-- This is analagous to pandoc-1 behavior, and is required in a pure context
-- such as the @'ToMarkup'@ instance.
--
handleError :: Either PandocError a -> a
handleError :: Either PandocError a -> a
handleError = (PandocError -> a) -> (a -> a) -> Either PandocError a -> a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> (PandocError -> String) -> PandocError -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PandocError -> String
forall a. Show a => a -> String
show) a -> a
forall a. a -> a
id