docx: use proper DPI for fallback PNG

pandoc-lua-engine/src/Text/Pandoc/Lua/PandocLua.hs

@@ -70,6 +70,7 @@ instance PandocMonad PandocLua where
   readFileLazy = IO.readFileLazy
   readFileStrict = IO.readFileStrict
   readStdinStrict = IO.readStdinStrict
+  svgToPng = IO.svgToPng
 
   glob = IO.glob
   fileExists = IO.fileExists

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, MonadIO 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/Class/IO.hs

@@ -31,6 +31,7 @@ module Text.Pandoc.Class.IO
   , readFileLazy
   , readFileStrict
   , readStdinStrict
+  , svgToPng
   , extractMedia
   , writeMedia
  ) where
@@ -80,6 +81,7 @@ import qualified System.Environment as Env
 import qualified System.FilePath.Glob
 import qualified System.Random
 import qualified Text.Pandoc.UTF8 as UTF8
+import Text.Pandoc.Image (svgToPngIO)
 #ifndef EMBED_DATA_FILES
 import qualified Paths_pandoc as Paths
 #endif
@@ -170,6 +172,11 @@ readFileStrict s = liftIOError B.readFile s
 readStdinStrict :: (PandocMonad m, MonadIO m) => m B.ByteString
 readStdinStrict = liftIOError (const B.getContents) "stdin"
 
+-- | Runs an image conversion step, returning an error on failure.
+-- Not available when sandboxed.
+svgToPng :: (PandocMonad m, MonadIO m) => Int -> Maybe Double -> Maybe Double -> BL.ByteString -> m (Either T.Text BL.ByteString)
+svgToPng = svgToPngIO
+
 -- | Return a list of paths that match a glob, relative to the working
 -- directory. See 'System.FilePath.Glob' for the glob syntax.
 glob :: (PandocMonad m, MonadIO m) => String -> m [FilePath]

src/Text/Pandoc/Class/PandocIO.hs

@@ -63,6 +63,7 @@ instance PandocMonad PandocIO where
   readFileLazy = IO.readFileLazy
   readFileStrict = IO.readFileStrict
   readStdinStrict = IO.readStdinStrict
+  svgToPng = IO.svgToPng
 
   glob = IO.glob
   fileExists = IO.fileExists

src/Text/Pandoc/Class/PandocMonad.hs

@@ -116,6 +116,9 @@ class (Functor m, Applicative m, Monad m, MonadError PandocError m)
   -- | Read the contents of stdin as a strict ByteString, raising
   -- an error on failure.
   readStdinStrict :: m B.ByteString
+  -- | Converts an SVG to a PNG (dpiX, widthPoints, heightPoints, svgBlob)
+  -- Not called when sandboxed.
+  svgToPng :: Int -> Maybe Double -> Maybe Double -> BL.ByteString -> m (Either T.Text BL.ByteString)
   -- | Return a list of paths that match a glob, relative to
   -- the working directory.  See 'System.FilePath.Glob' for
   -- the glob syntax.
@@ -505,6 +508,7 @@ instance (MonadTrans t, PandocMonad m, Functor (t m),
   readFileLazy = lift . readFileLazy
   readFileStrict = lift . readFileStrict
   readStdinStrict = lift readStdinStrict
+  svgToPng dpi width height bs = lift $ svgToPng dpi width height bs
   glob = lift . glob
   fileExists = lift . fileExists
   getDataFileName = lift . getDataFileName
@@ -523,6 +527,7 @@ instance {-# OVERLAPS #-} PandocMonad m => PandocMonad (ParsecT s st m) where
   readFileLazy = lift . readFileLazy
   readFileStrict = lift . readFileStrict
   readStdinStrict = lift readStdinStrict
+  svgToPng dpi width height bs = lift $ svgToPng dpi width height bs
   glob = lift . glob
   fileExists = lift . fileExists
   getDataFileName = lift . getDataFileName

src/Text/Pandoc/Class/PandocPure.hs

@@ -205,6 +205,8 @@ instance PandocMonad PandocPure where
       Nothing -> throwError $ PandocResourceNotFound $ T.pack fp
 
   readStdinStrict = getsPureState stStdin
+
+  svgToPng _ _ _ _ = return $ Left "SVG conversion not available in PandocPure"
 
   glob s = do
     FileTree ftmap <- getsPureState stFiles

src/Text/Pandoc/Image.hs

@@ -10,29 +10,53 @@ Portability : portable
 
 Functions for converting images.
 -}
-module Text.Pandoc.Image ( svgToPng ) where
+module Text.Pandoc.Image ( createPngFallback, svgToPngIO ) where
 import Text.Pandoc.Process (pipeProcess)
 import qualified Data.ByteString.Lazy as L
 import System.Exit
 import Data.Text (Text)
 import Text.Pandoc.Shared (tshow)
 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
 -- is used and must be available on the path.
-svgToPng :: MonadIO m
+svgToPngIO :: (PandocMonad m, MonadIO m)
          => Int           -- ^ DPI
+         -> Maybe Double        -- ^ width in Points
+         -> Maybe Double        -- ^ height in Points
          -> L.ByteString  -- ^ Input image as bytestring
          -> m (Either Text L.ByteString)
-svgToPng dpi bs = do
+svgToPngIO dpi widthPt heightPt bs = do
   let dpi' = show dpi
+  let args = ["-f","png","-a","--dpi-x",dpi',"--dpi-y",dpi']
+        ++ pt "width" widthPt ++ pt "height" heightPt
+  trace (T.intercalate " " $ map T.pack $ "rsvg-convert" : args)
   liftIO $ E.catch
        (do (exit, out) <- pipeProcess Nothing "rsvg-convert"
-                          ["-f","png","-a","--dpi-x",dpi',"--dpi-y",dpi']
+                          args
                           bs
            return $ if exit == ExitSuccess
               then Right out
               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]
+
+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/ImageSize.hs

@@ -166,8 +166,8 @@ sizeInPoints s = (pxXf * 72 / dpiXf, pxYf * 72 / dpiYf)
 -- | Calculate (height, width) in points, considering the desired dimensions in the
 -- attribute, while falling back on the image file's dpi metadata if no dimensions
 -- are specified in the attribute (or only dimensions in percentages).
-desiredSizeInPoints :: WriterOptions -> Attr -> ImageSize -> (Double, Double)
-desiredSizeInPoints opts attr s =
+desiredSizeInPoints :: WriterOptions -> Attr -> Maybe Integer -> ImageSize -> (Double, Double)
+desiredSizeInPoints opts attr pageWidthPoints' s =
   case (getDim Width, getDim Height) of
     (Just w, Just h)   -> (w, h)
     (Just w, Nothing)  -> (w, w / ratio)
@@ -176,7 +176,11 @@ desiredSizeInPoints opts attr s =
   where
     ratio = fromIntegral (pxX s) / fromIntegral (pxY s)
     getDim dir = case dimension dir attr of
-                   Just (Percent _) -> Nothing
+                   Just (Percent a) ->
+                     case (dir, pageWidthPoints') of
+                     (Width, Just pageWidthPoints) ->
+                       Just $ fromIntegral pageWidthPoints * a
+                     _ -> Nothing
                    Just dim         -> Just $ inPoints opts dim
                    Nothing          -> Nothing
 

src/Text/Pandoc/Writers/Docx.hs

@@ -36,8 +36,7 @@ import Control.Monad.State.Strict ( StateT(runStateT), gets, modify )
 import qualified Data.ByteString.Lazy as BL
 import Data.Containers.ListUtils (nubOrd)
 import Data.Char (isSpace, isLetter)
-import Data.List (intercalate, isPrefixOf, isSuffixOf, sortBy)
-import Data.Ord (comparing)
+import Data.List (intercalate, isPrefixOf, isSuffixOf, sortOn)
 import Data.String (fromString)
 import qualified Data.Map as M
 import Data.Maybe (fromMaybe, isNothing, mapMaybe, maybeToList, isJust)
@@ -78,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
@@ -126,7 +128,7 @@ rPrTagOrder =
 
 sortSquashed :: [Element] -> [Element]
 sortSquashed l =
-  sortBy (comparing tagIndex) l
+  sortOn tagIndex l
   where
     tagIndex :: Element -> Int
     tagIndex el =
@@ -1322,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
@@ -1519,21 +1530,30 @@ inlineToOpenXML' opts (Link _ txt (src,_)) = do
               return i
   return [ Elem $ mknode "w:hyperlink" [("r:id",id')] contents ]
 inlineToOpenXML' opts (Image attr@(imgident, _, _) alt (src, title)) = do
-  pageWidth <- asks envPrintWidth
+  pageWidth <- asks envPrintWidth -- in Points
   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 (Just pageWidth)
+               (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',
@@ -1560,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")] ()

src/Text/Pandoc/Writers/ICML.hs

@@ -613,7 +613,7 @@ imageICML opts style attr (src, _) = do
                report $ CouldNotFetchResource src $ tshow e
                return def)
   let (ow, oh) = sizeInPoints imgS
-      (imgWidth, imgHeight) = desiredSizeInPoints opts attr imgS
+      (imgWidth, imgHeight) = desiredSizeInPoints opts attr Nothing imgS
       hw = showFl $ ow / 2
       hh = showFl $ oh / 2
       scale = showFl (imgWidth / ow) <> " 0 0 " <> showFl (imgHeight / oh)

src/Text/Pandoc/Writers/RTF.hs

@@ -64,7 +64,7 @@ rtfEmbedImage opts x@(Image attr _ (src,_)) = catchError
                                 <> "\\pichgoal" <> tshow (floor (ypt * 20) :: Integer)
                         -- twip = 1/1440in = 1/20pt
                         where (xpx, ypx) = sizeInPixels sz
-                              (xpt, ypt) = desiredSizeInPoints opts attr sz
+                              (xpt, ypt) = desiredSizeInPoints opts attr Nothing sz
              let raw = "{\\pict" <> filetype <> sizeSpec <> " " <>
                         T.concat bytes <> "}"
              if B.null imgdata

test/command/9288.md

@@ -0,0 +1,49 @@
+```
+% pandoc -f native -t docx -o 9288.docx  --trace --quiet
+[ Figure
+    ( "" , [] , [] )
+    (Caption Nothing [ Plain [ Str "5in" ] ])
+    [ Plain
+        [ Image
+            ( "" , [] , [ ( "width" , "5in" ) ] )
+            [ Str "5in" ]
+            ( "command/SVG_logo.svg" , "" )
+        ]
+    ]
+, Figure
+    ( "" , [] , [] )
+    (Caption Nothing [ Plain [ Str "5in" ] ])
+    [ Plain
+        [ Image
+            ( "" , [] , [ ( "width" , "5in" ) ] )
+            [ Str "5in" ]
+            ( "command/SVG_logo.svg" , "" )
+        ]
+    ]
+, Figure
+    ( "" , [] , [] )
+    (Caption Nothing [ Plain [ Str "80%" ] ])
+    [ Plain
+        [ Image
+            ( "" , [] , [ ( "width" , "80%" ) ] )
+            [ Str "5in" ]
+            ( "command/SVG_logo.svg" , "" )
+        ]
+    ]
+, Figure
+    ( "" , [] , [] )
+    (Caption Nothing [ Plain [ Str "default" ] ])
+    [ Plain
+        [ Image
+            ( "" , [] , [] )
+            [ Str "5in" ]
+            ( "command/SVG_logo.svg" , "" )
+        ]
+    ]
+]
+^D
+2> [trace] rsvg-convert -f png -a --dpi-x 96 --dpi-y 96 --width 360.000000pt --height 360.000000pt
+2> [trace] rsvg-convert -f png -a --dpi-x 96 --dpi-y 96 --width 360.000000pt --height 360.000000pt
+2> [trace] rsvg-convert -f png -a --dpi-x 96 --dpi-y 96 --width 336.000000pt --height 336.000000pt
+2> [trace] rsvg-convert -f png -a --dpi-x 96 --dpi-y 96 --width 75.000000pt --height 75.000000pt
+```