75 lines
2.4 KiB
Haskell
75 lines
2.4 KiB
Haskell
module Handler.Utils.Pandoc
|
|
( htmlField, htmlFieldSmall
|
|
, htmlReaderOptions, markdownReaderOptions
|
|
, markdownWriterOptions, htmlWriterOptions
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Handler.Utils.I18n
|
|
|
|
import qualified Data.Text as Text
|
|
|
|
import qualified Text.Pandoc as P
|
|
|
|
import Text.Blaze (preEscapedText)
|
|
import Text.Blaze.Html.Renderer.Text (renderHtml)
|
|
import Text.HTML.SanitizeXSS (sanitizeBalance)
|
|
|
|
|
|
data HtmlFieldKind
|
|
= HtmlFieldNormal
|
|
| HtmlFieldSmall
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe HtmlFieldKind
|
|
instance Finite HtmlFieldKind
|
|
|
|
htmlField, htmlFieldSmall :: MonadLogger m => Field m Html
|
|
htmlField = htmlField' HtmlFieldNormal
|
|
htmlFieldSmall = htmlField' HtmlFieldSmall
|
|
|
|
|
|
htmlField' :: MonadLogger m => HtmlFieldKind -> Field m Html
|
|
htmlField' fieldKind = Field{..}
|
|
where
|
|
fieldEnctype = UrlEncoded
|
|
|
|
fieldParse (t : _) _
|
|
= return . fmap (assertM' $ not . null . renderHtml) . parseMarkdown $ Text.strip t
|
|
fieldParse [] _ = return $ Right Nothing
|
|
|
|
fieldView theId name attrs val isReq = do
|
|
val' <- either return (maybeT (return mempty) . renderMarkdown) val
|
|
let markdownExplanation = $(i18nWidgetFile "markdown-explanation")
|
|
$(widgetFile "widgets/html-field")
|
|
|
|
parseMarkdown :: Text -> Either (SomeMessage site) Html
|
|
parseMarkdown text =
|
|
bimap pandocError (preEscapedText . sanitizeBalance) . P.runPure $
|
|
P.writeHtml5String htmlWriterOptions =<< P.readMarkdown markdownReaderOptions text
|
|
where
|
|
pandocError = SomeMessage . tshow
|
|
|
|
renderMarkdown :: (MonadLogger m, MonadPlus m) => Html -> m Text
|
|
renderMarkdown html =
|
|
either (\e -> logPandocError e >> mzero) return . P.runPure $
|
|
P.writeMarkdown markdownWriterOptions =<< P.readHtml htmlReaderOptions (toStrict $ renderHtml html)
|
|
where
|
|
logPandocError = $logErrorS "renderMarkdown" . tshow
|
|
|
|
|
|
htmlReaderOptions, markdownReaderOptions :: P.ReaderOptions
|
|
htmlReaderOptions = markdownReaderOptions
|
|
markdownReaderOptions = def
|
|
{ P.readerExtensions = P.pandocExtensions
|
|
& P.enableExtension P.Ext_hard_line_breaks
|
|
& P.enableExtension P.Ext_autolink_bare_uris
|
|
, P.readerTabStop = 2
|
|
}
|
|
|
|
markdownWriterOptions, htmlWriterOptions :: P.WriterOptions
|
|
markdownWriterOptions = def
|
|
{ P.writerExtensions = P.readerExtensions markdownReaderOptions
|
|
, P.writerTabStop = P.readerTabStop markdownReaderOptions
|
|
}
|
|
htmlWriterOptions = markdownWriterOptions
|