git.iko.soy/typeable/pandoc
on master help sign in
Subdivide Text.Pandoc.Class into small modules (#6106)
ec49643Albert Krewinkel
pandoc.cabal+2
compare with master
unifiedsplit
@@ -569,6 +569,8 @@ library
569 Text.Pandoc.App.FormatHeuristics,
569 Text.Pandoc.App.FormatHeuristics,
570 Text.Pandoc.App.Opt,
570 Text.Pandoc.App.Opt,
571 Text.Pandoc.App.OutputSettings,
571 Text.Pandoc.App.OutputSettings,
572+ Text.Pandoc.Class.CommonState,
573+ Text.Pandoc.Class.PandocMonad,
572 Text.Pandoc.Filter.JSON,
574 Text.Pandoc.Filter.JSON,
573 Text.Pandoc.Filter.Lua,
575 Text.Pandoc.Filter.Lua,
574 Text.Pandoc.Filter.Path,
576 Text.Pandoc.Filter.Path,
src/Text/Pandoc/Class.hs+37−695
@@ -74,356 +74,57 @@ module Text.Pandoc.Class ( PandocMonad(..)
74 , Translations
74 , Translations
75 ) where
75 ) where
76
76
77−import Prelude
78−import System.Random (StdGen, next, mkStdGen)
79−import qualified System.Random as IO (newStdGen)
80import Codec.Archive.Zip
77import Codec.Archive.Zip
81−import qualified Data.CaseInsensitive as CI
78+import Control.Monad.Except
82−import Data.Unique (hashUnique)
79+import Control.Monad.State.Strict
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)
99import Data.ByteString.Base64 (decodeLenient)
80import Data.ByteString.Base64 (decodeLenient)
100−import Network.URI ( escapeURIString, nonStrictRelativeTo,
81+import Data.ByteString.Lazy (toChunks)
101− unEscapeString, parseURIReference, isAllowedInURI,
82+import Data.Default
102− parseURI, URI(..) )
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)
103import Network.HTTP.Client
88import Network.HTTP.Client
104 (httpLbs, responseBody, responseHeaders,
89 (httpLbs, responseBody, responseHeaders,
105 Request(port, host, requestHeaders), parseRequest, newManager)
90 Request(port, host, requestHeaders), parseRequest, newManager)
106import Network.HTTP.Client.Internal (addProxy)
91import Network.HTTP.Client.Internal (addProxy)
107import Network.HTTP.Client.TLS (tlsManagerSettings)
92import Network.HTTP.Client.TLS (tlsManagerSettings)
108−import System.Environment (getEnv)
109import Network.HTTP.Types.Header ( hContentType )
93import Network.HTTP.Types.Header ( hContentType )
110import Network.Socket (withSocketsDo)
94import Network.Socket (withSocketsDo)
111−import Data.ByteString.Lazy (toChunks)
95+import Network.URI ( unEscapeString )
112−import qualified Control.Exception as E
96+import Prelude
113−import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
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
114import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)
110import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)
115−import Text.Pandoc.Walk (walkM, walk)
111+import Text.Pandoc.Translations (Translations)
112+import Text.Pandoc.Walk (walk)
116−import qualified Text.Pandoc.MediaBag as MB
113+import qualified Control.Exception as E
117import qualified Data.ByteString as B
114import qualified Data.ByteString as B
118import qualified Data.ByteString.Lazy as BL
115import qualified Data.ByteString.Lazy as BL
119−import qualified System.Environment as IO (lookupEnv)
116+import qualified Data.CaseInsensitive as CI
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)
135import qualified Data.Map as M
117import qualified Data.Map as M
136import qualified Data.Text as T
118import qualified Data.Text as T
137−import Text.Pandoc.Error
119+import qualified Data.Time as IO (getCurrentTime)
138−import Text.Pandoc.BCP47 (Lang(..), parseBCP47, renderLang)
120+import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
139−import Text.Pandoc.Translations (Term(..), Translations, lookupTerm,
140− readTranslations)
141−import qualified Debug.Trace
121+import qualified Data.Unique as IO (newUnique)
142−#ifdef EMBED_DATA_FILES
143−import Text.Pandoc.Data (dataFiles)
144−#else
145−import qualified Paths_pandoc as Paths
122+import qualified System.Directory as Directory
146−#endif
123+import qualified System.Directory as IO (getModificationTime)
147−
124+import qualified System.Environment as IO (lookupEnv)
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
125+import qualified System.FilePath.Glob as IO (glob)
176− -- the glob syntax.
126+import qualified System.Random as IO (newStdGen)
177− glob :: String -> m [FilePath]
127+import qualified Text.Pandoc.UTF8 as UTF8
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 ""
427
128
428-- | Evaluate a 'PandocIO' operation.
129-- | Evaluate a 'PandocIO' operation.
429runIO :: PandocIO a -> IO (Either PandocError a)
130runIO :: PandocIO a -> IO (Either PandocError a)
@@ -519,314 +220,6 @@ alertIndent (l:ls) = do
519 where go l' = do UTF8.hPutStr stderr " "
220 where go l' = do UTF8.hPutStr stderr " "
520 UTF8.hPutStrLn stderr $ T.unpack l'
221 UTF8.hPutStrLn stderr $ T.unpack l'
521
222
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−
830-- | Extract media from the mediabag into a directory.
223-- | Extract media from the mediabag into a directory.
831extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
224extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
832extractMedia dir d = do
225extractMedia dir d = do
@@ -1015,54 +408,3 @@ instance PandocMonad PandocPure where
1015 putCommonState x = PandocPure $ lift $ put x
408 putCommonState x = PandocPure $ lift $ put x
1016
409
1017 logOutput _msg = return ()
410 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
src/Text/Pandoc/Class/CommonState.hsnew file+80
@@ -0,0 +1,80 @@
1+{- |
2+Module : Text.Pandoc.Class.CommonState
3+Copyright : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane
4+License : GNU GPL, version 2 or above
5+
6+Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
7+Stability : alpha
8+Portability : portable
9+
10+Common state shared by all pandoc-specific operations, including
11+those in readers, writers, and Lua filters.
12+-}
13+
14+module Text.Pandoc.Class.CommonState
15+ ( CommonState(..)
16+ , defaultCommonState
17+ )
18+where
19+
20+import Data.Default (Default (def))
21+import Data.Text (Text)
22+import Text.Pandoc.BCP47 (Lang)
23+import Text.Pandoc.MediaBag (MediaBag)
24+import Text.Pandoc.Logging (LogMessage, Verbosity (WARNING))
25+import Text.Pandoc.Translations (Translations)
26+
27+-- | 'CommonState' represents state that is used by all
28+-- instances of 'PandocMonad'. Normally users should not
29+-- need to interact with it directly; instead, auxiliary
30+-- functions like 'setVerbosity' and 'withMediaBag' should be used.
31+data CommonState = CommonState
32+ { stLog :: [LogMessage]
33+ -- ^ A list of log messages in reverse order
34+ , stUserDataDir :: Maybe FilePath
35+ -- ^ Directory to search for data files
36+ , stSourceURL :: Maybe Text
37+ -- ^ Absolute URL + dir of 1st source file
38+ , stRequestHeaders :: [(Text, Text)]
39+ -- ^ Headers to add for HTTP requests
40+ , stMediaBag :: MediaBag
41+ -- ^ Media parsed from binary containers
42+ , stTranslations :: Maybe (Lang, Maybe Translations)
43+ -- ^ Translations for localization
44+ , stInputFiles :: [FilePath]
45+ -- ^ List of input files from command line
46+ , stOutputFile :: Maybe FilePath
47+ -- ^ Output file from command line
48+ , stResourcePath :: [FilePath]
49+ -- ^ Path to search for resources like
50+ -- included images
51+ , stVerbosity :: Verbosity
52+ -- ^ Verbosity level
53+ , stTrace :: Bool
54+ -- ^ Controls whether tracing messages are
55+ -- issued.
56+ }
57+
58+-- | The default @'CommonState'@. All fields are initialized as the
59+-- monoid identity of their resprective type, except for:
60+--
61+-- * @'stResourcePath'@, which is set to @["."]@,
62+-- * @'stTrace'@, which is set to @'False'@, and
63+-- * @'stVerbosity'@, which is set to @WARNING@.
64+defaultCommonState :: CommonState
65+defaultCommonState = CommonState
66+ { stLog = []
67+ , stUserDataDir = Nothing
68+ , stSourceURL = Nothing
69+ , stRequestHeaders = []
70+ , stMediaBag = mempty
71+ , stTranslations = Nothing
72+ , stInputFiles = []
73+ , stOutputFile = Nothing
74+ , stResourcePath = ["."]
75+ , stVerbosity = WARNING
76+ , stTrace = False
77+ }
78+
79+instance Default CommonState where
80+ def = defaultCommonState
src/Text/Pandoc/Class/PandocMonad.hsnew file+706
@@ -0,0 +1,706 @@
1+{-# LANGUAGE NoImplicitPrelude #-}
2+{-# LANGUAGE CPP #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE OverloadedStrings #-}
7+{-# LANGUAGE ScopedTypeVariables #-}
8+{-# LANGUAGE TypeSynonymInstances #-}
9+{-# LANGUAGE UndecidableInstances #-}
10+{-# LANGUAGE ViewPatterns #-}
11+#if MIN_VERSION_base(4,8,0)
12+#else
13+{-# LANGUAGE OverlappingInstances #-}
14+#endif
15+{- |
16+Module : Text.Pandoc.Class.PandocMonad
17+Copyright : Copyright (C) 2016-20 Jesse Rosenthal, John MacFarlane
18+License : GNU GPL, version 2 or above
19+
20+Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
21+Stability : alpha
22+Portability : portable
23+
24+This module defines a type class, 'PandocMonad', for pandoc readers
25+and writers.
26+-}
27+
28+module Text.Pandoc.Class.PandocMonad
29+ ( PandocMonad(..)
30+ , getPOSIXTime
31+ , getZonedTime
32+ , readFileFromDirs
33+ , report
34+ , setTrace
35+ , setRequestHeader
36+ , getLog
37+ , setVerbosity
38+ , getVerbosity
39+ , getMediaBag
40+ , setMediaBag
41+ , insertMedia
42+ , setUserDataDir
43+ , getUserDataDir
44+ , fetchItem
45+ , fetchMediaResource
46+ , getInputFiles
47+ , setInputFiles
48+ , getOutputFile
49+ , setOutputFile
50+ , setResourcePath
51+ , getResourcePath
52+ , readDefaultDataFile
53+ , readDataFile
54+ , fillMediaBag
55+ , toLang
56+ , setTranslations
57+ , translateTerm
58+ , makeCanonical
59+ ) where
60+
61+import Prelude
62+import Codec.Archive.Zip
63+import Control.Monad.Except (MonadError (catchError, throwError),
64+ MonadTrans, lift, when)
65+import Data.Digest.Pure.SHA (sha1, showDigest)
66+import Data.Maybe (fromMaybe)
67+import Data.Time (UTCTime)
68+import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds)
69+import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime)
70+import Network.URI ( escapeURIString, nonStrictRelativeTo,
71+ unEscapeString, parseURIReference, isAllowedInURI,
72+ parseURI, URI(..) )
73+import System.FilePath ((</>), (<.>), takeExtension, dropExtension,
74+ isRelative, splitDirectories)
75+import System.Random (StdGen)
76+import Text.Pandoc.BCP47 (Lang(..), parseBCP47, renderLang)
77+import Text.Pandoc.Class.CommonState (CommonState (..))
78+import Text.Pandoc.Definition
79+import Text.Pandoc.Error
80+import Text.Pandoc.Logging
81+import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType)
82+import Text.Pandoc.MediaBag (MediaBag, lookupMedia)
83+import Text.Pandoc.Shared (uriPathToPath)
84+import Text.Pandoc.Translations (Term(..), Translations, lookupTerm,
85+ readTranslations)
86+import Text.Pandoc.Walk (walkM)
87+import Text.Parsec (ParsecT, getPosition, sourceLine, sourceName)
88+import qualified Data.ByteString as B
89+import qualified Data.ByteString.Lazy as BL
90+import qualified Data.Text as T
91+import qualified Debug.Trace
92+import qualified System.FilePath.Posix as Posix
93+import qualified Text.Pandoc.MediaBag as MB
94+import qualified Text.Pandoc.UTF8 as UTF8
95+#ifdef EMBED_DATA_FILES
96+import Text.Pandoc.Data (dataFiles)
97+#endif
98+
99+-- | The PandocMonad typeclass contains all the potentially
100+-- IO-related functions used in pandoc's readers and writers.
101+-- Instances of this typeclass may implement these functions
102+-- in IO (as in 'PandocIO') or using an internal state that
103+-- represents a file system, time, and so on (as in 'PandocPure').
104+class (Functor m, Applicative m, Monad m, MonadError PandocError m)
105+ => PandocMonad m where
106+ -- | Lookup an environment variable.
107+ lookupEnv :: T.Text -> m (Maybe T.Text)
108+ -- | Get the current (UTC) time.
109+ getCurrentTime :: m UTCTime
110+ -- | Get the locale's time zone.
111+ getCurrentTimeZone :: m TimeZone
112+ -- | Return a new generator for random numbers.
113+ newStdGen :: m StdGen
114+ -- | Return a new unique integer.
115+ newUniqueHash :: m Int
116+ -- | Retrieve contents and mime type from a URL, raising
117+ -- an error on failure.
118+ openURL :: T.Text -> m (B.ByteString, Maybe MimeType)
119+ -- | Read the lazy ByteString contents from a file path,
120+ -- raising an error on failure.
121+ readFileLazy :: FilePath -> m BL.ByteString
122+ -- | Read the strict ByteString contents from a file path,
123+ -- raising an error on failure.
124+ readFileStrict :: FilePath -> m B.ByteString
125+ -- | Return a list of paths that match a glob, relative to
126+ -- the working directory. See 'System.FilePath.Glob' for
127+ -- the glob syntax.
128+ glob :: String -> m [FilePath]
129+ -- | Returns True if file exists.
130+ fileExists :: FilePath -> m Bool
131+ -- | Returns the path of data file.
132+ getDataFileName :: FilePath -> m FilePath
133+ -- | Return the modification time of a file.
134+ getModificationTime :: FilePath -> m UTCTime
135+ -- | Get the value of the 'CommonState' used by all instances
136+ -- of 'PandocMonad'.
137+ getCommonState :: m CommonState
138+ -- | Set the value of the 'CommonState' used by all instances
139+ -- of 'PandocMonad'.
140+ -- | Get the value of a specific field of 'CommonState'.
141+ putCommonState :: CommonState -> m ()
142+ -- | Get the value of a specific field of 'CommonState'.
143+ getsCommonState :: (CommonState -> a) -> m a
144+ getsCommonState f = f <$> getCommonState
145+ -- | Modify the 'CommonState'.
146+ modifyCommonState :: (CommonState -> CommonState) -> m ()
147+ modifyCommonState f = getCommonState >>= putCommonState . f
148+ -- | Output a log message.
149+ logOutput :: LogMessage -> m ()
150+ -- | Output a debug message to sterr, using 'Debug.Trace.trace',
151+ -- if tracing is enabled. Note: this writes to stderr even in
152+ -- pure instances.
153+ trace :: T.Text -> m ()
154+ trace msg = do
155+ tracing <- getsCommonState stTrace
156+ when tracing $ Debug.Trace.trace ("[trace] " ++ T.unpack msg) (return ())
157+
158+-- * Functions defined for all PandocMonad instances
159+
160+-- | Set the verbosity level.
161+setVerbosity :: PandocMonad m => Verbosity -> m ()
162+setVerbosity verbosity =
163+ modifyCommonState $ \st -> st{ stVerbosity = verbosity }
164+
165+-- | Get the verbosity level.
166+getVerbosity :: PandocMonad m => m Verbosity
167+getVerbosity = getsCommonState stVerbosity
168+
169+-- | Get the accomulated log messages (in temporal order).
170+getLog :: PandocMonad m => m [LogMessage]
171+getLog = reverse <$> getsCommonState stLog
172+
173+-- | Log a message using 'logOutput'. Note that 'logOutput' is
174+-- called only if the verbosity level exceeds the level of the
175+-- message, but the message is added to the list of log messages
176+-- that will be retrieved by 'getLog' regardless of its verbosity level.
177+report :: PandocMonad m => LogMessage -> m ()
178+report msg = do
179+ verbosity <- getsCommonState stVerbosity
180+ let level = messageVerbosity msg
181+ when (level <= verbosity) $ logOutput msg
182+ modifyCommonState $ \st -> st{ stLog = msg : stLog st }
183+
184+-- | Determine whether tracing is enabled. This affects
185+-- the behavior of 'trace'. If tracing is not enabled,
186+-- 'trace' does nothing.
187+setTrace :: PandocMonad m => Bool -> m ()
188+setTrace useTracing = modifyCommonState $ \st -> st{stTrace = useTracing}
189+
190+-- | Set request header to use in HTTP requests.
191+setRequestHeader :: PandocMonad m
192+ => T.Text -- ^ Header name
193+ -> T.Text -- ^ Value
194+ -> m ()
195+setRequestHeader name val = modifyCommonState $ \st ->
196+ st{ stRequestHeaders =
197+ (name, val) : filter (\(n,_) -> n /= name) (stRequestHeaders st) }
198+
199+-- | Initialize the media bag.
200+setMediaBag :: PandocMonad m => MediaBag -> m ()
201+setMediaBag mb = modifyCommonState $ \st -> st{stMediaBag = mb}
202+
203+-- | Retrieve the media bag.
204+getMediaBag :: PandocMonad m => m MediaBag
205+getMediaBag = getsCommonState stMediaBag
206+
207+-- | Insert an item into the media bag.
208+insertMedia :: PandocMonad m => FilePath -> Maybe MimeType -> BL.ByteString -> m ()
209+insertMedia fp mime bs = do
210+ mb <- getMediaBag
211+ let mb' = MB.insertMedia fp mime bs mb
212+ setMediaBag mb'
213+
214+-- | Retrieve the input filenames.
215+getInputFiles :: PandocMonad m => m [FilePath]
216+getInputFiles = getsCommonState stInputFiles
217+
218+-- | Set the input filenames.
219+setInputFiles :: PandocMonad m => [FilePath] -> m ()
220+setInputFiles fs = do
221+ let sourceURL = case fs of
222+ [] -> Nothing
223+ (x:_) -> case parseURI x of
224+ Just u
225+ | uriScheme u `elem` ["http:","https:"] ->
226+ Just $ show u{ uriQuery = "",
227+ uriFragment = "" }
228+ _ -> Nothing
229+
230+ modifyCommonState $ \st -> st{ stInputFiles = fs
231+ , stSourceURL = T.pack <$> sourceURL }
232+
233+-- | Retrieve the output filename.
234+getOutputFile :: PandocMonad m => m (Maybe FilePath)
235+getOutputFile = getsCommonState stOutputFile
236+
237+-- | Set the output filename.
238+setOutputFile :: PandocMonad m => Maybe FilePath -> m ()
239+setOutputFile mbf = modifyCommonState $ \st -> st{ stOutputFile = mbf }
240+
241+-- | Retrieve the resource path searched by 'fetchItem'.
242+getResourcePath :: PandocMonad m => m [FilePath]
243+getResourcePath = getsCommonState stResourcePath
244+
245+-- | Set the resource path searched by 'fetchItem'.
246+setResourcePath :: PandocMonad m => [FilePath] -> m ()
247+setResourcePath ps = modifyCommonState $ \st -> st{stResourcePath = ps}
248+
249+-- | Get the POSIX time.
250+getPOSIXTime :: PandocMonad m => m POSIXTime
251+getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
252+
253+-- | Get the zoned time.
254+getZonedTime :: PandocMonad m => m ZonedTime
255+getZonedTime = do
256+ t <- getCurrentTime
257+ tz <- getCurrentTimeZone
258+ return $ utcToZonedTime tz t
259+
260+-- | Read file, checking in any number of directories.
261+readFileFromDirs :: PandocMonad m => [FilePath] -> FilePath -> m (Maybe T.Text)
262+readFileFromDirs [] _ = return Nothing
263+readFileFromDirs (d:ds) f = catchError
264+ (Just . T.pack . UTF8.toStringLazy <$> readFileLazy (d </> f))
265+ (\_ -> readFileFromDirs ds f)
266+
267+-- | Convert BCP47 string to a Lang, issuing warning
268+-- if there are problems.
269+toLang :: PandocMonad m => Maybe T.Text -> m (Maybe Lang)
270+toLang Nothing = return Nothing
271+toLang (Just s) =
272+ case parseBCP47 s of
273+ Left _ -> do
274+ report $ InvalidLang s
275+ return Nothing
276+ Right l -> return (Just l)
277+
278+-- | Select the language to use with 'translateTerm'.
279+-- Note that this does not read a translation file;
280+-- that is only done the first time 'translateTerm' is
281+-- used.
282+setTranslations :: PandocMonad m => Lang -> m ()
283+setTranslations lang =
284+ modifyCommonState $ \st -> st{ stTranslations = Just (lang, Nothing) }
285+
286+-- | Load term map.
287+getTranslations :: PandocMonad m => m Translations
288+getTranslations = do
289+ mbtrans <- getsCommonState stTranslations
290+ case mbtrans of
291+ Nothing -> return mempty -- no language defined
292+ Just (_, Just t) -> return t
293+ Just (lang, Nothing) -> do -- read from file
294+ let translationFile = "translations/" <> renderLang lang <> ".yaml"
295+ let fallbackFile = "translations/" <> langLanguage lang <> ".yaml"
296+ let getTrans fp = do
297+ bs <- readDataFile fp
298+ case readTranslations (UTF8.toText bs) of
299+ Left e -> do
300+ report $ CouldNotLoadTranslations (renderLang lang)
301+ (T.pack fp <> ": " <> e)
302+ -- make sure we don't try again...
303+ modifyCommonState $ \st ->
304+ st{ stTranslations = Nothing }
305+ return mempty
306+ Right t -> do
307+ modifyCommonState $ \st ->
308+ st{ stTranslations = Just (lang, Just t) }
309+ return t
310+ catchError (getTrans $ T.unpack translationFile)
311+ (\_ ->
312+ catchError (getTrans $ T.unpack fallbackFile)
313+ (\e -> do
314+ report $ CouldNotLoadTranslations (renderLang lang)
315+ $ case e of
316+ PandocCouldNotFindDataFileError _ ->
317+ "data file " <> fallbackFile <> " not found"
318+ _ -> ""
319+ -- make sure we don't try again...
320+ modifyCommonState $ \st -> st{ stTranslations = Nothing }
321+ return mempty))
322+
323+-- | Get a translation from the current term map.
324+-- Issue a warning if the term is not defined.
325+translateTerm :: PandocMonad m => Term -> m T.Text
326+translateTerm term = do
327+ translations <- getTranslations
328+ case lookupTerm term translations of
329+ Just s -> return s
330+ Nothing -> do
331+ report $ NoTranslation $ T.pack $ show term
332+ return ""
333+
334+-- | Specialized version of parseURIReference that disallows
335+-- single-letter schemes. Reason: these are usually windows absolute
336+-- paths.
337+parseURIReference' :: T.Text -> Maybe URI
338+parseURIReference' s = do
339+ u <- parseURIReference (T.unpack s)
340+ case uriScheme u of
341+ [_] -> Nothing
342+ _ -> Just u
343+
344+-- | Set the user data directory in common state.
345+setUserDataDir :: PandocMonad m
346+ => Maybe FilePath
347+ -> m ()
348+setUserDataDir mbfp = modifyCommonState $ \st -> st{ stUserDataDir = mbfp }
349+
350+-- | Get the user data directory from common state.
351+getUserDataDir :: PandocMonad m
352+ => m (Maybe FilePath)
353+getUserDataDir = getsCommonState stUserDataDir
354+
355+-- | Fetch an image or other item from the local filesystem or the net.
356+-- Returns raw content and maybe mime type.
357+fetchItem :: PandocMonad m
358+ => T.Text
359+ -> m (B.ByteString, Maybe MimeType)
360+fetchItem s = do
361+ mediabag <- getMediaBag
362+ case lookupMedia (T.unpack s) mediabag of
363+ Just (mime, bs) -> return (BL.toStrict bs, Just mime)
364+ Nothing -> downloadOrRead s
365+
366+-- | Returns the content and, if available, the MIME type of a resource.
367+-- If the given resource location is a valid URI, then download the
368+-- resource from that URI. Otherwise, treat the resource identifier as a
369+-- local file name.
370+--
371+-- Note that resources are treated relative to the URL of the first
372+-- input source, if any.
373+downloadOrRead :: PandocMonad m
374+ => T.Text
375+ -> m (B.ByteString, Maybe MimeType)
376+downloadOrRead s = do
377+ sourceURL <- getsCommonState stSourceURL
378+ case (sourceURL >>= parseURIReference' .
379+ ensureEscaped, ensureEscaped s) of
380+ (Just u, s') -> -- try fetching from relative path at source
381+ case parseURIReference' s' of
382+ Just u' -> openURL $ T.pack $ show $ u' `nonStrictRelativeTo` u
383+ Nothing -> openURL s' -- will throw error
384+ (Nothing, s'@(T.unpack -> ('/':'/':c:_))) | c /= '?' -> -- protocol-relative URI
385+ -- we exclude //? because of //?UNC/ on Windows
386+ case parseURIReference' s' of
387+ Just u' -> openURL $ T.pack $ show $ u' `nonStrictRelativeTo` httpcolon
388+ Nothing -> openURL s' -- will throw error
389+ (Nothing, s') ->
390+ case parseURI (T.unpack s') of -- requires absolute URI
391+ Just u' | uriScheme u' == "file:" ->
392+ readLocalFile $ uriPathToPath (T.pack $ uriPath u')
393+ -- We don't want to treat C:/ as a scheme:
394+ Just u' | length (uriScheme u') > 2 -> openURL (T.pack $ show u')
395+ _ -> readLocalFile fp -- get from local file system
396+ where readLocalFile f = do
397+ resourcePath <- getResourcePath
398+ cont <- if isRelative f
399+ then withPaths resourcePath readFileStrict f
400+ else readFileStrict f
401+ return (cont, mime)
402+ httpcolon = URI{ uriScheme = "http:",
403+ uriAuthority = Nothing,
404+ uriPath = "",
405+ uriQuery = "",
406+ uriFragment = "" }
407+ dropFragmentAndQuery = T.takeWhile (\c -> c /= '?' && c /= '#')
408+ fp = unEscapeString $ T.unpack $ dropFragmentAndQuery s
409+ mime = getMimeType $ case takeExtension fp of
410+ ".gz" -> dropExtension fp
411+ ".svgz" -> dropExtension fp ++ ".svg"
412+ x -> x
413+ ensureEscaped = T.pack . escapeURIString isAllowedInURI . T.unpack . T.map convertSlash
414+ convertSlash '\\' = '/'
415+ convertSlash x = x
416+
417+-- | Retrieve default reference.docx.
418+getDefaultReferenceDocx :: PandocMonad m => m Archive
419+getDefaultReferenceDocx = do
420+ let paths = ["[Content_Types].xml",
421+ "_rels/.rels",
422+ "docProps/app.xml",
423+ "docProps/core.xml",
424+ "docProps/custom.xml",
425+ "word/document.xml",
426+ "word/fontTable.xml",
427+ "word/footnotes.xml",
428+ "word/comments.xml",
429+ "word/numbering.xml",
430+ "word/settings.xml",
431+ "word/webSettings.xml",
432+ "word/styles.xml",
433+ "word/_rels/document.xml.rels",
434+ "word/_rels/footnotes.xml.rels",
435+ "word/theme/theme1.xml"]
436+ let toLazy = BL.fromChunks . (:[])
437+ let pathToEntry path = do
438+ epochtime <- (floor . utcTimeToPOSIXSeconds) <$> getCurrentTime
439+ contents <- toLazy <$> readDataFile ("docx/" ++ path)
440+ return $ toEntry path epochtime contents
441+ datadir <- getUserDataDir
442+ mbArchive <- case datadir of
443+ Nothing -> return Nothing
444+ Just d -> do
445+ exists <- fileExists (d </> "reference.docx")
446+ if exists
447+ then return (Just (d </> "reference.docx"))
448+ else return Nothing
449+ case mbArchive of
450+ Just arch -> toArchive <$> readFileLazy arch
451+ Nothing -> foldr addEntryToArchive emptyArchive <$>
452+ mapM pathToEntry paths
453+
454+-- | Retrieve default reference.odt.
455+getDefaultReferenceODT :: PandocMonad m => m Archive
456+getDefaultReferenceODT = do
457+ let paths = ["mimetype",
458+ "manifest.rdf",
459+ "styles.xml",
460+ "content.xml",
461+ "meta.xml",
462+ "settings.xml",
463+ "Configurations2/accelerator/current.xml",
464+ "Thumbnails/thumbnail.png",
465+ "META-INF/manifest.xml"]
466+ let pathToEntry path = do epochtime <- floor `fmap` getPOSIXTime
467+ contents <- (BL.fromChunks . (:[])) `fmap`
468+ readDataFile ("odt/" ++ path)
469+ return $ toEntry path epochtime contents
470+ datadir <- getUserDataDir
471+ mbArchive <- case datadir of
472+ Nothing -> return Nothing
473+ Just d -> do
474+ exists <- fileExists (d </> "reference.odt")
475+ if exists
476+ then return (Just (d </> "reference.odt"))
477+ else return Nothing
478+ case mbArchive of
479+ Just arch -> toArchive <$> readFileLazy arch
480+ Nothing -> foldr addEntryToArchive emptyArchive <$>
481+ mapM pathToEntry paths
482+
483+-- | Retrieve default reference.pptx.
484+getDefaultReferencePptx :: PandocMonad m => m Archive
485+getDefaultReferencePptx = do
486+ -- We're going to narrow this down substantially once we get it
487+ -- working.
488+ let paths = [ "[Content_Types].xml"
489+ , "_rels/.rels"
490+ , "docProps/app.xml"
491+ , "docProps/core.xml"
492+ , "ppt/_rels/presentation.xml.rels"
493+ , "ppt/presProps.xml"
494+ , "ppt/presentation.xml"
495+ , "ppt/slideLayouts/_rels/slideLayout1.xml.rels"
496+ , "ppt/slideLayouts/_rels/slideLayout2.xml.rels"
497+ , "ppt/slideLayouts/_rels/slideLayout3.xml.rels"
498+ , "ppt/slideLayouts/_rels/slideLayout4.xml.rels"
499+ , "ppt/slideLayouts/_rels/slideLayout5.xml.rels"
500+ , "ppt/slideLayouts/_rels/slideLayout6.xml.rels"
501+ , "ppt/slideLayouts/_rels/slideLayout7.xml.rels"
502+ , "ppt/slideLayouts/_rels/slideLayout8.xml.rels"
503+ , "ppt/slideLayouts/_rels/slideLayout9.xml.rels"
504+ , "ppt/slideLayouts/_rels/slideLayout10.xml.rels"
505+ , "ppt/slideLayouts/_rels/slideLayout11.xml.rels"
506+ , "ppt/slideLayouts/slideLayout1.xml"
507+ , "ppt/slideLayouts/slideLayout10.xml"
508+ , "ppt/slideLayouts/slideLayout11.xml"
509+ , "ppt/slideLayouts/slideLayout2.xml"
510+ , "ppt/slideLayouts/slideLayout3.xml"
511+ , "ppt/slideLayouts/slideLayout4.xml"
512+ , "ppt/slideLayouts/slideLayout5.xml"
513+ , "ppt/slideLayouts/slideLayout6.xml"
514+ , "ppt/slideLayouts/slideLayout7.xml"
515+ , "ppt/slideLayouts/slideLayout8.xml"
516+ , "ppt/slideLayouts/slideLayout9.xml"
517+ , "ppt/slideMasters/_rels/slideMaster1.xml.rels"
518+ , "ppt/slideMasters/slideMaster1.xml"
519+ , "ppt/slides/_rels/slide1.xml.rels"
520+ , "ppt/slides/slide1.xml"
521+ , "ppt/slides/_rels/slide2.xml.rels"
522+ , "ppt/slides/slide2.xml"
523+ , "ppt/slides/_rels/slide3.xml.rels"
524+ , "ppt/slides/slide3.xml"
525+ , "ppt/slides/_rels/slide4.xml.rels"
526+ , "ppt/slides/slide4.xml"
527+ , "ppt/tableStyles.xml"
528+ , "ppt/theme/theme1.xml"
529+ , "ppt/viewProps.xml"
530+ -- These relate to notes slides.
531+ , "ppt/notesMasters/notesMaster1.xml"
532+ , "ppt/notesMasters/_rels/notesMaster1.xml.rels"
533+ , "ppt/notesSlides/notesSlide1.xml"
534+ , "ppt/notesSlides/_rels/notesSlide1.xml.rels"
535+ , "ppt/notesSlides/notesSlide2.xml"
536+ , "ppt/notesSlides/_rels/notesSlide2.xml.rels"
537+ , "ppt/theme/theme2.xml"
538+ ]
539+ let toLazy = BL.fromChunks . (:[])
540+ let pathToEntry path = do
541+ epochtime <- (floor . utcTimeToPOSIXSeconds) <$> getCurrentTime
542+ contents <- toLazy <$> readDataFile ("pptx/" ++ path)
543+ return $ toEntry path epochtime contents
544+ datadir <- getUserDataDir
545+ mbArchive <- case datadir of
546+ Nothing -> return Nothing
547+ Just d -> do
548+ exists <- fileExists (d </> "reference.pptx")
549+ if exists
550+ then return (Just (d </> "reference.pptx"))
551+ else return Nothing
552+ case mbArchive of
553+ Just arch -> toArchive <$> readFileLazy arch
554+ Nothing -> foldr addEntryToArchive emptyArchive <$>
555+ mapM pathToEntry paths
556+
557+-- | Read file from user data directory or,
558+-- if not found there, from Cabal data directory.
559+readDataFile :: PandocMonad m => FilePath -> m B.ByteString
560+readDataFile fname = do
561+ datadir <- getUserDataDir
562+ case datadir of
563+ Nothing -> readDefaultDataFile fname
564+ Just userDir -> do
565+ exists <- fileExists (userDir </> fname)
566+ if exists
567+ then readFileStrict (userDir </> fname)
568+ else readDefaultDataFile fname
569+
570+-- | Read file from from Cabal data directory.
571+readDefaultDataFile :: PandocMonad m => FilePath -> m B.ByteString
572+readDefaultDataFile "reference.docx" =
573+ (B.concat . BL.toChunks . fromArchive) <$> getDefaultReferenceDocx
574+readDefaultDataFile "reference.pptx" =
575+ (B.concat . BL.toChunks . fromArchive) <$> getDefaultReferencePptx
576+readDefaultDataFile "reference.odt" =
577+ (B.concat . BL.toChunks . fromArchive) <$> getDefaultReferenceODT
578+readDefaultDataFile fname =
579+#ifdef EMBED_DATA_FILES
580+ case lookup (makeCanonical fname) dataFiles of
581+ Nothing -> throwError $ PandocCouldNotFindDataFileError $ T.pack fname
582+ Just contents -> return contents
583+#else
584+ getDataFileName fname' >>= checkExistence >>= readFileStrict
585+ where fname' = if fname == "MANUAL.txt" then fname else "data" </> fname
586+
587+-- | Returns the input filename unchanged if the file exits, and throws
588+-- a `PandocCouldNotFindDataFileError` if it doesn't.
589+checkExistence :: PandocMonad m => FilePath -> m FilePath
590+checkExistence fn = do
591+ exists <- fileExists fn
592+ if exists
593+ then return fn
594+ else throwError $ PandocCouldNotFindDataFileError $ T.pack fn
595+#endif
596+
597+-- | Canonicalizes a file path by removing redundant @.@ and @..@.
598+makeCanonical :: FilePath -> FilePath
599+makeCanonical = Posix.joinPath . transformPathParts . splitDirectories
600+ where transformPathParts = reverse . foldl go []
601+ go as "." = as
602+ go (_:as) ".." = as
603+ go as x = x : as
604+
605+-- | Trys to run an action on a file: for each directory given, a
606+-- filepath is created from the given filename, and the action is run on
607+-- that filepath. Returns the result of the first successful execution
608+-- of the action, or throws a @PandocResourceNotFound@ exception if the
609+-- action errors for all filepaths.
610+withPaths :: PandocMonad m => [FilePath] -> (FilePath -> m a) -> FilePath -> m a
611+withPaths [] _ fp = throwError $ PandocResourceNotFound $ T.pack fp
612+withPaths (p:ps) action fp =
613+ catchError (action (p </> fp))
614+ (\_ -> withPaths ps action fp)
615+
616+-- | Fetch local or remote resource (like an image) and provide data suitable
617+-- for adding it to the MediaBag.
618+fetchMediaResource :: PandocMonad m
619+ => T.Text -> m (FilePath, Maybe MimeType, BL.ByteString)
620+fetchMediaResource src = do
621+ (bs, mt) <- downloadOrRead src
622+ let ext = fromMaybe (T.pack $ takeExtension $ T.unpack src)
623+ (mt >>= extensionFromMimeType)
624+ let bs' = BL.fromChunks [bs]
625+ let basename = showDigest $ sha1 bs'
626+ let fname = basename <.> T.unpack ext
627+ return (fname, mt, bs')
628+
629+-- | Traverse tree, filling media bag for any images that
630+-- aren't already in the media bag.
631+fillMediaBag :: PandocMonad m => Pandoc -> m Pandoc
632+fillMediaBag d = walkM handleImage d
633+ where handleImage :: PandocMonad m => Inline -> m Inline
634+ handleImage (Image attr lab (src, tit)) = catchError
635+ (do mediabag <- getMediaBag
636+ case lookupMedia (T.unpack src) mediabag of
637+ Just (_, _) -> return $ Image attr lab (src, tit)
638+ Nothing -> do
639+ (fname, mt, bs) <- fetchMediaResource src
640+ insertMedia fname mt bs
641+ return $ Image attr lab (T.pack fname, tit))
642+ (\e ->
643+ case e of
644+ PandocResourceNotFound _ -> do
645+ report $ CouldNotFetchResource src
646+ "replacing image with description"
647+ -- emit alt text
648+ return $ Span ("",["image"],[]) lab
649+ PandocHttpError u er -> do
650+ report $ CouldNotFetchResource u
651+ (T.pack $ show er ++ "\rReplacing image with description.")
652+ -- emit alt text
653+ return $ Span ("",["image"],[]) lab
654+ _ -> throwError e)
655+ handleImage x = return x
656+
657+-- This requires UndecidableInstances. We could avoid that
658+-- by repeating the definitions below for every monad transformer
659+-- we use: ReaderT, WriterT, StateT, RWST. But this seems to
660+-- be harmless.
661+instance (MonadTrans t, PandocMonad m, Functor (t m),
662+ MonadError PandocError (t m), Monad (t m),
663+ Applicative (t m)) => PandocMonad (t m) where
664+ lookupEnv = lift . lookupEnv
665+ getCurrentTime = lift getCurrentTime
666+ getCurrentTimeZone = lift getCurrentTimeZone
667+ newStdGen = lift newStdGen
668+ newUniqueHash = lift newUniqueHash
669+ openURL = lift . openURL
670+ readFileLazy = lift . readFileLazy
671+ readFileStrict = lift . readFileStrict
672+ glob = lift . glob
673+ fileExists = lift . fileExists
674+ getDataFileName = lift . getDataFileName
675+ getModificationTime = lift . getModificationTime
676+ getCommonState = lift getCommonState
677+ putCommonState = lift . putCommonState
678+ logOutput = lift . logOutput
679+
680+instance {-# OVERLAPS #-} PandocMonad m => PandocMonad (ParsecT s st m) where
681+ lookupEnv = lift . lookupEnv
682+ getCurrentTime = lift getCurrentTime
683+ getCurrentTimeZone = lift getCurrentTimeZone
684+ newStdGen = lift newStdGen
685+ newUniqueHash = lift newUniqueHash
686+ openURL = lift . openURL
687+ readFileLazy = lift . readFileLazy
688+ readFileStrict = lift . readFileStrict
689+ glob = lift . glob
690+ fileExists = lift . fileExists
691+ getDataFileName = lift . getDataFileName
692+ getModificationTime = lift . getModificationTime
693+ getCommonState = lift getCommonState
694+ putCommonState = lift . putCommonState
695+ trace msg = do
696+ tracing <- getsCommonState stTrace
697+ when tracing $ do
698+ pos <- getPosition
699+ Debug.Trace.trace
700+ ("[trace] Parsed " ++ T.unpack msg ++ " at line " ++
701+ show (sourceLine pos) ++
702+ if sourceName pos == "chunk"
703+ then " of chunk"
704+ else "")
705+ (return ())
706+ logOutput = lift . logOutput