bc06ef0 · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Merge branch 'newbranch' of https://github.com/mpickering/pandoc into mpickering-newbranch

bc06ef0John MacFarlane12 years ago

src/Text/Pandoc/Readers/EPUB.hs+19−28

compare with master

unifiedsplit

@@ -14,7 +14,7 @@ import Text.Pandoc.Walk (walk, query)

14import Text.Pandoc.Generic(bottomUp)

15import Text.Pandoc.Readers.HTML (readHtml)

16import Text.Pandoc.Options ( ReaderOptions(..), readerTrace)

17−import Text.Pandoc.Shared (escapeURI)

17+import Text.Pandoc.Shared (escapeURI, collapseFilePath)

18import Text.Pandoc.MediaBag (MediaBag, insertMedia)

19import Text.Pandoc.Compat.Except (MonadError, throwError, runExcept, Except)

20import qualified Text.Pandoc.Builder as B

@@ -22,7 +22,7 @@ import Codec.Archive.Zip ( Archive (..), toArchive, fromEntry

22 , findEntryByPath, Entry)

23import qualified Data.ByteString.Lazy as BL (ByteString)

24import System.FilePath ( takeFileName, (</>), dropFileName, normalise

25− , joinPath, dropFileName, splitDirectories

25+ , dropFileName

26 , splitFileName )

27import qualified Text.Pandoc.UTF8 as UTF8 (toStringLazy)

28import Control.Applicative ((<$>))

@@ -50,50 +50,52 @@ runEPUB = either error id . runExcept

50--

51archiveToEPUB :: (MonadError String m) => ReaderOptions -> Archive -> m (Pandoc, MediaBag)

52archiveToEPUB os archive = do

53+ -- root is path to folder with manifest file in

53 (root, content) <- getManifest archive

54 (root, content) <- getManifest archive

54 meta <- parseMeta content

55 meta <- parseMeta content

55 (cover, items) <- parseManifest content

56 (cover, items) <- parseManifest content

57+ -- No need to collapse here as the image path is from the manifest file

56− let coverDoc = fromMaybe mempty (imageToPandoc <$> cover)

58+ let coverDoc = fromMaybe mempty (imageToPandoc . (root </>) <$> cover)

57 spine <- parseSpine items content

59 spine <- parseSpine items content

58 let escapedSpine = map (escapeURI . takeFileName . fst) spine

60 let escapedSpine = map (escapeURI . takeFileName . fst) spine

59 Pandoc _ bs <-

61 Pandoc _ bs <-

60 foldM' (\a b -> ((a <>) . bottomUp (prependHash escapedSpine))

62 foldM' (\a b -> ((a <>) . bottomUp (prependHash escapedSpine))

61 `liftM` parseSpineElem root b) mempty spine

63 `liftM` parseSpineElem root b) mempty spine

62 let ast = coverDoc <> (Pandoc meta bs)

64 let ast = coverDoc <> (Pandoc meta bs)

63− let mediaBag = fetchImages (M.elems items) root archive ast

65+ let mediaBag = fetchImages (M.elems items) archive ast

64 return $ (ast, mediaBag)

66 return $ (ast, mediaBag)

65 where

67 where

66 os' = os {readerParseRaw = True}

68 os' = os {readerParseRaw = True}

67 parseSpineElem :: MonadError String m => FilePath -> (FilePath, MIME) -> m Pandoc

69 parseSpineElem :: MonadError String m => FilePath -> (FilePath, MIME) -> m Pandoc

68 parseSpineElem (normalise -> r) (normalise -> path, mime) = do

70 parseSpineElem (normalise -> r) (normalise -> path, mime) = do

69 when (readerTrace os) (traceM path)

71 when (readerTrace os) (traceM path)

70− doc <- mimeToReader mime r path

72+ doc <- mimeToReader mime (r </> path)

71 let docSpan = B.doc $ B.para $ B.spanWith (takeFileName path, [], []) mempty

73 let docSpan = B.doc $ B.para $ B.spanWith (takeFileName path, [], []) mempty

72 return $ docSpan <> doc

74 return $ docSpan <> doc

73− mimeToReader :: MonadError String m => MIME -> FilePath -> FilePath -> m Pandoc

75+ mimeToReader :: MonadError String m => MIME -> FilePath -> m Pandoc

74− mimeToReader "application/xhtml+xml" r path = do

76+ mimeToReader "application/xhtml+xml" (normalise -> path) = do

75− fname <- findEntryByPathE (r </> path) archive

77+ fname <- findEntryByPathE path archive

76− return $ fixInternalReferences (r </> path) .

78+ return $ fixInternalReferences path .

77 readHtml os' .

79 readHtml os' .

78 UTF8.toStringLazy $

80 UTF8.toStringLazy $

79 fromEntry fname

81 fromEntry fname

80− mimeToReader s _ path

82+ mimeToReader s path

81 | s `elem` imageMimes = return $ imageToPandoc path

83 | s `elem` imageMimes = return $ imageToPandoc path

82 | otherwise = return $ mempty

84 | otherwise = return $ mempty

86+-- paths should be absolute when this function is called

87+-- renameImages should do this

84fetchImages :: [(FilePath, MIME)]

88fetchImages :: [(FilePath, MIME)]

85− -> FilePath

86 -> Archive

89 -> Archive

87 -> Pandoc

90 -> Pandoc

88 -> MediaBag

91 -> MediaBag

89−fetchImages mimes root arc (query iq -> links) =

92+fetchImages mimes arc (query iq -> links) =

90 foldr (uncurry3 insertMedia) mempty

93 foldr (uncurry3 insertMedia) mempty

91 (mapMaybe getEntry links)

94 (mapMaybe getEntry links)

92 where

95 where

93− getEntry (normalise -> l) =

96+ getEntry link =

94− let mediaPos = normalise (root </> l) in

95− (l , lookup mediaPos mimes, ) . fromEntry

97+ (link , lookup link mimes, ) . fromEntry

96− <$> findEntryByPath mediaPos arc

98+ <$> findEntryByPath link arc

98iq :: Inline -> [FilePath]

100iq :: Inline -> [FilePath]

99iq (Image _ (url, _)) = [url]

101iq (Image _ (url, _)) = [url]

@@ -101,20 +103,9 @@ iq _ = []

101

103

102-- Remove relative paths

104-- Remove relative paths

103renameImages :: FilePath -> Inline -> Inline

105renameImages :: FilePath -> Inline -> Inline

104−renameImages root (Image a (url, b)) = Image a (collapse (root </> url), b)

106+renameImages root (Image a (url, b)) = Image a (collapseFilePath (root </> url), b)

105renameImages _ x = x

107renameImages _ x = x

106

108

107−collapse :: FilePath -> FilePath

108−collapse = joinPath . reverse . foldl go [] . splitDirectories

109− where

110− go rs "." = rs

111− go r@(p:rs) ".." = case p of

112− ".." -> ("..":r)

113− "/" -> ("..":r)

114− _ -> rs

115− go _ "/" = ["/"]

116− go rs x = x:rs

117−

118imageToPandoc :: FilePath -> Pandoc

109imageToPandoc :: FilePath -> Pandoc

119imageToPandoc s = B.doc . B.para $ B.image s "" mempty

110imageToPandoc s = B.doc . B.para $ B.image s "" mempty

120

111

src/Text/Pandoc/Shared.hs+26−1

@@ -80,6 +80,7 @@ module Text.Pandoc.Shared (

80 fetchItem,

81 fetchItem',

82 openURL,

83+ collapseFilePath,

83 -- * Error handling

84 -- * Error handling

84 err,

85 err,

85 warn,

86 warn,

@@ -105,6 +106,7 @@ import Network.URI ( escapeURIString, isURI, nonStrictRelativeTo,

105 unEscapeString, parseURIReference, isAllowedInURI )

106 unEscapeString, parseURIReference, isAllowedInURI )

106import qualified Data.Set as Set

107import qualified Data.Set as Set

107import System.Directory

108import System.Directory

109+import System.FilePath (joinPath, splitDirectories)

108import Text.Pandoc.MIME (getMimeType)

110import Text.Pandoc.MIME (getMimeType)

109import System.FilePath ( (</>), takeExtension, dropExtension)

111import System.FilePath ( (</>), takeExtension, dropExtension)

110import Data.Generics (Typeable, Data)

112import Data.Generics (Typeable, Data)

@@ -530,7 +532,7 @@ stringify = query go . walk deNote

530 deNote x = x

532 deNote x = x

531

533

532-- | Bring all regular text in a pandoc structure to uppercase.

534-- | Bring all regular text in a pandoc structure to uppercase.

533−--

535+--

534-- This function correctly handles cases where a lowercase character doesn't

536-- This function correctly handles cases where a lowercase character doesn't

535-- match to a single uppercase character – e.g. “Straße” would be converted

537-- match to a single uppercase character – e.g. “Straße” would be converted

536-- to “STRASSE”, not “STRAßE”.

538-- to “STRASSE”, not “STRAßE”.

@@ -854,6 +856,29 @@ warn msg = do

854 name <- getProgName

856 name <- getProgName

855 UTF8.hPutStrLn stderr $ name ++ ": " ++ msg

857 UTF8.hPutStrLn stderr $ name ++ ": " ++ msg

856

858

859+-- | Remove intermediate "." and ".." directories from a path.

860+--

861+-- @

862+-- collapseFilePath "./foo" == "foo"

863+-- collapseFilePath "/bar/../baz" == "/baz"

864+-- collapseFilePath "/../baz" == "/../baz"

865+-- collapseFilePath "parent/foo/baz/../bar" == "parent/foo/bar"

866+-- collapseFilePath "parent/foo/baz/../../bar" == "parent/bar"

867+-- collapseFilePath "parent/foo/.." == "parent"

868+-- collapseFilePath "/parent/foo/../../bar" == "/bar"

869+-- @

870+collapseFilePath :: FilePath -> FilePath

871+collapseFilePath = joinPath . reverse . foldl go [] . splitDirectories

872+ where

873+ go rs "." = rs

874+ go r@(p:rs) ".." = case p of

875+ ".." -> ("..":r)

876+ "/" -> ("..":r)

877+ _ -> rs

878+ go _ "/" = ["/"]

879+ go rs x = x:rs

880+

881+

857--

882--

858-- Safe read

883-- Safe read

859--

884--

tests/Tests/Shared.hs+23−1

@@ -6,7 +6,7 @@ import Test.Framework

6import Tests.Helpers

7import Tests.Arbitrary()

8import Test.Framework.Providers.HUnit

9−import Test.HUnit ( assertBool )

9+import Test.HUnit ( assertBool, (@?=) )

10import Text.Pandoc.Builder

11import Data.Monoid

@@ -23,6 +23,7 @@ tests = [ testGroup "normalize"

23 (let x = [(str "word", [para (str "def"), mempty])]

24 in compactify'DL x == x)

25 ]

26+ , testGroup "collapseFilePath" testCollapse

26 ]

27 ]

28p_normalize_blocks_rt :: [Block] -> Bool

29p_normalize_blocks_rt :: [Block] -> Bool

@@ -36,3 +37,24 @@ p_normalize_inlines_rt ils =

36p_normalize_no_trailing_spaces :: [Inline] -> Bool

37p_normalize_no_trailing_spaces :: [Inline] -> Bool

37p_normalize_no_trailing_spaces ils = null ils' || last ils' /= Space

38p_normalize_no_trailing_spaces ils = null ils' || last ils' /= Space

38 where ils' = normalizeInlines $ ils ++ [Space]

39 where ils' = normalizeInlines $ ils ++ [Space]

40+

41+testCollapse :: [Test]

42+testCollapse = map (testCase "collapse")

43+ [ (collapseFilePath "" @?= "")

44+ , (collapseFilePath "./foo" @?= "foo")

45+ , (collapseFilePath "././../foo" @?= "../foo")

46+ , (collapseFilePath "../foo" @?= "../foo")

47+ , (collapseFilePath "/bar/../baz" @?= "/baz")

48+ , (collapseFilePath "/../baz" @?= "/../baz")

49+ , (collapseFilePath "./foo/.././bar/../././baz" @?= "baz")

50+ , (collapseFilePath "./" @?= "")

51+ , (collapseFilePath "././" @?= "")

52+ , (collapseFilePath "../" @?= "..")

53+ , (collapseFilePath ".././" @?= "..")

54+ , (collapseFilePath "./../" @?= "..")

55+ , (collapseFilePath "../../" @?= "../..")

56+ , (collapseFilePath "parent/foo/baz/../bar" @?= "parent/foo/bar")

57+ , (collapseFilePath "parent/foo/baz/../../bar" @?= "parent/bar")

58+ , (collapseFilePath "parent/foo/.." @?= "parent")

59+ , (collapseFilePath "/parent/foo/../../bar" @?= "/bar")

60+ , (collapseFilePath "/./parent/foo" @?= "/parent/foo")]