Allow --extract-media to extract to a tar archive...

instead of a directory.  This happens when the path given has a
.tar extension.

1 files changed, 21 insertions, 4 deletions

diff --git a/src/Text/Pandoc/Class/IO.hs b/src/Text/Pandoc/Class/IO.hs
index 612ab7f51..c1bbff714 100644
--- a/src/Text/Pandoc/Class/IO.hs
+++ b/src/Text/Pandoc/Class/IO.hs
@@ -62,7 +62,7 @@ import qualified Data.CaseInsensitive as CI
 #endif
 import Network.URI (URI(..), parseURI, unEscapeString)
 import System.Directory (createDirectoryIfMissing)
-import System.FilePath ((</>), takeDirectory, normalise)
+import System.FilePath ((</>), takeDirectory, takeFileName, normalise, takeExtension)
 import qualified System.FilePath.Posix as Posix
 import System.IO (stderr)
 import System.IO.Error
@@ -88,6 +88,8 @@ import qualified System.Environment as Env
 import qualified System.FilePath.Glob
 import qualified System.Random
 import qualified Text.Pandoc.UTF8 as UTF8
+import Codec.Archive.Tar (write)
+import Codec.Archive.Tar.Entry (fileEntry, toTarPath)
 #ifndef EMBED_DATA_FILES
 import qualified Paths_pandoc as Paths
 #endif
@@ -245,16 +247,31 @@ alertIndent (l:ls) = do
   where go l' = do UTF8.hPutStr stderr "  "
                    UTF8.hPutStrLn stderr l'
 
--- | Extract media from the mediabag into a directory.
+-- | Extract media from the mediabag into a directory (or a tar archive if the
+-- path supplied ends in @.tar@.
 extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc
-extractMedia dir d = do
+extractMedia path d = do
   media <- getMediaBag
   let items = mediaItems media
+  let (dir, mbTar) = case takeExtension path of
+                       ".tar" -> (takeDirectory path, Just (takeFileName path))
+                       _ -> (path, Nothing)
   if null items
     then return d
     else do
-      mapM_ (writeMedia dir) items
+      case mbTar of
+        Just fname -> case write <$> traverse toEntry items of
+                    Left e -> throwError
+                               (PandocSomeError (T.pack
+                                 ("Could not create " <> path <> ":\n" <> e)))
+                    Right tar -> writeMedia dir
+                                  (fname, "application/x-tar", tar)
+        Nothing -> mapM_ (writeMedia dir) items
       return $ walk (adjustImagePath dir media) d
+ where
+  toEntry (fp, _mime, content) = do
+    tarPath <- toTarPath False fp  -- False = file, not directory
+    pure $ fileEntry tarPath content
 
 -- | Write the contents of a media bag to a path.
 -- If the path contains URI escape sequences (percent-encoding),