path: root/src/markdown2pdf.hs

module Main where

import Data.List (isInfixOf, intercalate, isPrefixOf)
import Data.Maybe (isNothing)
import qualified Data.ByteString as BS
import Codec.Binary.UTF8.String (decodeString, encodeString)
import Data.ByteString.UTF8 (toString)
import Control.Monad (unless, guard, liftM, when)
import Control.Concurrent (putMVar, takeMVar, newEmptyMVar, forkIO)
import Control.Exception (tryJust, bracket, evaluate)
import Control.Monad.Trans (liftIO)
import System.IO.Error (isAlreadyExistsError)

import System.IO
import System.IO.Error (isDoesNotExistError)
import System.Environment ( getArgs, getProgName )
import qualified Text.Pandoc.UTF8 as UTF8
import System.Exit (ExitCode (..), exitWith)
import System.FilePath
import System.Directory
import System.Process

-- A variant of 'readProcessWithExitCode' that does not
-- cause an error if the output is not UTF-8. (Copied
-- with slight variants from 'System.Process'.)
readProcessWithExitCode'
    :: FilePath                 -- ^ command to run
    -> [String]                 -- ^ any arguments
    -> String                   -- ^ standard input
    -> IO (ExitCode,String,String) -- ^ exitcode, stdout, stderr
readProcessWithExitCode' cmd args input = do
    (Just inh, Just outh, Just errh, pid) <-
        createProcess (proc cmd args){ std_in  = CreatePipe,
                                       std_out = CreatePipe,
                                       std_err = CreatePipe }

    outMVar <- newEmptyMVar

    -- fork off a thread to start consuming stdout
    out  <- liftM toString $ BS.hGetContents outh
    _ <- forkIO $ evaluate (length out) >> putMVar outMVar ()

    -- fork off a thread to start consuming stderr
    err  <- liftM toString $ BS.hGetContents errh
    _ <- forkIO $ evaluate (length err) >> putMVar outMVar ()

    -- now write and flush any input
    when (not (null input)) $ do hPutStr inh input; hFlush inh
    hClose inh -- done with stdin

    -- wait on the output
    takeMVar outMVar
    takeMVar outMVar
    hClose outh

    -- wait on the process
    ex <- waitForProcess pid

    return (ex, out, err)

run :: FilePath -> [String] -> IO (Either String String)
run file opts = do
  (code, out, err) <- readProcessWithExitCode' (encodeString file)
                        (map encodeString opts) ""
  let msg = out ++ err
  case code of
    ExitFailure _ -> return $ Left  $! msg
    ExitSuccess   -> return $ Right $! msg

parsePandocArgs :: [String] -> IO (Maybe ([String], String))
parsePandocArgs args = do
  result <- run "pandoc" $ ["--dump-args"] ++ args
  return $ either error (parse . map trim . lines) result
  where parse []         = Nothing
        parse ("-":[])   = Just ([], "stdin") -- no output or input
        parse ("-":x:xs) = Just (x:xs, dropExtension x) -- no output
        parse ( x :xs)   = Just (xs,   dropExtension x) -- at least output
        --trim = reverse . dropWhile isSpace . reverse . dropWhile isSpace
        trim = takeWhile (/='\r') . dropWhile (=='\r')

runPandoc :: String -> [String] -> FilePath -> IO (Either String FilePath)
runPandoc outputFormat inputsAndArgs output = do
  let texFile = addExtension output "tex"
  result <- run "pandoc" $
    ["-s", "--no-wrap", "-r", "markdown", "-w", outputFormat]
    ++ inputsAndArgs ++ ["-o", texFile]
  return $ either Left (const $ Right texFile) result

runLatexRaw :: String -> FilePath -> IO (Either (Either String String) FilePath)
runLatexRaw latexProgram file = do
  -- we ignore the ExitCode because pdflatex always fails the first time
  run latexProgram ["-halt-on-error", "-interaction", "nonstopmode",
    "-output-directory", takeDirectory file, dropExtension file] >> return ()
  let pdfFile = replaceExtension file "pdf"
  let logFile = replaceExtension file "log"
  txt <- tryJust (guard . isDoesNotExistError)
         (liftM toString $ BS.readFile logFile)
  let  checks = checkLatex $ either (const "") id txt
  case checks of
  -- err  , bib , ref , msg
    (True , _    , _   , msg) -> return $ Left $ Left msg   -- failure
    (False, True , _   , msg) -> runBibtex file >>
                                (return $ Left $ Right msg) -- citations
    (False, _    , True, msg) -> return $ Left $ Right msg  -- references
    (False, False, False, _ ) -> return $ Right pdfFile     -- success

runLatex :: String -> FilePath -> IO (Either String FilePath)
runLatex latexProgram file = step 3
  where
  step n = do
    result <- runLatexRaw latexProgram file
    case result of
      Left (Left err) -> return $ Left err
      Left (Right _) | n > 1  -> step (n-1 :: Int)
      Right _ | n > 2 -> step (n-1 :: Int)
      Left (Right msg) -> return $ Left msg
      Right pdfFile   -> return $ Right pdfFile

checkLatex :: String -> (Bool, Bool, Bool, String)
checkLatex ""  = (True, False, False, "Could not read log file")
checkLatex txt = (err , bib, ref, unlines $! msgs ++ tips)
  where
  xs `oneOf` x = any (flip isInfixOf x) xs
  msgs = dropWhile (not . errorline) $ lines txt
  errorline ('!':_) = True
  errorline _ = False
  tips = checkPackages msgs
  err = any (oneOf ["!", "LaTeX Error:", "Latex Error:"]) msgs
  bib = any (oneOf ["Warning: Citation"
                   ,"Warning: There were undefined citations"]) msgs
  ref = any (oneOf ["Warning: Reference"
                   ,"Warning: Label"
                   ,"Warning: There were undefined references"
                   ]) msgs

checkPackages :: [String] -> [String]
checkPackages = concatMap chks
  where -- for each message, search 'pks' for matches and give a hint
  chks x = concatMap (chk x) pks
  chk x (k,v) = if sub k `isInfixOf` x then tip k v else []
  sub k   = "`" ++ k ++ ".sty' not found"
  tip k v = ["Please install the '" ++ k ++
             "' package from CTAN:", "  " ++ v]
  pks = [("ucs"
         ,"http://www.ctan.org/tex-archive/macros/latex/contrib/unicode/")
        ,("ulem"
         ,"http://www.ctan.org/tex-archive/macros/latex/contrib/misc/")
        ,("graphicx"
         ,"http://www.ctan.org/tex-archive/macros/latex/required/graphics/")
        ,("fancyhdr"
         ,"http://www.ctan.org/tex-archive/macros/latex/contrib/fancyhdr/")
        ,("array"
         ,"http://www.ctan.org/tex-archive/macros/latex/required/tools/")]

runBibtex :: FilePath -> IO (Either String FilePath)
runBibtex file = do
  let auxFile = replaceExtension file "aux"
  result <- run "bibtex" [auxFile]
  return $ either Left (const $ Right auxFile) result

exit :: String -> IO a
exit x = do
  progName <- getProgName
  UTF8.hPutStrLn stderr $ progName ++ ": " ++ x
  exitWith $ ExitFailure 1

saveStdin :: FilePath -> IO (Either String FilePath)
saveStdin file = do
  text <- liftM toString $ BS.getContents
  UTF8.writeFile file text
  fileExist <- doesFileExist (encodeString file)
  case fileExist of
    False -> return $ Left $! "Could not create " ++ file
    True  -> return $ Right file

saveOutput :: FilePath -> FilePath -> IO ()
saveOutput input output = do
  copyFile (encodeString input) (encodeString output)
  UTF8.hPutStrLn stderr $! "Created " ++ output

-- | Perform a function in a temporary directory and clean up.
withTempDir :: FilePath -> (FilePath -> IO a) -> IO a
withTempDir baseName = bracket (createTempDir 0 baseName) removeDirectoryRecursive

-- | Create a temporary directory with a unique name.
createTempDir :: Integer -> FilePath -> IO FilePath
createTempDir num baseName = do
  sysTempDir <- getTemporaryDirectory
  let dirName = sysTempDir </> baseName <.> show num
  liftIO $ catch (createDirectory dirName >> return dirName) $
      \e -> if isAlreadyExistsError e
               then createTempDir (num + 1) baseName
               else ioError e

main :: IO ()
main = withTempDir "pandoc"
  -- run computation
  $ \tmp -> do
    args <- liftM (map decodeString) getArgs
    -- check for invalid arguments and print help message if needed
    let goodopts = ["-f","-r","-N", "-p","-R","-H","-B","-A", "-C","-o","-V"]
    let goodoptslong = ["--from","--read","--strict",
                   "--preserve-tabs","--tab-stop","--parse-raw",
                   "--toc","--table-of-contents", "--xetex", "--luatex",
                   "--number-sections","--include-in-header",
                   "--include-before-body","--include-after-body",
                   "--custom-header","--output",
                   "--template", "--variable",
                   "--no-highlight", "--highlight-style",
                   "--citation-abbreviations", "--old-dashes",
                   "--csl", "--bibliography", "--data-dir", "--listings",
                   "--beamer"]
    let isOpt ('-':_) = True
        isOpt _       = False
    let opts = filter isOpt args
    -- note that a long option can come in this form: --opt=val
    let isGoodopt x = x `elem` (goodopts ++ goodoptslong) ||
                      any (\o -> (o ++ "=") `isPrefixOf` x) goodoptslong
    let markdown2pdfOpts = ["--xetex","--luatex", "--beamer"]
    unless (all isGoodopt opts) $ do
      (code, out, _err) <- readProcessWithExitCode "pandoc" ["--help"] ""
      UTF8.putStrLn "markdown2pdf [OPTIONS] [FILES]\nOptions:"
      UTF8.putStr $ unlines $
                 filter (\l -> any (`isInfixOf` l) goodoptslong) (lines out)
                 ++ map (replicate 24 ' ' ++) markdown2pdfOpts
      exitWith code

    let args' = filter (`notElem` markdown2pdfOpts) args

    -- check for executable files
    let latexProgram = if "--xetex" `elem` opts
                          then "xelatex"
                          else if "--luatex" `elem` opts
                                  then "lualatex"
                                  else "pdflatex"
    let outputFormat = if "--beamer" `elem` opts
                          then "beamer"
                          else "latex"
    let execs = ["pandoc", latexProgram, "bibtex"]
    paths <- mapM findExecutable execs
    let miss = map snd $ filter (isNothing . fst) $ zip paths execs
    unless (null miss) $ exit $! "Could not find " ++ intercalate ", " miss

    -- parse arguments
    -- if no input given, use 'stdin'
    pandocArgs <- parsePandocArgs args'
    (input, output) <- case pandocArgs of
      Nothing      -> exit "Could not parse arguments"
      Just ([],out) -> do
        stdinFile <- saveStdin (replaceDirectory (takeBaseName out) tmp)
        case stdinFile of
          Left err  -> exit err
          Right f   -> return ([f], out)
      -- no need because we'll pass all arguments to pandoc
      Just (_ ,out) -> return ([], out)
    -- run pandoc
    pandocRes <- runPandoc outputFormat (input ++ args') $ replaceDirectory output tmp
    case pandocRes of
      Left err -> exit err
      Right texFile  -> do
        -- run pdflatex
        latexRes <- runLatex latexProgram texFile
        case latexRes of
          Left err      -> exit err
          Right pdfFile -> do
            -- save the output
            saveOutput pdfFile $
              replaceDirectory pdfFile (takeDirectory output)