module Yesod.RST
( RST(..)
, rstToHtml
, rstToHtmlTrusted
, rstFromFile
, parseRST
, writePandoc
, writePandocTrusted
, yesodDefaultWriterOptions
, yesodDefaultParserState
, rstField
)
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.Html (preEscapedToMarkup)
import Text.Pandoc
import Text.HTML.SanitizeXSS (sanitizeBalance)
import Data.Monoid (Monoid)
import Data.String (IsString)
import System.Directory (doesFileExist)
import Data.Text (Text, pack, unpack)
newtype RST = RST String
deriving (Eq, Ord, Show, Read, PersistField, IsString, Monoid)
instance ToField RST master where
toField = areq rstField
instance ToField (Maybe RST) master where
toField = aopt rstField
rstField :: RenderMessage master FormMessage => Field sub master RST
rstField = Field
{ fieldParse = \values _ -> (blank $ Right . RST . unlines . lines' . unpack) values
, fieldView = \theId name attrs val _isReq -> toWidget
[hamlet|
<textarea id="#{theId}" name="#{name}" *{attrs}>#{either id unRST val}
|]
, fieldEnctype = UrlEncoded
}
where
unRST :: RST -> Text
unRST (RST s) = pack s
lines' :: String -> [String]
lines' = map (filter (/= '\r')) . lines
blank :: (Monad m, RenderMessage master FormMessage)
=> (Text -> Either FormMessage a) -> [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
rstToHtml :: RST -> Html
rstToHtml = writePandoc yesodDefaultWriterOptions
. parseRST yesodDefaultParserState
rstToHtmlTrusted :: RST -> Html
rstToHtmlTrusted = writePandocTrusted yesodDefaultWriterOptions
. parseRST yesodDefaultParserState
rstFromFile :: FilePath -> IO RST
rstFromFile f = do
exists <- doesFileExist f
content <- do
if exists
then readFile f
else return ""
return $ RST content
writePandoc :: WriterOptions -> Pandoc -> Html
writePandoc wo = preEscapedToMarkup . sanitizeBalance . pack . writeHtmlString wo
writePandocTrusted :: WriterOptions -> Pandoc -> Html
writePandocTrusted wo = preEscapedToMarkup . writeHtmlString wo
parseRST :: ParserState -> RST -> Pandoc
parseRST ro (RST m) = readRST ro m
yesodDefaultWriterOptions :: WriterOptions
yesodDefaultWriterOptions = defaultWriterOptions
{ writerHtml5 = True
, writerWrapText = False
}
yesodDefaultParserState :: ParserState
yesodDefaultParserState = defaultParserState
{ stateSmart = True
, stateParseRaw = True
}