{-# LANGUAGE CPP #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
module Yesod.Markdown
( Markdown(..)
, markdownToHtml
, markdownToHtmlTrusted
, markdownToHtmlWithExtensions
, markdownToHtmlWith
, markdownFromFile
, parseMarkdown
, writePandoc
, writePandocTrusted
, yesodDefaultWriterOptions
, yesodDefaultReaderOptions
, yesodDefaultExtensions
, 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
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
}
markdownToHtml :: Markdown -> Either PandocError Html
markdownToHtml :: Markdown -> Either PandocError Markup
markdownToHtml = ReaderOptions
-> WriterOptions -> Markdown -> Either PandocError Markup
markdownToHtmlWith
ReaderOptions
yesodDefaultReaderOptions
WriterOptions
yesodDefaultWriterOptions
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
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 }
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
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
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" #-}
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
}
yesodDefaultReaderOptions :: ReaderOptions
yesodDefaultReaderOptions :: ReaderOptions
yesodDefaultReaderOptions = ReaderOptions
forall a. Default a => a
def
{ readerExtensions :: Extensions
readerExtensions = [Extension] -> Extensions
extensionsFromList [Extension]
yesodDefaultExtensions
}
yesodDefaultExtensions :: [Extension]
yesodDefaultExtensions :: [Extension]
yesodDefaultExtensions =
[ Extension
Ext_raw_html
, Extension
Ext_auto_identifiers
]
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