From eae790485325ba6993b29d7b3ad638fefb1d21ee Mon Sep 17 00:00:00 2001 From: Jesse Rosenthal Date: Thu, 18 Jan 2018 09:41:16 -0500 Subject: Powerpoint writer: Make our own docProps/core.xml file. This allows us to set document metadata properties from pandoc metadata. --- src/Text/Pandoc/Writers/Powerpoint/Output.hs | 39 ++++++++++++++++++---- src/Text/Pandoc/Writers/Powerpoint/Presentation.hs | 9 ++--- 2 files changed, 37 insertions(+), 11 deletions(-) (limited to 'src/Text/Pandoc') diff --git a/src/Text/Pandoc/Writers/Powerpoint/Output.hs b/src/Text/Pandoc/Writers/Powerpoint/Output.hs index 45ae86352..f0485adcc 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Output.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Output.hs @@ -40,6 +40,7 @@ import Control.Monad.State import Codec.Archive.Zip import Data.List (intercalate, stripPrefix, nub, union, isPrefixOf) import Data.Default +import Text.Pandoc.Compat.Time (formatTime, defaultTimeLocale) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import System.FilePath.Posix (splitDirectories, splitExtension, takeExtension) @@ -54,7 +55,7 @@ import Text.Pandoc.MIME import qualified Data.ByteString.Lazy as BL import Text.Pandoc.Writers.OOXML import qualified Data.Map as M -import Data.Maybe (mapMaybe, listToMaybe) +import Data.Maybe (mapMaybe, listToMaybe, fromMaybe) import Text.Pandoc.ImageSize import Control.Applicative ((<|>)) import System.FilePath.Glob @@ -166,7 +167,6 @@ copyFileToArchive arch fp = do inheritedPatterns :: [Pattern] inheritedPatterns = map compile [ "docProps/app.xml" - , "docProps/core.xml" , "ppt/slideLayouts/slideLayout*.xml" , "ppt/slideLayouts/_rels/slideLayout*.xml.rels" , "ppt/slideMasters/slideMaster1.xml" @@ -194,7 +194,6 @@ patternsToFilePaths pats = concat <$> mapM patternToFilePaths pats -- any of these are missing, we should error out of our build. requiredFiles :: [FilePath] requiredFiles = [ "docProps/app.xml" - , "docProps/core.xml" , "ppt/presProps.xml" , "ppt/slideLayouts/slideLayout1.xml" , "ppt/slideLayouts/_rels/slideLayout1.xml.rels" @@ -213,7 +212,7 @@ requiredFiles = [ "docProps/app.xml" presentationToArchiveP :: PandocMonad m => Presentation -> P m Archive -presentationToArchiveP p@(Presentation _ slides) = do +presentationToArchiveP p@(Presentation docProps slides) = do filePaths <- patternsToFilePaths inheritedPatterns -- make sure all required files are available: @@ -226,6 +225,8 @@ presentationToArchiveP p@(Presentation _ slides) = do ) newArch' <- foldM copyFileToArchive emptyArchive filePaths + -- we make a docProps/core.xml entry out of the presentation docprops + docPropsEntry <- docPropsToEntry docProps -- we make this ourself in case there's something unexpected in the -- one in the reference doc. relsEntry <- topLevelRelsEntry @@ -244,7 +245,7 @@ presentationToArchiveP p@(Presentation _ slides) = do slideEntries ++ slideRelEntries ++ mediaEntries ++ - [contentTypesEntry, relsEntry, presEntry, presRelsEntry] + [contentTypesEntry, docPropsEntry, relsEntry, presEntry, presRelsEntry] makeSlideIdMap :: Presentation -> M.Map SlideId Int makeSlideIdMap (Presentation _ slides) = @@ -1313,7 +1314,30 @@ presentationToPresEntry :: PandocMonad m => Presentation -> P m Entry presentationToPresEntry pres = presentationToPresentationElement pres >>= elemToEntry "ppt/presentation.xml" - +-- adapted from the Docx writer +docPropsElement :: PandocMonad m => DocProps -> P m Element +docPropsElement docProps = do + utctime <- asks envUTCTime + let keywords = case dcKeywords docProps of + Just xs -> intercalate "," xs + Nothing -> "" + return $ + mknode "cp:coreProperties" + [("xmlns:cp","http://schemas.openxmlformats.org/package/2006/metadata/core-properties") + ,("xmlns:dc","http://purl.org/dc/elements/1.1/") + ,("xmlns:dcterms","http://purl.org/dc/terms/") + ,("xmlns:dcmitype","http://purl.org/dc/dcmitype/") + ,("xmlns:xsi","http://www.w3.org/2001/XMLSchema-instance")] + $ (mknode "dc:title" [] $ fromMaybe "" $ dcTitle docProps) + : (mknode "dc:creator" [] $ fromMaybe "" $ dcCreator docProps) + : (mknode "cp:keywords" [] keywords) + : (\x -> [ mknode "dcterms:created" [("xsi:type","dcterms:W3CDTF")] x + , mknode "dcterms:modified" [("xsi:type","dcterms:W3CDTF")] x + ]) (formatTime defaultTimeLocale "%FT%XZ" utctime) + +docPropsToEntry :: PandocMonad m => DocProps -> P m Entry +docPropsToEntry docProps = docPropsElement docProps >>= + elemToEntry "docProps/core.xml" defaultContentTypeToElem :: DefaultContentType -> Element @@ -1396,6 +1420,7 @@ presentationToContentTypes (Presentation _ slides) = do (mapMaybe mediaFileContentType $ mediaFps) inheritedOverrides = mapMaybe pathToOverride filePaths + docPropsOverride = mapMaybe pathToOverride ["docProps/core.xml"] presOverride = mapMaybe pathToOverride ["ppt/presentation.xml"] relativePaths <- mapM slideToFilePath slides let slideOverrides = mapMaybe @@ -1403,7 +1428,7 @@ presentationToContentTypes (Presentation _ slides) = do relativePaths return $ ContentTypes (defaults ++ mediaDefaults) - (inheritedOverrides ++ presOverride ++ slideOverrides) + (inheritedOverrides ++ docPropsOverride ++ presOverride ++ slideOverrides) presML :: String presML = "application/vnd.openxmlformats-officedocument.presentationml" diff --git a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs index 1300bbe39..e1192745f 100644 --- a/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs +++ b/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -34,6 +34,7 @@ Presentation. module Text.Pandoc.Writers.Powerpoint.Presentation ( documentToPresentation , Presentation(..) + , DocProps(..) , Slide(..) , Layout(..) , Notes(..) @@ -852,13 +853,13 @@ metaToDocProps meta = Just (MetaList xs) -> Just $ map Shared.stringify xs _ -> Nothing - authors = case lookupMeta "author" meta of - Just (MetaList xs) -> Just $ map Shared.stringify xs - _ -> Nothing + authors = case map Shared.stringify $ docAuthors meta of + [] -> Nothing + ss -> Just $ intercalate ";" ss in DocProps{ dcTitle = Shared.stringify <$> lookupMeta "title" meta , dcSubject = Shared.stringify <$> lookupMeta "subject" meta - , dcCreator = (intercalate "; ") <$> authors + , dcCreator = authors , dcKeywords = keywords , dcCreated = Nothing } -- cgit v1.2.3