module Network.Gitit.Export ( exportFormats ) where
import Text.Pandoc hiding (HTMLMathMethod(..))
import qualified Text.Pandoc as Pandoc
import Text.Pandoc.SelfContained as SelfContained
import Text.Pandoc.Shared (escapeStringUsing, readDataFile)
import Network.Gitit.Server
import Network.Gitit.Framework (pathForPage, getWikiBase)
import Network.Gitit.Util (withTempDir, readFileUTF8)
import Network.Gitit.State (getConfig)
import Network.Gitit.Types
import Network.Gitit.Cache (cacheContents, lookupCache)
import Control.Monad.Trans (liftIO)
import Control.Monad (unless, when)
import Text.XHtml (noHtml)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.UTF8 (fromString)
import System.FilePath ((<.>), (</>), takeDirectory)
import Control.Exception (throwIO)
import System.Environment (getEnvironment)
import System.Exit (ExitCode(..))
import System.IO (openTempFile)
import System.Directory (getCurrentDirectory, setCurrentDirectory, removeFile)
import System.Process (runProcess, waitForProcess)
import Codec.Binary.UTF8.String (encodeString)
import Text.HTML.SanitizeXSS
import qualified Data.Text as T
import Data.List (isPrefixOf)
defaultRespOptions :: WriterOptions
defaultRespOptions = defaultWriterOptions { writerStandalone = True }
respond :: String
-> String
-> (Pandoc -> IO L.ByteString)
-> String
-> Pandoc
-> Handler
respond mimetype ext fn page doc = liftIO (fn doc) >>=
ok . setContentType mimetype .
(if null ext then id else setFilename (page ++ "." ++ ext)) .
toResponseBS B.empty
respondX :: String -> String -> String
-> (WriterOptions -> Pandoc -> IO L.ByteString)
-> WriterOptions -> String -> Pandoc -> Handler
respondX templ mimetype ext fn opts page doc = do
cfg <- getConfig
template' <- liftIO $ getDefaultTemplate (pandocUserData cfg) templ
template <- case template' of
Right t -> return t
Left e -> liftIO $ throwIO e
doc' <- if ext `elem` ["odt","pdf","epub","docx","rtf"]
then fixURLs page doc
else return doc
doc'' <- if ext == "rtf"
then liftIO $ bottomUpM rtfEmbedImage doc'
else return doc'
respond mimetype ext (fn opts{writerTemplate = template
,writerSourceDirectory = repositoryPath cfg
,writerUserDataDir = pandocUserData cfg})
page doc''
respondS :: String -> String -> String -> (WriterOptions -> Pandoc -> String)
-> WriterOptions -> String -> Pandoc -> Handler
respondS templ mimetype ext fn =
respondX templ mimetype ext (\o d -> return $ fromString $ fn o d)
respondSlides :: String -> HTMLSlideVariant -> String -> Pandoc -> Handler
respondSlides templ slideVariant page doc = do
cfg <- getConfig
base' <- getWikiBase
let math = case mathMethod cfg of
MathML -> Pandoc.MathML Nothing
WebTeX u -> Pandoc.WebTeX u
JsMathScript -> Pandoc.JsMath
(Just $ base' ++ "/js/jsMath/easy/load.js")
_ -> Pandoc.PlainMath
let opts' = defaultRespOptions {
writerSlideVariant = slideVariant
,writerIncremental = True
,writerHtml5 = templ == "dzslides"
,writerHTMLMathMethod = math}
Pandoc meta blocks <- fixURLs page doc
let body' = writeHtmlString opts'{writerStandalone = False}
(Pandoc meta blocks)
let body'' = T.unpack
$ (if xssSanitize cfg then sanitizeBalance else id)
$ T.pack body'
variables' <- if mathMethod cfg == MathML
then do
s <- liftIO $ readDataFile (pandocUserData cfg) $
"data"</>"MathMLinHTML.js"
return [("mathml-script", s)]
else return []
template' <- liftIO $ getDefaultTemplate (pandocUserData cfg) templ
template <- case template' of
Right t -> return t
Left e -> liftIO $ throwIO e
dzcore <- if templ == "dzslides"
then do
dztempl <- liftIO $ readDataFile (pandocUserData cfg)
$ "dzslides" </> "template.html"
return $ unlines
$ dropWhile (not . isPrefixOf "<!-- {{{{ dzslides core")
$ lines dztempl
else return ""
let h = writeHtmlString opts'{
writerVariables =
("body",body''):("dzslides-core",dzcore):variables'
,writerTemplate = template
,writerSourceDirectory = repositoryPath cfg
,writerUserDataDir = pandocUserData cfg
} (Pandoc meta [])
h' <- liftIO $ makeSelfContained (pandocUserData cfg) h
ok . setContentType "text/html;charset=UTF-8" .
toResponseBS B.empty $ fromString h'
respondLaTeX :: String -> Pandoc -> Handler
respondLaTeX = respondS "latex" "application/x-latex" "tex"
writeLaTeX defaultRespOptions
respondConTeXt :: String -> Pandoc -> Handler
respondConTeXt = respondS "context" "application/x-context" "tex"
writeConTeXt defaultRespOptions
respondRTF :: String -> Pandoc -> Handler
respondRTF = respondS "rtf" "application/rtf" "rtf"
writeRTF defaultRespOptions
respondRST :: String -> Pandoc -> Handler
respondRST = respondS "rst" "text/plain; charset=utf-8" ""
writeRST defaultRespOptions{writerReferenceLinks = True}
respondMarkdown :: String -> Pandoc -> Handler
respondMarkdown = respondS "markdown" "text/plain; charset=utf-8" ""
writeMarkdown defaultRespOptions{writerReferenceLinks = True}
respondPlain :: String -> Pandoc -> Handler
respondPlain = respondS "plain" "text/plain; charset=utf-8" ""
writePlain defaultRespOptions
respondMan :: String -> Pandoc -> Handler
respondMan = respondS "man" "text/plain; charset=utf-8" ""
writeMan defaultRespOptions
respondTexinfo :: String -> Pandoc -> Handler
respondTexinfo = respondS "texinfo" "application/x-texinfo" "texi"
writeTexinfo defaultRespOptions
respondDocbook :: String -> Pandoc -> Handler
respondDocbook = respondS "docbook" "application/docbook+xml" "xml"
writeDocbook defaultRespOptions
respondOrg :: String -> Pandoc -> Handler
respondOrg = respondS "org" "text/plain; charset=utf-8" ""
writeOrg defaultRespOptions
respondTextile :: String -> Pandoc -> Handler
respondTextile = respondS "textile" "text/plain; charset=utf-8" ""
writeTextile defaultRespOptions
respondAsciiDoc :: String -> Pandoc -> Handler
respondAsciiDoc = respondS "asciidoc" "text/plain; charset=utf-8" ""
writeAsciiDoc defaultRespOptions
respondMediaWiki :: String -> Pandoc -> Handler
respondMediaWiki = respondS "mediawiki" "text/plain; charset=utf-8" ""
writeMediaWiki defaultRespOptions
respondODT :: String -> Pandoc -> Handler
respondODT = respondX "opendocument" "application/vnd.oasis.opendocument.text"
"odt" (writeODT Nothing) defaultRespOptions
respondEPUB :: String -> Pandoc -> Handler
respondEPUB = respondX "html" "application/epub+zip" "epub" (writeEPUB Nothing [])
defaultRespOptions
respondDocx :: String -> Pandoc -> Handler
respondDocx = respondX "native"
"application/vnd.openxmlformats-officedocument.wordprocessingml.document"
"docx" (writeDocx Nothing) defaultRespOptions
runShellCommand :: FilePath
-> Maybe [(String, String)]
-> String
-> [String]
-> IO ExitCode
runShellCommand workingDir environment command optionList = do
(errPath, err) <- openTempFile workingDir "err"
hProcess <- runProcess (encodeString command) (map encodeString optionList)
(Just workingDir) environment Nothing (Just err) (Just err)
status <- waitForProcess hProcess
removeFile errPath
return status
respondPDF :: String -> Pandoc -> Handler
respondPDF page old_pndc = fixURLs page old_pndc >>= \pndc -> do
cfg <- getConfig
unless (pdfExport cfg) $ error "PDF export disabled"
let cacheName = pathForPage page ++ ".export.pdf"
cached <- if useCache cfg
then lookupCache cacheName
else return Nothing
pdf' <- case cached of
Just (_modtime, bs) -> return $ Right (False, L.fromChunks [bs])
Nothing -> liftIO $ withTempDir "gitit-tmp-pdf" $ \tempdir -> do
template' <- liftIO $ getDefaultTemplate (pandocUserData cfg) "latex"
template <- either throwIO return template'
let toc = tableOfContents cfg
let latex = writeLaTeX defaultRespOptions{writerTemplate = template
,writerTableOfContents = toc} pndc
let tempfile = "export" <.> "tex"
curdir <- getCurrentDirectory
setCurrentDirectory tempdir
writeFile tempfile latex
let cmd = "pdflatex"
oldEnv <- getEnvironment
let env = Just $ ("TEXINPUTS",".:" ++
escapeStringUsing [(' ',"\\ "),('"',"\\\"")]
(curdir </> repositoryPath cfg) ++ ":") : oldEnv
let opts = ["-interaction=batchmode", "-no-shell-escape", tempfile]
_ <- runShellCommand tempdir env cmd opts
canary <- runShellCommand tempdir env cmd opts
setCurrentDirectory curdir
case canary of
ExitSuccess -> do pdfBS <- L.readFile (tempdir </> "export" <.> "pdf")
return $ Right (useCache cfg, pdfBS)
ExitFailure n -> do l <- readFileUTF8 (tempdir </> "export" <.> "log")
return $ Left (n, l)
case pdf' of
Left (n,logOutput) -> simpleErrorHandler ("PDF creation failed with code: " ++
show n ++ "\n" ++ logOutput)
Right (needsCaching, pdfBS) -> do
when needsCaching $
cacheContents cacheName $ B.concat . L.toChunks $ pdfBS
ok $ setContentType "application/pdf" $ setFilename (page ++ ".pdf") $
(toResponse noHtml) {rsBody = pdfBS}
fixURLs :: String -> Pandoc -> GititServerPart Pandoc
fixURLs page pndc = do
curdir <- liftIO getCurrentDirectory
cfg <- getConfig
let go (Image ils (url, title)) = Image ils (fixURL url, title)
go x = x
fixURL ('/':url) = curdir </> staticDir cfg </> url
fixURL url = curdir </> repositoryPath cfg </> takeDirectory page </> url
return $ bottomUp go pndc
exportFormats :: Config -> [(String, String -> Pandoc -> Handler)]
exportFormats cfg = if pdfExport cfg
then ("PDF", respondPDF) : rest
else rest
where rest = [ ("LaTeX", respondLaTeX)
, ("ConTeXt", respondConTeXt)
, ("Texinfo", respondTexinfo)
, ("reST", respondRST)
, ("Markdown", respondMarkdown)
, ("Plain text",respondPlain)
, ("MediaWiki", respondMediaWiki)
, ("Org-mode", respondOrg)
, ("Textile", respondTextile)
, ("AsciiDoc", respondAsciiDoc)
, ("Man page", respondMan)
, ("DocBook", respondDocbook)
, ("DZSlides", respondSlides "dzslides" DZSlides)
, ("Slidy", respondSlides "slidy" SlidySlides)
, ("S5", respondSlides "s5" S5Slides)
, ("EPUB", respondEPUB)
, ("ODT", respondODT)
, ("Docx", respondDocx)
, ("RTF", respondRTF) ]