diff options
Diffstat (limited to 'Text/Pandoc')
| -rw-r--r-- | Text/Pandoc/ODT.hs | 144 | ||||
| -rw-r--r-- | Text/Pandoc/Shared.hs | 26 | ||||
| -rw-r--r-- | Text/Pandoc/TH.hs | 14 |
3 files changed, 68 insertions, 116 deletions
diff --git a/Text/Pandoc/ODT.hs b/Text/Pandoc/ODT.hs index 8c3b1b45f..10cf1b7e2 100644 --- a/Text/Pandoc/ODT.hs +++ b/Text/Pandoc/ODT.hs @@ -29,22 +29,16 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA Functions for producing an ODT file from OpenDocument XML. -} module Text.Pandoc.ODT ( saveOpenDocumentAsODT ) where -import Text.Pandoc.TH ( binaryContentsOf ) -import Data.Maybe ( fromJust ) -import Data.List ( partition, intersperse ) -import System.Directory -import System.FilePath ( (</>), takeDirectory, takeFileName, splitDirectories ) -import System.Process ( runProcess, waitForProcess ) -import System.Exit -import Text.XML.Light -import Text.XML.Light.Cursor -import Text.Pandoc.Shared ( withTempDir ) -import Network.URI ( isURI ) -import qualified Data.ByteString as B ( writeFile, pack ) -import Data.ByteString.Internal ( c2w ) +import Text.Pandoc.TH ( makeZip ) +import Data.List ( find ) +import System.FilePath ( (</>), takeFileName ) +import qualified Data.ByteString.Lazy as B +import Data.ByteString.Lazy.UTF8 ( fromString ) import Prelude hiding ( writeFile, readFile ) -import System.IO ( stderr ) -import System.IO.UTF8 +import Codec.Archive.Zip +import Control.Applicative ( (<$>) ) +import Text.ParserCombinators.Parsec +import System.Time -- | Produce an ODT file from OpenDocument XML. saveOpenDocumentAsODT :: FilePath -- ^ Pathname of ODT file to be produced. @@ -52,89 +46,43 @@ saveOpenDocumentAsODT :: FilePath -- ^ Pathname of ODT file to be produced. -> String -- ^ OpenDocument XML contents. -> IO () saveOpenDocumentAsODT destinationODTPath sourceDirRelative xml = do - let zipCmd = "zip" - -- check for zip in path: - zipPathMaybe <- findExecutable zipCmd - let zipPath = case zipPathMaybe of - Nothing -> error $ "The '" ++ zipCmd ++ - "' command, which is needed to build an ODT file, was not found.\n" ++ - "It can be obtained from http://www.info-zip.org/Zip.html\n" ++ - "Debian (and Debian-based) linux: apt-get install zip\n" ++ - "Windows: See http://gnuwin32.sourceforge.net/packages/zip.htm" - Just x -> x - withTempDir "pandoc-odt" $ \tempDir -> do - let tempODT = tempDir </> "reference.odt" - B.writeFile tempODT $ B.pack $ map c2w $(binaryContentsOf $ "odt-styles" </> "reference.odt") - xml' <- handlePictures tempODT sourceDirRelative xml - writeFile (tempDir </> "content.xml") xml' - ph <- runProcess zipPath ["-9", "-q", "-r", tempODT, "content.xml", "Pictures"] - (Just tempDir) Nothing Nothing Nothing (Just stderr) - ec <- waitForProcess ph -- requires compilation with -threaded - case ec of - ExitSuccess -> copyFile tempODT destinationODTPath - _ -> error "Error creating ODT." >> exitWith ec + let refArchive = read $(makeZip "odt-styles") + -- handle pictures + let (newContents, pics) = + case runParser pPictures [] "OpenDocument XML contents" xml of + Left err -> error $ show err + Right x -> x + picEntries <- mapM (makePictureEntry sourceDirRelative) pics + (TOD epochTime _) <- getClockTime + let contentEntry = toEntry "content.xml" epochTime $ fromString newContents + let archive = foldr addEntryToArchive refArchive (contentEntry : picEntries) + B.writeFile destinationODTPath $ fromArchive archive --- | Find <draw:image ... /> elements and copy the file (xlink:href attribute) into Pictures/ in --- the zip file. If filename is a URL, attempt to download it. Modify xlink:href attributes --- to point to the new locations in Pictures/. Return modified XML. -handlePictures :: FilePath -- ^ Path of ODT file in temp directory - -> FilePath -- ^ Directory (relative) containing source file - -> String -- ^ OpenDocument XML string - -> IO String -- ^ Modified XML -handlePictures tempODT sourceDirRelative xml = do - let parsed = case parseXMLDoc xml of - Nothing -> error "Could not parse OpenDocument XML." - Just x -> x - let cursor = case (fromForest $ elContent parsed) of - Nothing -> error "ODT appears empty" - Just x -> x - cursor' <- scanPictures tempODT sourceDirRelative cursor - let modified = parsed { elContent = toForest $ root cursor' } - return $ showTopElement modified +makePictureEntry :: FilePath -- ^ Relative directory of source file + -> (FilePath, String) -- ^ Path and new path of picture + -> IO Entry +makePictureEntry sourceDirRelative (path, newPath) = do + entry <- readEntry [] $ sourceDirRelative </> path + return (entry { eRelativePath = newPath }) -scanPictures :: FilePath -> FilePath -> Cursor -> IO Cursor -scanPictures tempODT sourceDirRelative cursor = do - cursor' <- handleTree tempODT sourceDirRelative cursor - case right cursor' of - Just n -> scanPictures tempODT sourceDirRelative n - Nothing -> return cursor' - -handleTree :: FilePath -> FilePath -> Cursor -> IO Cursor -handleTree tempODT sourceDirRelative cursor = do - case firstChild cursor of - Nothing -> modifyContentM (handleContent tempODT sourceDirRelative) cursor - Just n -> scanPictures tempODT sourceDirRelative n >>= return . fromJust . parent - --- | If content is an image link, handle it appropriately. --- Otherwise, handle children if any. -handleContent :: FilePath -> FilePath -> Content -> IO Content -handleContent tempODT sourceDirRelative content@(Elem el) = do - if qName (elName el) == "image" - then do - let (hrefs, rest) = partition (\a -> qName (attrKey a) == "href") $ elAttribs el - let href = case hrefs of - [] -> error $ "No href found in " ++ show el - [x] -> x - _ -> error $ "Multiple hrefs found in " ++ show el - if isURI $ attrVal href - then return content - else do -- treat as filename - let oldLoc = sourceDirRelative </> attrVal href - fileExists <- doesFileExist oldLoc - if fileExists - then do - let pref = take 230 $ concat $ intersperse "_" $ - splitDirectories $ takeDirectory $ attrVal href - let picName = pref ++ "_" ++ (takeFileName $ attrVal href) - let tempDir = takeDirectory tempODT - createDirectoryIfMissing False $ tempDir </> "Pictures" - copyFile oldLoc $ tempDir </> "Pictures" </> picName - let newAttrs = (href { attrVal = "Pictures/" ++ picName }) : rest - return $ Elem (el { elAttribs = newAttrs }) - else do - hPutStrLn stderr $ "Warning: Unable to find image at " ++ oldLoc ++ " - ignoring." - return content - else return content - -handleContent _ _ c = return c -- not Element +pPictures :: GenParser Char [(FilePath, String)] ([Char], [(FilePath, String)]) +pPictures = do + contents <- concat <$> many (pPicture <|> many1 (noneOf "<") <|> string "<") + pics <- getState + return (contents, pics) +pPicture :: GenParser Char [(FilePath, String)] [Char] +pPicture = try $ do + string "<draw:image xlink:href=\"" + path <- manyTill anyChar (char '"') + let filename = takeFileName path + pics <- getState + newPath <- case find (\(o, _) -> o == path) pics of + Just (_, new) -> return new + Nothing -> do + -- get a unique name + let dups = length $ (filter (\(o, _) -> takeFileName o == filename)) pics + let new = "Pictures/" ++ replicate dups '0' ++ filename + updateState ((path, new) :) + return new + return $ "<draw:image xlink:href=\"" ++ newPath ++ "\"" diff --git a/Text/Pandoc/Shared.hs b/Text/Pandoc/Shared.hs index 2c53ffa7a..9bb0c35f9 100644 --- a/Text/Pandoc/Shared.hs +++ b/Text/Pandoc/Shared.hs @@ -101,7 +101,7 @@ module Text.Pandoc.Shared ( WriterOptions (..), defaultWriterOptions, -- * File handling - withTempDir + inDirectory ) where import Text.Pandoc.Definition @@ -112,10 +112,7 @@ import Text.Pandoc.CharacterReferences ( characterReference ) import Data.Char ( toLower, toUpper, ord, isLower, isUpper ) import Data.List ( find, isPrefixOf ) import Control.Monad ( join ) -import Control.Exception ( bracket ) import Network.URI ( parseURI, URI (..), isAllowedInURI ) -import System.FilePath ( (</>), (<.>) ) -import System.IO.Error ( catch, ioError, isAlreadyExistsError ) import System.Directory import Prelude hiding ( putStrLn, writeFile, readFile, getContents ) import System.IO.UTF8 @@ -920,16 +917,11 @@ defaultWriterOptions = -- File handling -- --- | 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 - catch (createDirectory dirName >> return dirName) $ - \e -> if isAlreadyExistsError e - then createTempDir (num + 1) baseName - else ioError e +-- | Perform an IO action in a directory, returning to starting directory. +inDirectory :: FilePath -> IO a -> IO a +inDirectory path action = do + oldDir <- getCurrentDirectory + setCurrentDirectory path + result <- action + setCurrentDirectory oldDir + return result diff --git a/Text/Pandoc/TH.hs b/Text/Pandoc/TH.hs index dfd6be28b..0dc5a6719 100644 --- a/Text/Pandoc/TH.hs +++ b/Text/Pandoc/TH.hs @@ -30,7 +30,8 @@ Template haskell functions used by Pandoc modules. -} module Text.Pandoc.TH ( contentsOf, - binaryContentsOf + binaryContentsOf, + makeZip ) where import Language.Haskell.TH @@ -39,6 +40,8 @@ import qualified Data.ByteString as B import Data.ByteString.Internal ( w2c ) import Prelude hiding ( readFile ) import System.IO.UTF8 +import Codec.Archive.Zip +import Text.Pandoc.Shared ( inDirectory ) -- | Insert contents of text file into a template. contentsOf :: FilePath -> ExpQ @@ -51,3 +54,12 @@ binaryContentsOf p = lift =<< (runIO $ B.readFile p) instance Lift B.ByteString where lift x = return (LitE (StringL $ map w2c $ B.unpack x)) + +instance Lift Archive where + lift x = return (LitE (StringL $ show x )) + +-- | Construct zip file from files in a directory, and +-- insert into a template. +makeZip :: FilePath -> ExpQ +makeZip path = lift =<< (runIO $ inDirectory path $ addFilesToArchive [OptRecursive] emptyArchive ["."]) + |