8511f6f · typeable/pandoc

git.iko.soy/typeable/pandoc

MediaBag improvements.

In the current dev version, we will sometimes add a version of an image with a hashed name, keeping the original version with the original name, which would leave to undesirable duplication. This change separates the media's filename from the media's canonical name (which is the path of the link in the document itself). Filenames are based on SHA1 hashes and assigned automatically. In Text.Pandoc.MediaBag: - Export MediaItem type [API change]. - Change MediaBag type to a map from Text to MediaItem [API change]. - `lookupMedia` now returns a `MediaItem` [API change]. - Change `insertMedia` so it sets the `mediaPath` to a filename based on the SHA1 hash of the contents. This will be used when contents are extracted. In Text.Pandoc.Class.PandocMonad: - Remove `fetchMediaResource` [API change]. Lua MediaBag module has been changed minimally. In the future it would be better, probably, to give Lua access to the full MediaItem type.

commit8511f6fdf6c9fbc2cc926538bca4ae9f554b4ed9 authorJohn MacFarlane <jgm@berkeley.edu> dateSun 23 May 2021, 22:57 (5 years ago) parent58fbf56

5 files changed+55−48

compare with master

unifiedsplit

src/Text/Pandoc/Class/IO.hs+4−5 src/Text/Pandoc/Class/PandocMonad.hs+17−26 src/Text/Pandoc/Lua/Module/MediaBag.hs+3−3 src/Text/Pandoc/MediaBag.hs+26−9 test/Tests/Readers/Docx.hs+5−5

src/Text/Pandoc/Class/IO.hs+4−5

@@ -62,7 +62,7 @@ import Text.Pandoc.Definition (Pandoc, Inline (Image))

6262import Text.Pandoc.Error (PandocError (..))

6363import Text.Pandoc.Logging (LogMessage (..), messageVerbosity, showLogMessage)

6464import Text.Pandoc.MIME (MimeType)

65−import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)

65+import Text.Pandoc.MediaBag (MediaBag, MediaItem(..), lookupMedia, mediaDirectory)

6666import Text.Pandoc.Walk (walk)

6767import qualified Control.Exception as E

6868import qualified Data.ByteString as B

@@ -213,14 +213,13 @@ writeMedia :: (PandocMonad m, MonadIO m)

213213writeMedia dir mediabag subpath = do

214214 -- we join and split to convert a/b/c to a\b\c on Windows;

215215 -- in zip containers all paths use /

216− let fullpath = dir </> unEscapeString (normalise subpath)

217216 let mbcontents = lookupMedia subpath mediabag

218217 case mbcontents of

219218 Nothing -> throwError $ PandocResourceNotFound $ pack subpath

220− Just (_, bs) -> do

221− report $ Extracting $ pack fullpath

219+ Just item -> do

220+ let fullpath = dir </> mediaPath item

222221 liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath)

223− logIOError $ BL.writeFile fullpath bs

222+ logIOError $ BL.writeFile fullpath $ mediaContents item

224223

225224-- | If the given Inline element is an image with a @src@ path equal to

226225-- one in the list of @paths@, then prepends @dir@ to the image source;

src/Text/Pandoc/Class/PandocMonad.hs+17−26

@@ -37,7 +37,6 @@ module Text.Pandoc.Class.PandocMonad

3737 , setUserDataDir

3838 , getUserDataDir

3939 , fetchItem

40− , fetchMediaResource

4140 , getInputFiles

4241 , setInputFiles

4342 , getOutputFile

@@ -57,8 +56,6 @@ module Text.Pandoc.Class.PandocMonad

5756import Codec.Archive.Zip

5857import Control.Monad.Except (MonadError (catchError, throwError),

5958 MonadTrans, lift, when)

60−import Data.Digest.Pure.SHA (sha1, showDigest)

61−import Data.Maybe (fromMaybe)

6259import Data.List (foldl')

6360import Data.Time (UTCTime)

6461import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds,

@@ -67,7 +64,7 @@ import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime)

6764import Network.URI ( escapeURIString, nonStrictRelativeTo,

6865 unEscapeString, parseURIReference, isAllowedInURI,

6966 parseURI, URI(..) )

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

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

7168 isRelative, splitDirectories)

7269import System.Random (StdGen)

7370import Text.Collate.Lang (Lang(..), parseLang, renderLang)

@@ -75,8 +72,8 @@ import Text.Pandoc.Class.CommonState (CommonState (..))

7572import Text.Pandoc.Definition

7673import Text.Pandoc.Error

7774import Text.Pandoc.Logging

78−import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType)

79−import Text.Pandoc.MediaBag (MediaBag, lookupMedia)

75+import Text.Pandoc.MIME (MimeType, getMimeType)

76+import Text.Pandoc.MediaBag (MediaBag, lookupMedia, MediaItem(..))

8077import Text.Pandoc.Shared (uriPathToPath, safeRead)

8178import Text.Pandoc.Translations (Term(..), Translations, lookupTerm,

8279 readTranslations)

@@ -376,7 +373,8 @@ fetchItem :: PandocMonad m

376373fetchItem s = do

377374 mediabag <- getMediaBag

378375 case lookupMedia (T.unpack s) mediabag of

379− Just (mime, bs) -> return (BL.toStrict bs, Just mime)

376+ Just item -> return (BL.toStrict (mediaContents item),

377+ Just (mediaMimeType item))

380378 Nothing -> downloadOrRead s

381379

382380-- | Returns the content and, if available, the MIME type of a resource.

@@ -629,19 +627,6 @@ withPaths (p:ps) action fp =

629627 catchError (action (p </> fp))

630628 (\_ -> withPaths ps action fp)

631629

632−-- | Fetch local or remote resource (like an image) and provide data suitable

633−-- for adding it to the MediaBag.

634−fetchMediaResource :: PandocMonad m

635− => T.Text -> m (FilePath, Maybe MimeType, BL.ByteString)

636−fetchMediaResource src = do

637− (bs, mt) <- fetchItem src

638− let ext = fromMaybe (T.pack $ takeExtension $ T.unpack src)

639− (mt >>= extensionFromMimeType)

640− let bs' = BL.fromChunks [bs]

641− let basename = showDigest $ sha1 bs'

642− let fname = basename <.> T.unpack ext

643− return (fname, mt, bs')

644−

645630-- | Traverse tree, filling media bag for any images that

646631-- aren't already in the media bag.

647632fillMediaBag :: PandocMonad m => Pandoc -> m Pandoc

@@ -649,12 +634,18 @@ fillMediaBag d = walkM handleImage d

649634 where handleImage :: PandocMonad m => Inline -> m Inline

650635 handleImage (Image attr lab (src, tit)) = catchError

651636 (do mediabag <- getMediaBag

652− case lookupMedia (T.unpack src) mediabag of

653− Just (_, _) -> return $ Image attr lab (src, tit)

654− Nothing -> do

655− (fname, mt, bs) <- fetchMediaResource src

656− insertMedia fname mt bs

657− return $ Image attr lab (T.pack fname, tit))

637+ let fp = T.unpack src

638+ src' <- T.pack <$> case lookupMedia fp mediabag of

639+ Just item -> return $ mediaPath item

640+ Nothing -> do

641+ (bs, mt) <- fetchItem src

642+ insertMedia fp mt (BL.fromStrict bs)

643+ mediabag' <- getMediaBag

644+ case lookupMedia fp mediabag' of

645+ Just item -> return $ mediaPath item

646+ Nothing -> throwError $ PandocSomeError $

647+ src <> " not successfully inserted into MediaBag"

648+ return $ Image attr lab (src', tit))

658649 (\e ->

659650 case e of

660651 PandocResourceNotFound _ -> do

src/Text/Pandoc/Lua/Module/MediaBag.hs+3−3

@@ -73,9 +73,9 @@ lookup fp = do

7373 res <- MB.lookupMedia fp <$> getMediaBag

7474 liftPandocLua $ case res of

7575 Nothing -> 1 <$ Lua.pushnil

76− Just (mimeType, contents) -> do

77− Lua.push mimeType

78− Lua.push contents

76+ Just item -> do

77+ Lua.push $ MB.mediaMimeType item

78+ Lua.push $ MB.mediaContents item

7979 return 2

8080

8181list :: PandocLua NumResults

src/Text/Pandoc/MediaBag.hs+26−9

@@ -15,6 +15,7 @@ Definition of a MediaBag object to hold binary resources, and an

1515interface for interacting with it.

1616-}

1717module Text.Pandoc.MediaBag (

18+ MediaItem(..),

1819 MediaBag,

1920 deleteMedia,

2021 lookupMedia,

@@ -28,15 +29,23 @@ import qualified Data.Map as M

2829import Data.Maybe (fromMaybe)

2930import Data.Typeable (Typeable)

3031import System.FilePath

31−import Text.Pandoc.MIME (MimeType, getMimeTypeDef)

32+import Text.Pandoc.MIME (MimeType, getMimeTypeDef, extensionFromMimeType)

3233import Data.Text (Text)

3334import qualified Data.Text as T

35+import Data.Digest.Pure.SHA (sha1, showDigest)

36+

37+data MediaItem =

38+ MediaItem

39+ { mediaMimeType :: MimeType

40+ , mediaPath :: FilePath

41+ , mediaContents :: BL.ByteString

42+ } deriving (Eq, Ord, Show, Data, Typeable)

3443

3544-- | A container for a collection of binary resources, with names and

3645-- mime types. Note that a 'MediaBag' is a Monoid, so 'mempty'

3746-- can be used for an empty 'MediaBag', and '<>' can be used to append

3847-- two 'MediaBag's.

39−newtype MediaBag = MediaBag (M.Map Text (MimeType, BL.ByteString))

48+newtype MediaBag = MediaBag (M.Map Text MediaItem)

4049 deriving (Semigroup, Monoid, Data, Typeable)

4150

4251instance Show MediaBag where

@@ -62,26 +71,34 @@ insertMedia :: FilePath -- ^ relative path and canonical name of resource

6271 -> MediaBag

6372 -> MediaBag

6473insertMedia fp mbMime contents (MediaBag mediamap) =

65− MediaBag (M.insert (canonicalize fp) (mime, contents) mediamap)

66− where mime = fromMaybe fallback mbMime

74+ MediaBag (M.insert (canonicalize fp) mediaItem mediamap)

75+ where mediaItem = MediaItem{ mediaPath = showDigest (sha1 contents) <>

76+ "." <> ext

77+ , mediaContents = contents

78+ , mediaMimeType = mt }

6779 fallback = case takeExtension fp of

6880 ".gz" -> getMimeTypeDef $ dropExtension fp

6981 _ -> getMimeTypeDef fp

82+ mt = fromMaybe fallback mbMime

83+ ext = maybe (takeExtension fp) T.unpack $ extensionFromMimeType mt

84+

7085

7186-- | Lookup a media item in a 'MediaBag', returning mime type and contents.

7287lookupMedia :: FilePath

7388 -> MediaBag

74− -> Maybe (MimeType, BL.ByteString)

89+ -> Maybe MediaItem

7590lookupMedia fp (MediaBag mediamap) = M.lookup (canonicalize fp) mediamap

7691

7792-- | Get a list of the file paths stored in a 'MediaBag', with

7893-- their corresponding mime types and the lengths in bytes of the contents.

7994mediaDirectory :: MediaBag -> [(FilePath, MimeType, Int)]

8095mediaDirectory (MediaBag mediamap) =

81− M.foldrWithKey (\fp (mime,contents) ->

82− ((T.unpack fp, mime, fromIntegral (BL.length contents)):)) [] mediamap

96+ M.foldrWithKey (\fp item ->

97+ ((T.unpack fp, mediaMimeType item,

98+ fromIntegral (BL.length (mediaContents item))):)) [] mediamap

8399

84100mediaItems :: MediaBag -> [(FilePath, MimeType, BL.ByteString)]

85101mediaItems (MediaBag mediamap) =

86− M.foldrWithKey (\fp (mime,contents) ->

87− ((T.unpack fp, mime, contents):)) [] mediamap

102+ M.foldrWithKey (\fp item ->

103+ ((T.unpack fp, mediaMimeType item, mediaContents item):))

104+ [] mediamap

test/Tests/Readers/Docx.hs+5−5

@@ -24,7 +24,7 @@ import Test.Tasty.HUnit

2424import Tests.Helpers

2525import Text.Pandoc

2626import qualified Text.Pandoc.Class as P

27−import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)

27+import qualified Text.Pandoc.MediaBag as MB

2828import Text.Pandoc.UTF8 as UTF8

2929

3030-- We define a wrapper around pandoc that doesn't normalize in the

@@ -91,11 +91,11 @@ getMedia :: FilePath -> FilePath -> IO (Maybe B.ByteString)

9191getMedia archivePath mediaPath = fmap fromEntry . findEntryByPath

9292 ("word/" ++ mediaPath) . toArchive <$> B.readFile archivePath

9393

94−compareMediaPathIO :: FilePath -> MediaBag -> FilePath -> IO Bool

94+compareMediaPathIO :: FilePath -> MB.MediaBag -> FilePath -> IO Bool

9595compareMediaPathIO mediaPath mediaBag docxPath = do

9696 docxMedia <- getMedia docxPath mediaPath

97− let mbBS = case lookupMedia mediaPath mediaBag of

98− Just (_, bs) -> bs

97+ let mbBS = case MB.lookupMedia mediaPath mediaBag of

98+ Just item -> MB.mediaContents item

9999 Nothing -> error ("couldn't find " ++

100100 mediaPath ++

101101 " in media bag")

@@ -110,7 +110,7 @@ compareMediaBagIO docxFile = do

110110 mb <- runIOorExplode $ readDocx defopts df >> P.getMediaBag

111111 bools <- mapM

112112 (\(fp, _, _) -> compareMediaPathIO fp mb docxFile)

113− (mediaDirectory mb)

113+ (MB.mediaDirectory mb)

114114 return $ and bools

115115

116116testMediaBagIO :: String -> FilePath -> IO TestTree