fix(docx): use proper DPI when creating fallback images

Introduce getOrCreateFallback, and pass the desired size in points to
rsvg-convert.
Otherwise it'll guess the size based on the SVG's viewbox and completely
ignore the DPI argument.

Signed-off-by: Edwin Török <[email protected]>

Author: edwintorok

src/Text/Pandoc/App.hs

@@ -28,7 +28,7 @@ module Text.Pandoc.App (
           , applyFilters
           ) where
 import qualified Control.Exception as E
-import Control.Monad ( (>=>), when, forM, forM_ )
+import Control.Monad ( (>=>), when, forM )
 import Control.Monad.Trans ( MonadIO(..) )
 import Control.Monad.Catch ( MonadMask )
 import Control.Monad.Except (throwError)
@@ -49,7 +49,6 @@ import System.IO (nativeNewline, stdout)
 import qualified System.IO as IO (Newline (..))
 import Text.Pandoc
 import Text.Pandoc.Builder (setMeta)
-import Text.Pandoc.MediaBag (mediaItems)
 import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), defaultOpts,
                             IpynbOutput (..), OptInfo(..))
 import Text.Pandoc.App.CommandLineOptions (parseOptions, parseOptionsFromArgs,
@@ -66,7 +65,6 @@ import qualified Text.Pandoc.Format as Format
 import Text.Pandoc.PDF (makePDF)
 import Text.Pandoc.Scripting (ScriptingEngine (..), CustomComponents(..))
 import Text.Pandoc.SelfContained (makeSelfContained)
-import Text.Pandoc.Shared (tshow)
 import Text.Pandoc.Writers.Shared (lookupMetaString)
 import Text.Pandoc.Readers.Markdown (yamlToMeta)
 import qualified Text.Pandoc.UTF8 as UTF8
@@ -300,9 +298,6 @@ convertWithOpts' scriptingEngine istty datadir opts = do
             >=> maybe return extractMedia (optExtractMedia opts)
             )
 
-  when (format == "docx" && not (optSandbox opts)) $ do
-    createPngFallbacks (writerDpi writerOptions)
-
   output <- case writer of
     ByteStringWriter f
       | format == "chunkedhtml" -> ZipOutput <$> f writerOptions doc
@@ -367,21 +362,6 @@ readAbbreviations mbfilepath =
     >>= fmap (Set.fromList . filter (not . T.null) . T.lines) .
          toTextM (fromMaybe mempty mbfilepath)
 
-createPngFallbacks :: (PandocMonad m) => Int -> m ()
-createPngFallbacks dpi = do
-  -- create fallback pngs for svgs
-  items <- mediaItems <$> getMediaBag
-  forM_ items $ \(fp, mt, bs) ->
-    case T.takeWhile (/=';') mt of
-      "image/svg+xml" -> do
-        res <- svgToPng dpi Nothing Nothing bs
-        case res of
-          Right bs' -> do
-            let fp' = fp <> ".png"
-            insertMedia fp' (Just "image/png") bs'
-          Left e -> report $ CouldNotConvertImage (T.pack fp) (tshow e)
-      _ -> return ()
-
 getMetadataFromFiles :: PandocMonad m
                      => Text -> ReaderOptions -> [FilePath] -> m Meta
 getMetadataFromFiles readerFormat readerOpts = \case

src/Text/Pandoc/Image.hs

@@ -10,7 +10,7 @@ Portability : portable
 
 Functions for converting images.
 -}
-module Text.Pandoc.Image ( svgToPngIO ) where
+module Text.Pandoc.Image ( createPngFallback, svgToPngIO ) where
 import Text.Pandoc.Process (pipeProcess)
 import qualified Data.ByteString.Lazy as L
 import System.Exit
@@ -20,6 +20,9 @@ import qualified Control.Exception as E
 import Control.Monad.IO.Class (MonadIO(liftIO))
 import Text.Pandoc.Class.PandocMonad
 import qualified Data.Text as T
+import Text.Pandoc.Logging (LogMessage(CouldNotConvertImage))
+import Data.ByteString.Lazy (ByteString)
+import Text.Pandoc.MediaBag (MediaItem, lookupMedia)
 import Text.Printf (printf)
 
 -- | Convert svg image to png. rsvg-convert
@@ -44,4 +47,16 @@ svgToPngIO dpi widthPt heightPt bs = do
               else Left "conversion from SVG failed")
        (\(e :: E.SomeException) -> return $ Left $
            "check that rsvg-convert is in path.\n" <> tshow e)
-  where pt name = maybe [] $ \points -> ["--" <> name, printf "%.6fpt" points]
+  where pt name = maybe [] $ \points -> ["--" <> name, printf "%.6fpt" points]
+
+createPngFallback :: (PandocMonad m) => Int -> (Double, Double) -> FilePath -> ByteString -> m (Maybe MediaItem)
+createPngFallback dpi (xPt, yPt) fp bs = do
+  -- create fallback pngs for svgs
+  res <- svgToPng dpi (Just xPt) (Just yPt) bs
+  case res of
+    Right bs' -> do
+      insertMedia fp (Just "image/png") bs'
+      lookupMedia fp <$> getMediaBag
+    Left e -> do
+      report $ CouldNotConvertImage (T.pack fp) (tshow e)
+      return Nothing

src/Text/Pandoc/Writers/Docx/OpenXML.hs

@@ -24,6 +24,7 @@ import Control.Monad (when, unless)
 import Control.Applicative ((<|>))
 import Control.Monad.Except (catchError)
 import Crypto.Hash (hashWith, SHA1(SHA1))
+import Data.ByteString (ByteString)
 import qualified Data.ByteString.Lazy as BL
 import Data.Char (isLetter, isSpace)
 import Text.Pandoc.Char (isCJK)
@@ -48,6 +49,7 @@ import Text.Pandoc.UTF8 (fromText)
 import Text.Pandoc.Definition
 import Text.Pandoc.Highlighting (highlight)
 import Text.Pandoc.Templates (compileDefaultTemplate, renderTemplate)
+import Text.Pandoc.Image (createPngFallback)
 import Text.Pandoc.ImageSize
 import Text.Pandoc.Logging
 import Text.Pandoc.MIME (extensionFromMimeType, getMimeType)
@@ -60,6 +62,7 @@ import Text.Pandoc.Walk
 import qualified Text.Pandoc.Writers.GridTable as Grid
 import Text.Pandoc.Writers.Math
 import Text.Pandoc.Writers.Shared
+import Text.Printf (printf)
 import Text.TeXMath
 import Text.Pandoc.Writers.OOXML
 import Text.Pandoc.XML.Light as XML
@@ -718,6 +721,16 @@ formattedRun els = do
   props <- getTextProps
   return $ mknode "w:r" [] $ props ++ els
 
+getOrCreateFallback :: PandocMonad m => Int -> (Integer, Integer) -> FilePath -> ByteString -> m (Maybe MediaItem)
+getOrCreateFallback dpi (xemu, yemu) src' img = do
+  mediabag <- getMediaBag
+  let src = printf "%s_%d_%d.png" src' xemu yemu
+  let xyPt = (fromIntegral xemu / 12700.0, fromIntegral yemu / 12700.0)
+  case lookupMedia src mediabag of
+    Just item -> return $ Just item
+    Nothing -> createPngFallback dpi xyPt src $ BL.fromStrict img
+
+ -- | Convert an inline element to OpenXML.
 -- | Convert an inline element to OpenXML.
 inlineToOpenXML :: PandocMonad m => WriterOptions -> Inline -> WS m [Content]
 inlineToOpenXML opts il = withDirection $ inlineToOpenXML' opts il
@@ -919,17 +932,26 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do
   imgs <- gets stImages
   let
     stImage = M.lookup (T.unpack src) imgs
-    generateImgElt (ident, _fp, mt, img) = do
+    generateImgElt (ident, fp, mt, img) = do
       docprid <- getUniqueId
       nvpicprid <- getUniqueId
+      let
+        (xpt,ypt) = desiredSizeInPoints opts attr
+               (either (const def) id (imageSize opts img))
+        -- 12700 emu = 1 pt
+        pageWidthPt = case dimension Width attr of
+                        Just (Percent a) -> pageWidth * floor (a * 127)
+                        _                -> pageWidth * 12700
+        (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) pageWidthPt
       (blipAttrs, blipContents) <-
         case T.takeWhile (/=';') <$> mt of
           Just "image/svg+xml" -> do
             -- get fallback png
-            mediabag <- getMediaBag
+            fallback <- getOrCreateFallback (writerDpi opts) (xemu, yemu) fp img
             mbFallback <-
-              case lookupMedia (T.unpack (src <> ".png")) mediabag of
+              case fallback of
                 Just item -> do
+                  P.trace $ "Found fallback " <> tshow (mediaPath item)
                   id' <- T.unpack . ("rId" <>) <$> getUniqueId
                   let fp' = "media/" <> id' <> ".png"
                   let imgdata = (id',
@@ -956,13 +978,6 @@ inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do
                     [extLst])
           _ -> return ([("r:embed", T.pack ident)], [])
       let
-        (xpt,ypt) = desiredSizeInPoints opts attr
-               (either (const def) id (imageSize opts img))
-        -- 12700 emu = 1 pt
-        pageWidthPt = case dimension Width attr of
-                        Just (Percent a) -> pageWidth * floor (a * 127)
-                        _                -> pageWidth * 12700
-        (xemu,yemu) = fitToPage (xpt * 12700, ypt * 12700) pageWidthPt
         cNvPicPr = mknode "pic:cNvPicPr" [] $
                          mknode "a:picLocks" [("noChangeArrowheads","1")
                                              ,("noChangeAspect","1")] ()