module Yesod.Markdown
( Markdown(..)
, markdownToHtml
, markdownToHtmlTrusted
, markdownFromFile
, parseMarkdown
, writePandoc
, writePandocTrusted
, yesodDefaultWriterOptions
, yesodDefaultParserState
, markdownField
)
where
import Yesod.Form (ToField(..), areq, aopt)
import Yesod.Core (RenderMessage, SomeMessage(..))
import Yesod.Form.Types
import Yesod.Widget (toWidget)
import Text.Hamlet (hamlet, Html)
import Database.Persist (PersistField)
import Text.Blaze (preEscapedString, preEscapedText)
import Text.Pandoc
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Data.Monoid (Monoid)
import Data.String (IsString)
import System.Directory (doesFileExist)
import qualified Data.Text as T
newtype Markdown = Markdown String
deriving (Eq, Ord, Show, Read, PersistField, IsString, Monoid)
instance ToField Markdown master where
toField = areq markdownField
instance ToField (Maybe Markdown) master where
toField = aopt markdownField
markdownField :: RenderMessage master FormMessage => Field sub master Markdown
markdownField = Field
{ fieldParse = blank $ Right . Markdown . unlines . lines' . T.unpack
, fieldView = \theId name attrs val _isReq -> toWidget
[hamlet|
<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unMarkdown val}
|]
}
where
unMarkdown :: Markdown -> T.Text
unMarkdown (Markdown s) = T.pack s
lines' :: String -> [String]
lines' = map go . lines
go [] = []
go ('\r':xs) = go xs
go (x:xs) = x : go xs
blank :: (Monad m, RenderMessage master FormMessage)
=> (T.Text -> Either FormMessage a)
-> [T.Text]
-> m (Either (SomeMessage master) (Maybe a))
blank _ [] = return $ Right Nothing
blank _ ("":_) = return $ Right Nothing
blank f (x:_) = return $ either (Left . SomeMessage) (Right . Just) $ f x
markdownToHtml :: Markdown -> Html
markdownToHtml = writePandoc yesodDefaultWriterOptions
. parseMarkdown yesodDefaultParserState
markdownToHtmlTrusted :: Markdown -> Html
markdownToHtmlTrusted = writePandocTrusted yesodDefaultWriterOptions
. parseMarkdown yesodDefaultParserState
markdownFromFile :: FilePath -> IO Markdown
markdownFromFile f = do
exists <- doesFileExist f
content <- do
if exists
then readFile f
else return ""
return $ Markdown content
writePandoc :: WriterOptions -> Pandoc -> Html
writePandoc wo = preEscapedText . sanitizeBalance . T.pack . writeHtmlString wo
writePandocTrusted :: WriterOptions -> Pandoc -> Html
writePandocTrusted wo = preEscapedString . writeHtmlString wo
parseMarkdown :: ParserState -> Markdown -> Pandoc
parseMarkdown ro (Markdown m) = readMarkdown ro m
yesodDefaultWriterOptions :: WriterOptions
yesodDefaultWriterOptions = defaultWriterOptions
{ writerHtml5 = True
, writerWrapText = False
}
yesodDefaultParserState :: ParserState
yesodDefaultParserState = defaultParserState
{ stateSmart = True
, stateParseRaw = True
}