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,8 +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.Image (svgToPng)
 import Text.Pandoc.App.Opt (Opt (..), LineEnding (..), defaultOpts,
                             IpynbOutput (..), OptInfo(..))
 import Text.Pandoc.App.CommandLineOptions (parseOptions, parseOptionsFromArgs,
@@ -65,7 +63,7 @@ import Text.Pandoc.PDF (makePDF)
 import Text.Pandoc.Scripting (ScriptingEngine (..), CustomComponents(..))
 import Text.Pandoc.SelfContained (makeSelfContained)
 import Text.Pandoc.Shared (eastAsianLineBreakFilter,
-         headerShift, filterIpynbOutput, tshow)
+         headerShift, filterIpynbOutput)
 import Text.Pandoc.URI (isURI)
 import Text.Pandoc.Writers.Shared (lookupMetaString)
 import Text.Pandoc.Readers.Markdown (yamlToMeta)
@@ -307,9 +305,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
@@ -372,21 +367,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 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,18 +10,38 @@ Portability : portable
 
 Functions for converting images.
 -}
-module Text.Pandoc.Image ( svgToPng ) where
+module Text.Pandoc.Image ( createPngFallback, svgToPng ) where
 import qualified Data.ByteString.Lazy as L
 import Data.Text (Text)
 import Text.Pandoc.Class.PandocMonad
+import qualified Data.Text as T
+import Text.Pandoc.Logging (LogMessage(CouldNotConvertImage))
+import Text.Pandoc.Shared (tshow)
+import Data.ByteString.Lazy (ByteString)
+import Text.Pandoc.MediaBag (MediaItem, lookupMedia)
+import Text.Printf (printf)
 
 -- | Convert svg image to png. rsvg-convert
 -- is used and must be available on the path.
 svgToPng :: (PandocMonad m)
          => Int           -- ^ DPI
+         -> (Double, Double) -- ^ desired size in Points
          -> L.ByteString  -- ^ Input image as bytestring
          -> m (Either Text L.ByteString)
-svgToPng dpi bs = do
+svgToPng dpi (xPt, yPt) bs = do
   let dpi' = show dpi
-  let args = ["-f","png","-a","--dpi-x",dpi',"--dpi-y",dpi']
-  runConversion ("rsvg-convert", args, bs)
+  let args = ["-f","png","-a","--dpi-x",dpi',"--dpi-y",dpi',"--width", pt xPt, "--height", pt yPt]
+  runConversion ("rsvg-convert", args, bs)
+  where pt points = printf "%.6fpt" points
+
+createPngFallback :: (PandocMonad m) => Int -> (Double, Double) -> FilePath -> ByteString -> m (Maybe MediaItem)
+createPngFallback dpi xyPt fp bs = do
+  -- create fallback pngs for svgs
+  res <- svgToPng dpi xyPt 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.hs

@@ -77,6 +77,9 @@ import Text.Pandoc.Writers.OOXML
 import Text.Pandoc.XML.Light as XML
 import Data.Generics (mkT, everywhere)
 import Text.Collate.Lang (renderLang, Lang(..))
+import Text.Pandoc.Image (createPngFallback)
+import Data.ByteString (ByteString)
+import Text.Printf (printf)
 
 -- from wml.xsd EG_RPrBase
 rPrTagOrder :: M.Map Text Int
@@ -1321,6 +1324,15 @@ 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.
 inlineToOpenXML :: PandocMonad m => WriterOptions -> Inline -> WS m [Content]
 inlineToOpenXML opts il = withDirection $ inlineToOpenXML' opts il
@@ -1522,17 +1534,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',
@@ -1559,13 +1580,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")] ()