102 lines
3.7 KiB
Haskell
102 lines
3.7 KiB
Haskell
module Handler.Utils.Pandoc
|
|
( htmlField, htmlFieldSmall
|
|
, renderMarkdownWith, parseMarkdownWith
|
|
, htmlReaderOptions, markdownReaderOptions
|
|
, markdownWriterOptions, htmlWriterOptions
|
|
) where
|
|
|
|
import Import.NoFoundation
|
|
import Handler.Utils.I18n
|
|
|
|
import qualified Data.Text as Text
|
|
import qualified Data.Text.Lazy as LT
|
|
|
|
import Control.Monad.Error.Class (liftEither)
|
|
|
|
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 StoredMarkup
|
|
htmlField = htmlField' HtmlFieldNormal
|
|
htmlFieldSmall = htmlField' HtmlFieldSmall
|
|
|
|
|
|
htmlField' :: MonadLogger m => HtmlFieldKind -> Field m StoredMarkup
|
|
htmlField' fieldKind = Field{..}
|
|
where
|
|
fieldEnctype = UrlEncoded
|
|
|
|
fieldParse ((Text.strip -> t) : _) _ = runExceptT . runMaybeT $ do
|
|
html <- assertM' (not . null . LT.strip . renderHtml) =<< liftEither (parseMarkdown t)
|
|
return StoredMarkup
|
|
{ markupInputFormat = MarkupMarkdown
|
|
, markupInput = fromStrict t
|
|
, markupOutput = html
|
|
}
|
|
fieldParse [] _ = return $ Right Nothing
|
|
|
|
fieldView theId name attrs val isReq = do
|
|
val'
|
|
<- let toMarkdown StoredMarkup{..} = case markupInputFormat of
|
|
MarkupMarkdown -> return $ toStrict markupInput
|
|
MarkupHtml -> renderMarkdown markupOutput
|
|
MarkupPlaintext -> plaintextToMarkdown $ toStrict markupInput
|
|
in either return (maybeT (return mempty) . toMarkdown) val
|
|
|
|
let markdownExplanation = $(i18nWidgetFile "markdown-explanation")
|
|
$(widgetFile "widgets/html-field")
|
|
|
|
parseMarkdown = parseMarkdownWith markdownReaderOptions htmlWriterOptions
|
|
renderMarkdown = renderMarkdownWith htmlReaderOptions markdownWriterOptions
|
|
plaintextToMarkdown = plaintextToMarkdownWith markdownWriterOptions
|
|
|
|
parseMarkdownWith :: P.ReaderOptions -> P.WriterOptions -> Text -> Either (SomeMessage site) Html
|
|
parseMarkdownWith readerOptions writerOptions text =
|
|
bimap pandocError (preEscapedText . sanitizeBalance) . P.runPure $
|
|
P.writeHtml5String writerOptions =<< P.readMarkdown readerOptions text
|
|
where
|
|
pandocError = SomeMessage . tshow
|
|
|
|
renderMarkdownWith :: (MonadLogger m, MonadPlus m) => P.ReaderOptions -> P.WriterOptions -> Html -> m Text
|
|
renderMarkdownWith readerOptions writerOptions html =
|
|
either (\e -> logPandocError e >> mzero) return . P.runPure $
|
|
P.writeMarkdown writerOptions =<< P.readHtml readerOptions (toStrict $ renderHtml html)
|
|
where
|
|
logPandocError = $logErrorS "renderMarkdown" . tshow
|
|
|
|
plaintextToMarkdownWith :: (MonadLogger m, MonadPlus m) => P.WriterOptions -> Text -> m Text
|
|
plaintextToMarkdownWith writerOptions text =
|
|
either (\e -> logPandocError e >> mzero) return . P.runPure $
|
|
P.writeMarkdown writerOptions pandoc
|
|
where
|
|
logPandocError = $logErrorS "renderMarkdown" . tshow
|
|
pandoc = P.Pandoc mempty [P.Plain [P.Str text]]
|
|
|
|
|
|
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
|