@@ -74,356 +74,57 @@ module Text.Pandoc.Class ( PandocMonad(..)
7474 , Translations
7575 ) where
7676
77−import Prelude
78−import System.Random (StdGen, next, mkStdGen)
79−import qualified System.Random as IO (newStdGen)
8077import Codec.Archive.Zip
81−import qualified Data.CaseInsensitive as CI
82−import Data.Unique (hashUnique)
83−import qualified Data.Unique as IO (newUnique)
84−import qualified Text.Pandoc.UTF8 as UTF8
85−import qualified System.Directory as Directory
86−import Data.Time (UTCTime)
87−import Text.Pandoc.Logging
88−import Text.Pandoc.Shared (uriPathToPath)
89−import Text.Parsec (ParsecT, getPosition, sourceLine, sourceName)
90−import qualified Data.Time as IO (getCurrentTime)
91−import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType)
92−import Text.Pandoc.Definition
93−import Data.Digest.Pure.SHA (sha1, showDigest)
94−import Data.Maybe (fromMaybe)
95−import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds
96− , posixSecondsToUTCTime
97− , POSIXTime )
98−import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime, utc)
78+import Control.Monad.Except
79+import Control.Monad.State.Strict
9980import Data.ByteString.Base64 (decodeLenient)
100−import Network.URI ( escapeURIString, nonStrictRelativeTo,
101− unEscapeString, parseURIReference, isAllowedInURI,
102− parseURI, URI(..) )
81+import Data.ByteString.Lazy (toChunks)
82+import Data.Default
83+import Data.Time (UTCTime)
84+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
85+import Data.Time.LocalTime (TimeZone, utc)
86+import Data.Unique (hashUnique)
87+import Data.Word (Word8)
10388import Network.HTTP.Client
10489 (httpLbs, responseBody, responseHeaders,
10590 Request(port, host, requestHeaders), parseRequest, newManager)
10691import Network.HTTP.Client.Internal (addProxy)
10792import Network.HTTP.Client.TLS (tlsManagerSettings)
108−import System.Environment (getEnv)
10993import Network.HTTP.Types.Header ( hContentType )
11094import Network.Socket (withSocketsDo)
111−import Data.ByteString.Lazy (toChunks)
112−import qualified Control.Exception as E
113−import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
95+import Network.URI ( unEscapeString )
96+import Prelude
97+import System.Directory (createDirectoryIfMissing, getDirectoryContents,
98+ doesDirectoryExist)
99+import System.Environment (getEnv)
100+import System.FilePath ((</>), takeDirectory, normalise)
101+import System.FilePath.Glob (match, compile)
102+import System.IO (stderr)
103+import System.IO.Error
104+import System.Random (StdGen, next, mkStdGen)
105+import Text.Pandoc.Class.CommonState (CommonState (..))
106+import Text.Pandoc.Class.PandocMonad
107+import Text.Pandoc.Definition
108+import Text.Pandoc.Error
109+import Text.Pandoc.Logging
114110import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)
115−import Text.Pandoc.Walk (walkM, walk)
116−import qualified Text.Pandoc.MediaBag as MB
111+import Text.Pandoc.Translations (Translations)
112+import Text.Pandoc.Walk (walk)
113+import qualified Control.Exception as E
117114import qualified Data.ByteString as B
118115import qualified Data.ByteString.Lazy as BL
119−import qualified System.Environment as IO (lookupEnv)
120−import System.FilePath.Glob (match, compile)
121−import System.Directory (createDirectoryIfMissing, getDirectoryContents,
122− doesDirectoryExist)
123−import System.FilePath
124− ((</>), (<.>), takeDirectory, takeExtension, dropExtension,
125− isRelative, normalise, splitDirectories)
126−import qualified System.FilePath.Glob as IO (glob)
127−import qualified System.FilePath.Posix as Posix
128−import qualified System.Directory as IO (getModificationTime)
129−import Control.Monad.State.Strict
130−import Control.Monad.Except
131−import Data.Word (Word8)
132−import Data.Default
133−import System.IO.Error
134−import System.IO (stderr)
116+import qualified Data.CaseInsensitive as CI
135117import qualified Data.Map as M
136118import qualified Data.Text as T
137−import Text.Pandoc.Error
138−import Text.Pandoc.BCP47 (Lang(..), parseBCP47, renderLang)
139−import Text.Pandoc.Translations (Term(..), Translations, lookupTerm,
140− readTranslations)
141−import qualified Debug.Trace
142−#ifdef EMBED_DATA_FILES
143−import Text.Pandoc.Data (dataFiles)
144−#else
145−import qualified Paths_pandoc as Paths
146−#endif
147−
148−-- | The PandocMonad typeclass contains all the potentially
149−-- IO-related functions used in pandoc's readers and writers.
150−-- Instances of this typeclass may implement these functions
151−-- in IO (as in 'PandocIO') or using an internal state that
152−-- represents a file system, time, and so on (as in 'PandocPure').
153−class (Functor m, Applicative m, Monad m, MonadError PandocError m)
154− => PandocMonad m where
155− -- | Lookup an environment variable.
156− lookupEnv :: T.Text -> m (Maybe T.Text)
157− -- | Get the current (UTC) time.
158− getCurrentTime :: m UTCTime
159− -- | Get the locale's time zone.
160− getCurrentTimeZone :: m TimeZone
161− -- | Return a new generator for random numbers.
162− newStdGen :: m StdGen
163− -- | Return a new unique integer.
164− newUniqueHash :: m Int
165− -- | Retrieve contents and mime type from a URL, raising
166− -- an error on failure.
167− openURL :: T.Text -> m (B.ByteString, Maybe MimeType)
168− -- | Read the lazy ByteString contents from a file path,
169− -- raising an error on failure.
170− readFileLazy :: FilePath -> m BL.ByteString
171− -- | Read the strict ByteString contents from a file path,
172− -- raising an error on failure.
173− readFileStrict :: FilePath -> m B.ByteString
174− -- | Return a list of paths that match a glob, relative to
175− -- the working directory. See 'System.FilePath.Glob' for
176− -- the glob syntax.
177− glob :: String -> m [FilePath]
178− -- | Returns True if file exists.
179− fileExists :: FilePath -> m Bool
180− -- | Returns the path of data file.
181− getDataFileName :: FilePath -> m FilePath
182− -- | Return the modification time of a file.
183− getModificationTime :: FilePath -> m UTCTime
184− -- | Get the value of the 'CommonState' used by all instances
185− -- of 'PandocMonad'.
186− getCommonState :: m CommonState
187− -- | Set the value of the 'CommonState' used by all instances
188− -- of 'PandocMonad'.
189− -- | Get the value of a specific field of 'CommonState'.
190− putCommonState :: CommonState -> m ()
191− -- | Get the value of a specific field of 'CommonState'.
192− getsCommonState :: (CommonState -> a) -> m a
193− getsCommonState f = f <$> getCommonState
194− -- | Modify the 'CommonState'.
195− modifyCommonState :: (CommonState -> CommonState) -> m ()
196− modifyCommonState f = getCommonState >>= putCommonState . f
197− -- Output a log message.
198− logOutput :: LogMessage -> m ()
199− -- Output a debug message to sterr, using 'Debug.Trace.trace',
200− -- if tracing is enabled. Note: this writes to stderr even in
201− -- pure instances.
202− trace :: T.Text -> m ()
203− trace msg = do
204− tracing <- getsCommonState stTrace
205− when tracing $ Debug.Trace.trace ("[trace] " ++ T.unpack msg) (return ())
206−
207−-- * Functions defined for all PandocMonad instances
208−
209−-- | Set the verbosity level.
210−setVerbosity :: PandocMonad m => Verbosity -> m ()
211−setVerbosity verbosity =
212− modifyCommonState $ \st -> st{ stVerbosity = verbosity }
213−
214−-- | Get the verbosity level.
215−getVerbosity :: PandocMonad m => m Verbosity
216−getVerbosity = getsCommonState stVerbosity
217−
218−-- Get the accomulated log messages (in temporal order).
219−getLog :: PandocMonad m => m [LogMessage]
220−getLog = reverse <$> getsCommonState stLog
221−
222−-- | Log a message using 'logOutput'. Note that 'logOutput' is
223−-- called only if the verbosity level exceeds the level of the
224−-- message, but the message is added to the list of log messages
225−-- that will be retrieved by 'getLog' regardless of its verbosity level.
226−report :: PandocMonad m => LogMessage -> m ()
227−report msg = do
228− verbosity <- getsCommonState stVerbosity
229− let level = messageVerbosity msg
230− when (level <= verbosity) $ logOutput msg
231− modifyCommonState $ \st -> st{ stLog = msg : stLog st }
232−
233−-- | Determine whether tracing is enabled. This affects
234−-- the behavior of 'trace'. If tracing is not enabled,
235−-- 'trace' does nothing.
236−setTrace :: PandocMonad m => Bool -> m ()
237−setTrace useTracing = modifyCommonState $ \st -> st{stTrace = useTracing}
238−
239−-- | Set request header to use in HTTP requests.
240−setRequestHeader :: PandocMonad m
241− => T.Text -- ^ Header name
242− -> T.Text -- ^ Value
243− -> m ()
244−setRequestHeader name val = modifyCommonState $ \st ->
245− st{ stRequestHeaders =
246− (name, val) : filter (\(n,_) -> n /= name) (stRequestHeaders st) }
247−
248−-- | Initialize the media bag.
249−setMediaBag :: PandocMonad m => MediaBag -> m ()
250−setMediaBag mb = modifyCommonState $ \st -> st{stMediaBag = mb}
251−
252−-- Retrieve the media bag.
253−getMediaBag :: PandocMonad m => m MediaBag
254−getMediaBag = getsCommonState stMediaBag
255−
256−-- Insert an item into the media bag.
257−insertMedia :: PandocMonad m => FilePath -> Maybe MimeType -> BL.ByteString -> m ()
258−insertMedia fp mime bs = do
259− mb <- getMediaBag
260− let mb' = MB.insertMedia fp mime bs mb
261− setMediaBag mb'
262−
263−-- Retrieve the input filenames.
264−getInputFiles :: PandocMonad m => m [FilePath]
265−getInputFiles = getsCommonState stInputFiles
266−
267−-- Set the input filenames.
268−setInputFiles :: PandocMonad m => [FilePath] -> m ()
269−setInputFiles fs = do
270− let sourceURL = case fs of
271− [] -> Nothing
272− (x:_) -> case parseURI x of
273− Just u
274− | uriScheme u `elem` ["http:","https:"] ->
275− Just $ show u{ uriQuery = "",
276− uriFragment = "" }
277− _ -> Nothing
278−
279− modifyCommonState $ \st -> st{ stInputFiles = fs
280− , stSourceURL = T.pack <$> sourceURL }
281−
282−-- Retrieve the output filename.
283−getOutputFile :: PandocMonad m => m (Maybe FilePath)
284−getOutputFile = getsCommonState stOutputFile
285−
286−-- Set the output filename.
287−setOutputFile :: PandocMonad m => Maybe FilePath -> m ()
288−setOutputFile mbf = modifyCommonState $ \st -> st{ stOutputFile = mbf }
289−
290−-- Retrieve the resource path searched by 'fetchItem'.
291−getResourcePath :: PandocMonad m => m [FilePath]
292−getResourcePath = getsCommonState stResourcePath
293−
294−-- Set the resource path searched by 'fetchItem'.
295−setResourcePath :: PandocMonad m => [FilePath] -> m ()
296−setResourcePath ps = modifyCommonState $ \st -> st{stResourcePath = ps}
297−
298−-- Get the POSIX time.
299−getPOSIXTime :: PandocMonad m => m POSIXTime
300−getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
301−
302−-- Get the zoned time.
303−getZonedTime :: PandocMonad m => m ZonedTime
304−getZonedTime = do
305− t <- getCurrentTime
306− tz <- getCurrentTimeZone
307− return $ utcToZonedTime tz t
308−
309−-- | Read file, checking in any number of directories.
310−readFileFromDirs :: PandocMonad m => [FilePath] -> FilePath -> m (Maybe T.Text)
311−readFileFromDirs [] _ = return Nothing
312−readFileFromDirs (d:ds) f = catchError
313− ((Just . T.pack . UTF8.toStringLazy) <$> readFileLazy (d </> f))
314− (\_ -> readFileFromDirs ds f)
315−
316−-- | 'CommonState' represents state that is used by all
317−-- instances of 'PandocMonad'. Normally users should not
318−-- need to interact with it directly; instead, auxiliary
319−-- functions like 'setVerbosity' and 'withMediaBag' should be used.
320−data CommonState = CommonState { stLog :: [LogMessage]
321− -- ^ A list of log messages in reverse order
322− , stUserDataDir :: Maybe FilePath
323− -- ^ Directory to search for data files
324− , stSourceURL :: Maybe T.Text
325− -- ^ Absolute URL + dir of 1st source file
326− , stRequestHeaders :: [(T.Text, T.Text)]
327− -- ^ Headers to add for HTTP requests
328− , stMediaBag :: MediaBag
329− -- ^ Media parsed from binary containers
330− , stTranslations :: Maybe
331− (Lang, Maybe Translations)
332− -- ^ Translations for localization
333− , stInputFiles :: [FilePath]
334− -- ^ List of input files from command line
335− , stOutputFile :: Maybe FilePath
336− -- ^ Output file from command line
337− , stResourcePath :: [FilePath]
338− -- ^ Path to search for resources like
339− -- included images
340− , stVerbosity :: Verbosity
341− -- ^ Verbosity level
342− , stTrace :: Bool
343− -- ^ Controls whether tracing messages are
344− -- issued.
345− }
346−
347−instance Default CommonState where
348− def = CommonState { stLog = []
349− , stUserDataDir = Nothing
350− , stSourceURL = Nothing
351− , stRequestHeaders = []
352− , stMediaBag = mempty
353− , stTranslations = Nothing
354− , stInputFiles = []
355− , stOutputFile = Nothing
356− , stResourcePath = ["."]
357− , stVerbosity = WARNING
358− , stTrace = False
359− }
360−
361−-- | Convert BCP47 string to a Lang, issuing warning
362−-- if there are problems.
363−toLang :: PandocMonad m => Maybe T.Text -> m (Maybe Lang)
364−toLang Nothing = return Nothing
365−toLang (Just s) =
366− case parseBCP47 s of
367− Left _ -> do
368− report $ InvalidLang s
369− return Nothing
370− Right l -> return (Just l)
371−
372−-- | Select the language to use with 'translateTerm'.
373−-- Note that this does not read a translation file;
374−-- that is only done the first time 'translateTerm' is
375−-- used.
376−setTranslations :: PandocMonad m => Lang -> m ()
377−setTranslations lang =
378− modifyCommonState $ \st -> st{ stTranslations = Just (lang, Nothing) }
379−
380−-- | Load term map.
381−getTranslations :: PandocMonad m => m Translations
382−getTranslations = do
383− mbtrans <- getsCommonState stTranslations
384− case mbtrans of
385− Nothing -> return mempty -- no language defined
386− Just (_, Just t) -> return t
387− Just (lang, Nothing) -> do -- read from file
388− let translationFile = "translations/" <> renderLang lang <> ".yaml"
389− let fallbackFile = "translations/" <> langLanguage lang <> ".yaml"
390− let getTrans fp = do
391− bs <- readDataFile fp
392− case readTranslations (UTF8.toText bs) of
393− Left e -> do
394− report $ CouldNotLoadTranslations (renderLang lang)
395− (T.pack fp <> ": " <> e)
396− -- make sure we don't try again...
397− modifyCommonState $ \st ->
398− st{ stTranslations = Nothing }
399− return mempty
400− Right t -> do
401− modifyCommonState $ \st ->
402− st{ stTranslations = Just (lang, Just t) }
403− return t
404− catchError (getTrans $ T.unpack translationFile)
405− (\_ ->
406− catchError (getTrans $ T.unpack fallbackFile)
407− (\e -> do
408− report $ CouldNotLoadTranslations (renderLang lang)
409− $ case e of
410− PandocCouldNotFindDataFileError _ ->
411− "data file " <> fallbackFile <> " not found"
412− _ -> ""
413− -- make sure we don't try again...
414− modifyCommonState $ \st -> st{ stTranslations = Nothing }
415− return mempty))
416−
417−-- | Get a translation from the current term map.
418−-- Issue a warning if the term is not defined.
419−translateTerm :: PandocMonad m => Term -> m T.Text
420−translateTerm term = do
421− translations <- getTranslations
422− case lookupTerm term translations of
423− Just s -> return s
424− Nothing -> do
425− report $ NoTranslation $ T.pack $ show term
426− return ""
119+import qualified Data.Time as IO (getCurrentTime)
120+import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
121+import qualified Data.Unique as IO (newUnique)
122+import qualified System.Directory as Directory
123+import qualified System.Directory as IO (getModificationTime)
124+import qualified System.Environment as IO (lookupEnv)
125+import qualified System.FilePath.Glob as IO (glob)
126+import qualified System.Random as IO (newStdGen)
127+import qualified Text.Pandoc.UTF8 as UTF8
427128
428129-- | Evaluate a 'PandocIO' operation.
429130runIO :: PandocIO a -> IO (Either PandocError a)
@@ -519,314 +220,6 @@ alertIndent (l:ls) = do
519220 where go l' = do UTF8.hPutStr stderr " "
520221 UTF8.hPutStrLn stderr $ T.unpack l'
521222
522−-- | Specialized version of parseURIReference that disallows
523−-- single-letter schemes. Reason: these are usually windows absolute
524−-- paths.
525−parseURIReference' :: T.Text -> Maybe URI
526−parseURIReference' s = do
527− u <- parseURIReference (T.unpack s)
528− case uriScheme u of
529− [_] -> Nothing
530− _ -> Just u
531−
532−-- | Set the user data directory in common state.
533−setUserDataDir :: PandocMonad m
534− => Maybe FilePath
535− -> m ()
536−setUserDataDir mbfp = modifyCommonState $ \st -> st{ stUserDataDir = mbfp }
537−
538−-- | Get the user data directory from common state.
539−getUserDataDir :: PandocMonad m
540− => m (Maybe FilePath)
541−getUserDataDir = getsCommonState stUserDataDir
542−
543−-- | Fetch an image or other item from the local filesystem or the net.
544−-- Returns raw content and maybe mime type.
545−fetchItem :: PandocMonad m
546− => T.Text
547− -> m (B.ByteString, Maybe MimeType)
548−fetchItem s = do
549− mediabag <- getMediaBag
550− case lookupMedia (T.unpack s) mediabag of
551− Just (mime, bs) -> return (BL.toStrict bs, Just mime)
552− Nothing -> downloadOrRead s
553−
554−downloadOrRead :: PandocMonad m
555− => T.Text
556− -> m (B.ByteString, Maybe MimeType)
557−downloadOrRead s = do
558− sourceURL <- getsCommonState stSourceURL
559− case (sourceURL >>= parseURIReference' .
560− ensureEscaped, ensureEscaped s) of
561− (Just u, s') -> -- try fetching from relative path at source
562− case parseURIReference' s' of
563− Just u' -> openURL $ T.pack $ show $ u' `nonStrictRelativeTo` u
564− Nothing -> openURL s' -- will throw error
565− (Nothing, s'@(T.unpack -> ('/':'/':c:_))) | c /= '?' -> -- protocol-relative URI
566− -- we exclude //? because of //?UNC/ on Windows
567− case parseURIReference' s' of
568− Just u' -> openURL $ T.pack $ show $ u' `nonStrictRelativeTo` httpcolon
569− Nothing -> openURL s' -- will throw error
570− (Nothing, s') ->
571− case parseURI (T.unpack s') of -- requires absolute URI
572− Just u' | uriScheme u' == "file:" ->
573− readLocalFile $ uriPathToPath (T.pack $ uriPath u')
574− -- We don't want to treat C:/ as a scheme:
575− Just u' | length (uriScheme u') > 2 -> openURL (T.pack $ show u')
576− _ -> readLocalFile fp -- get from local file system
577− where readLocalFile f = do
578− resourcePath <- getResourcePath
579− cont <- if isRelative f
580− then withPaths resourcePath readFileStrict f
581− else readFileStrict f
582− return (cont, mime)
583− httpcolon = URI{ uriScheme = "http:",
584− uriAuthority = Nothing,
585− uriPath = "",
586− uriQuery = "",
587− uriFragment = "" }
588− dropFragmentAndQuery = T.takeWhile (\c -> c /= '?' && c /= '#')
589− fp = unEscapeString $ T.unpack $ dropFragmentAndQuery s
590− mime = getMimeType $ case takeExtension fp of
591− ".gz" -> dropExtension fp
592− ".svgz" -> dropExtension fp ++ ".svg"
593− x -> x
594− ensureEscaped = T.pack . escapeURIString isAllowedInURI . T.unpack . T.map convertSlash
595− convertSlash '\\' = '/'
596− convertSlash x = x
597−
598−-- Retrieve default reference.docx.
599−getDefaultReferenceDocx :: PandocMonad m => m Archive
600−getDefaultReferenceDocx = do
601− let paths = ["[Content_Types].xml",
602− "_rels/.rels",
603− "docProps/app.xml",
604− "docProps/core.xml",
605− "docProps/custom.xml",
606− "word/document.xml",
607− "word/fontTable.xml",
608− "word/footnotes.xml",
609− "word/comments.xml",
610− "word/numbering.xml",
611− "word/settings.xml",
612− "word/webSettings.xml",
613− "word/styles.xml",
614− "word/_rels/document.xml.rels",
615− "word/_rels/footnotes.xml.rels",
616− "word/theme/theme1.xml"]
617− let toLazy = BL.fromChunks . (:[])
618− let pathToEntry path = do
619− epochtime <- (floor . utcTimeToPOSIXSeconds) <$> getCurrentTime
620− contents <- toLazy <$> readDataFile ("docx/" ++ path)
621− return $ toEntry path epochtime contents
622− datadir <- getUserDataDir
623− mbArchive <- case datadir of
624− Nothing -> return Nothing
625− Just d -> do
626− exists <- fileExists (d </> "reference.docx")
627− if exists
628− then return (Just (d </> "reference.docx"))
629− else return Nothing
630− case mbArchive of
631− Just arch -> toArchive <$> readFileLazy arch
632− Nothing -> foldr addEntryToArchive emptyArchive <$>
633− mapM pathToEntry paths
634−
635−-- Retrieve default reference.odt.
636−getDefaultReferenceODT :: PandocMonad m => m Archive
637−getDefaultReferenceODT = do
638− let paths = ["mimetype",
639− "manifest.rdf",
640− "styles.xml",
641− "content.xml",
642− "meta.xml",
643− "settings.xml",
644− "Configurations2/accelerator/current.xml",
645− "Thumbnails/thumbnail.png",
646− "META-INF/manifest.xml"]
647− let pathToEntry path = do epochtime <- floor `fmap` getPOSIXTime
648− contents <- (BL.fromChunks . (:[])) `fmap`
649− readDataFile ("odt/" ++ path)
650− return $ toEntry path epochtime contents
651− datadir <- getUserDataDir
652− mbArchive <- case datadir of
653− Nothing -> return Nothing
654− Just d -> do
655− exists <- fileExists (d </> "reference.odt")
656− if exists
657− then return (Just (d </> "reference.odt"))
658− else return Nothing
659− case mbArchive of
660− Just arch -> toArchive <$> readFileLazy arch
661− Nothing -> foldr addEntryToArchive emptyArchive <$>
662− mapM pathToEntry paths
663−
664−getDefaultReferencePptx :: PandocMonad m => m Archive
665−getDefaultReferencePptx = do
666− -- We're going to narrow this down substantially once we get it
667− -- working.
668− let paths = [ "[Content_Types].xml"
669− , "_rels/.rels"
670− , "docProps/app.xml"
671− , "docProps/core.xml"
672− , "ppt/_rels/presentation.xml.rels"
673− , "ppt/presProps.xml"
674− , "ppt/presentation.xml"
675− , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
676− , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
677− , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
678− , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
679− , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"
680− , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"
681− , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"
682− , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"
683− , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"
684− , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"
685− , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"
686− , "ppt/slideLayouts/slideLayout1.xml"
687− , "ppt/slideLayouts/slideLayout10.xml"
688− , "ppt/slideLayouts/slideLayout11.xml"
689− , "ppt/slideLayouts/slideLayout2.xml"
690− , "ppt/slideLayouts/slideLayout3.xml"
691− , "ppt/slideLayouts/slideLayout4.xml"
692− , "ppt/slideLayouts/slideLayout5.xml"
693− , "ppt/slideLayouts/slideLayout6.xml"
694− , "ppt/slideLayouts/slideLayout7.xml"
695− , "ppt/slideLayouts/slideLayout8.xml"
696− , "ppt/slideLayouts/slideLayout9.xml"
697− , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
698− , "ppt/slideMasters/slideMaster1.xml"
699− , "ppt/slides/_rels/slide1.xml.rels"
700− , "ppt/slides/slide1.xml"
701− , "ppt/slides/_rels/slide2.xml.rels"
702− , "ppt/slides/slide2.xml"
703− , "ppt/slides/_rels/slide3.xml.rels"
704− , "ppt/slides/slide3.xml"
705− , "ppt/slides/_rels/slide4.xml.rels"
706− , "ppt/slides/slide4.xml"
707− , "ppt/tableStyles.xml"
708− , "ppt/theme/theme1.xml"
709− , "ppt/viewProps.xml"
710− -- These relate to notes slides.
711− , "ppt/notesMasters/notesMaster1.xml"
712− , "ppt/notesMasters/_rels/notesMaster1.xml.rels"
713− , "ppt/notesSlides/notesSlide1.xml"
714− , "ppt/notesSlides/_rels/notesSlide1.xml.rels"
715− , "ppt/notesSlides/notesSlide2.xml"
716− , "ppt/notesSlides/_rels/notesSlide2.xml.rels"
717− , "ppt/theme/theme2.xml"
718− ]
719− let toLazy = BL.fromChunks . (:[])
720− let pathToEntry path = do
721− epochtime <- (floor . utcTimeToPOSIXSeconds) <$> getCurrentTime
722− contents <- toLazy <$> readDataFile ("pptx/" ++ path)
723− return $ toEntry path epochtime contents
724− datadir <- getUserDataDir
725− mbArchive <- case datadir of
726− Nothing -> return Nothing
727− Just d -> do
728− exists <- fileExists (d </> "reference.pptx")
729− if exists
730− then return (Just (d </> "reference.pptx"))
731− else return Nothing
732− case mbArchive of
733− Just arch -> toArchive <$> readFileLazy arch
734− Nothing -> foldr addEntryToArchive emptyArchive <$>
735− mapM pathToEntry paths
736−
737−
738−-- | Read file from user data directory or,
739−-- if not found there, from Cabal data directory.
740−readDataFile :: PandocMonad m => FilePath -> m B.ByteString
741−readDataFile fname = do
742− datadir <- getUserDataDir
743− case datadir of
744− Nothing -> readDefaultDataFile fname
745− Just userDir -> do
746− exists <- fileExists (userDir </> fname)
747− if exists
748− then readFileStrict (userDir </> fname)
749− else readDefaultDataFile fname
750−
751−-- | Read file from from Cabal data directory.
752−readDefaultDataFile :: PandocMonad m => FilePath -> m B.ByteString
753−readDefaultDataFile "reference.docx" =
754− (B.concat . BL.toChunks . fromArchive) <$> getDefaultReferenceDocx
755−readDefaultDataFile "reference.pptx" =
756− (B.concat . BL.toChunks . fromArchive) <$> getDefaultReferencePptx
757−readDefaultDataFile "reference.odt" =
758− (B.concat . BL.toChunks . fromArchive) <$> getDefaultReferenceODT
759−readDefaultDataFile fname =
760−#ifdef EMBED_DATA_FILES
761− case lookup (makeCanonical fname) dataFiles of
762− Nothing -> throwError $ PandocCouldNotFindDataFileError $ T.pack fname
763− Just contents -> return contents
764−#else
765− getDataFileName fname' >>= checkExistence >>= readFileStrict
766− where fname' = if fname == "MANUAL.txt" then fname else "data" </> fname
767−
768−checkExistence :: PandocMonad m => FilePath -> m FilePath
769−checkExistence fn = do
770− exists <- fileExists fn
771− if exists
772− then return fn
773− else throwError $ PandocCouldNotFindDataFileError $ T.pack fn
774−#endif
775−
776−makeCanonical :: FilePath -> FilePath
777−makeCanonical = Posix.joinPath . transformPathParts . splitDirectories
778− where transformPathParts = reverse . foldl go []
779− go as "." = as
780− go (_:as) ".." = as
781− go as x = x : as
782−
783−withPaths :: PandocMonad m => [FilePath] -> (FilePath -> m a) -> FilePath -> m a
784−withPaths [] _ fp = throwError $ PandocResourceNotFound $ T.pack fp
785−withPaths (p:ps) action fp =
786− catchError (action (p </> fp))
787− (\_ -> withPaths ps action fp)
788−
789−-- | Fetch local or remote resource (like an image) and provide data suitable
790−-- for adding it to the MediaBag.
791−fetchMediaResource :: PandocMonad m
792− => T.Text -> m (FilePath, Maybe MimeType, BL.ByteString)
793−fetchMediaResource src = do
794− (bs, mt) <- downloadOrRead src
795− let ext = fromMaybe (T.pack $ takeExtension $ T.unpack src)
796− (mt >>= extensionFromMimeType)
797− let bs' = BL.fromChunks [bs]
798− let basename = showDigest $ sha1 bs'
799− let fname = basename <.> T.unpack ext
800− return (fname, mt, bs')
801−
802−-- | Traverse tree, filling media bag for any images that
803−-- aren't already in the media bag.
804−fillMediaBag :: PandocMonad m => Pandoc -> m Pandoc
805−fillMediaBag d = walkM handleImage d
806− where handleImage :: PandocMonad m => Inline -> m Inline
807− handleImage (Image attr lab (src, tit)) = catchError
808− (do mediabag <- getMediaBag
809− case lookupMedia (T.unpack src) mediabag of
810− Just (_, _) -> return $ Image attr lab (src, tit)
811− Nothing -> do
812− (fname, mt, bs) <- fetchMediaResource src
813− insertMedia fname mt bs
814− return $ Image attr lab (T.pack fname, tit))
815− (\e ->
816− case e of
817− PandocResourceNotFound _ -> do
818− report $ CouldNotFetchResource src
819− "replacing image with description"
820− -- emit alt text
821− return $ Span ("",["image"],[]) lab
822− PandocHttpError u er -> do
823− report $ CouldNotFetchResource u
824− (T.pack $ show er ++ "\rReplacing image with description.")
825− -- emit alt text
826− return $ Span ("",["image"],[]) lab
827− _ -> throwError e)
828− handleImage x = return x
829−
830223-- | Extract media from the mediabag into a directory.
831224extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
832225extractMedia dir d = do
@@ -1015,54 +408,3 @@ instance PandocMonad PandocPure where
1015408 putCommonState x = PandocPure $ lift $ put x
1016409
1017410 logOutput _msg = return ()
1018−
1019−-- This requires UndecidableInstances. We could avoid that
1020−-- by repeating the definitions below for every monad transformer
1021−-- we use: ReaderT, WriterT, StateT, RWST. But this seems to
1022−-- be harmless.
1023−instance (MonadTrans t, PandocMonad m, Functor (t m),
1024− MonadError PandocError (t m), Monad (t m),
1025− Applicative (t m)) => PandocMonad (t m) where
1026− lookupEnv = lift . lookupEnv
1027− getCurrentTime = lift getCurrentTime
1028− getCurrentTimeZone = lift getCurrentTimeZone
1029− newStdGen = lift newStdGen
1030− newUniqueHash = lift newUniqueHash
1031− openURL = lift . openURL
1032− readFileLazy = lift . readFileLazy
1033− readFileStrict = lift . readFileStrict
1034− glob = lift . glob
1035− fileExists = lift . fileExists
1036− getDataFileName = lift . getDataFileName
1037− getModificationTime = lift . getModificationTime
1038− getCommonState = lift getCommonState
1039− putCommonState = lift . putCommonState
1040− logOutput = lift . logOutput
1041−
1042−instance {-# OVERLAPS #-} PandocMonad m => PandocMonad (ParsecT s st m) where
1043− lookupEnv = lift . lookupEnv
1044− getCurrentTime = lift getCurrentTime
1045− getCurrentTimeZone = lift getCurrentTimeZone
1046− newStdGen = lift newStdGen
1047− newUniqueHash = lift newUniqueHash
1048− openURL = lift . openURL
1049− readFileLazy = lift . readFileLazy
1050− readFileStrict = lift . readFileStrict
1051− glob = lift . glob
1052− fileExists = lift . fileExists
1053− getDataFileName = lift . getDataFileName
1054− getModificationTime = lift . getModificationTime
1055− getCommonState = lift getCommonState
1056− putCommonState = lift . putCommonState
1057− trace msg = do
1058− tracing <- getsCommonState stTrace
1059− when tracing $ do
1060− pos <- getPosition
1061− Debug.Trace.trace
1062− ("[trace] Parsed " ++ T.unpack msg ++ " at line " ++
1063− show (sourceLine pos) ++
1064− if sourceName pos == "chunk"
1065− then " of chunk"
1066− else "")
1067− (return ())
1068− logOutput = lift . logOutput