diff options
Diffstat (limited to 'src/Text/Pandoc/Class')
-rw-r--r-- | src/Text/Pandoc/Class/CommonState.hs | 2 | ||||
-rw-r--r-- | src/Text/Pandoc/Class/IO.hs | 49 | ||||
-rw-r--r-- | src/Text/Pandoc/Class/PandocMonad.hs | 79 |
3 files changed, 68 insertions, 62 deletions
diff --git a/src/Text/Pandoc/Class/CommonState.hs b/src/Text/Pandoc/Class/CommonState.hs index 7e1735c2b..796a4afd5 100644 --- a/src/Text/Pandoc/Class/CommonState.hs +++ b/src/Text/Pandoc/Class/CommonState.hs @@ -19,7 +19,7 @@ where import Data.Default (Default (def)) import Data.Text (Text) -import Text.Pandoc.BCP47 (Lang) +import Text.Collate.Lang (Lang) import Text.Pandoc.MediaBag (MediaBag) import Text.Pandoc.Logging (LogMessage, Verbosity (WARNING)) import Text.Pandoc.Translations (Translations) diff --git a/src/Text/Pandoc/Class/IO.hs b/src/Text/Pandoc/Class/IO.hs index eecda5711..f4cfc8682 100644 --- a/src/Text/Pandoc/Class/IO.hs +++ b/src/Text/Pandoc/Class/IO.hs @@ -62,7 +62,7 @@ import Text.Pandoc.Definition (Pandoc, Inline (Image)) import Text.Pandoc.Error (PandocError (..)) import Text.Pandoc.Logging (LogMessage (..), messageVerbosity, showLogMessage) import Text.Pandoc.MIME (MimeType) -import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory) +import Text.Pandoc.MediaBag (MediaBag, MediaItem(..), lookupMedia, mediaItems) import Text.Pandoc.Walk (walk) import qualified Control.Exception as E import qualified Data.ByteString as B @@ -183,7 +183,7 @@ getModificationTime = liftIOError System.Directory.getModificationTime logOutput :: (PandocMonad m, MonadIO m) => LogMessage -> m () logOutput msg = liftIO $ do UTF8.hPutStr stderr $ - "[" ++ show (messageVerbosity msg) ++ "] " + "[" <> T.pack (show (messageVerbosity msg)) <> "] " alertIndent $ T.lines $ showLogMessage msg -- | Prints the list of lines to @stderr@, indenting every but the first @@ -191,42 +191,41 @@ logOutput msg = liftIO $ do alertIndent :: [Text] -> IO () alertIndent [] = return () alertIndent (l:ls) = do - UTF8.hPutStrLn stderr $ unpack l + UTF8.hPutStrLn stderr l mapM_ go ls where go l' = do UTF8.hPutStr stderr " " - UTF8.hPutStrLn stderr $ unpack l' + UTF8.hPutStrLn stderr l' -- | Extract media from the mediabag into a directory. extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc extractMedia dir d = do media <- getMediaBag - case [fp | (fp, _, _) <- mediaDirectory media] of - [] -> return d - fps -> do - mapM_ (writeMedia dir media) fps - return $ walk (adjustImagePath dir fps) d + let items = mediaItems media + if null items + then return d + else do + mapM_ (writeMedia dir) items + return $ walk (adjustImagePath dir media) d -- | Write the contents of a media bag to a path. writeMedia :: (PandocMonad m, MonadIO m) - => FilePath -> MediaBag -> FilePath + => FilePath + -> (FilePath, MimeType, BL.ByteString) -> m () -writeMedia dir mediabag subpath = do - -- we join and split to convert a/b/c to a\b\c on Windows; - -- in zip containers all paths use / - let fullpath = dir </> unEscapeString (normalise subpath) - let mbcontents = lookupMedia subpath mediabag - case mbcontents of - Nothing -> throwError $ PandocResourceNotFound $ pack subpath - Just (_, bs) -> do - report $ Extracting $ pack fullpath - liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath) - logIOError $ BL.writeFile fullpath bs +writeMedia dir (fp, _mt, bs) = do + -- we normalize to get proper path separators for the platform + let fullpath = normalise $ dir </> fp + liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath) + logIOError $ BL.writeFile fullpath bs -- | If the given Inline element is an image with a @src@ path equal to -- one in the list of @paths@, then prepends @dir@ to the image source; -- returns the element unchanged otherwise. -adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline -adjustImagePath dir paths (Image attr lab (src, tit)) - | unpack src `elem` paths - = Image attr lab (pack (normalise $ dir </> unpack src), tit) +adjustImagePath :: FilePath -> MediaBag -> Inline -> Inline +adjustImagePath dir mediabag (Image attr lab (src, tit)) = + case lookupMedia (T.unpack src) mediabag of + Nothing -> Image attr lab (src, tit) + Just item -> + let fullpath = dir <> "/" <> mediaPath item + in Image attr lab (T.pack fullpath, tit) adjustImagePath _ _ x = x diff --git a/src/Text/Pandoc/Class/PandocMonad.hs b/src/Text/Pandoc/Class/PandocMonad.hs index 374da161b..439aec071 100644 --- a/src/Text/Pandoc/Class/PandocMonad.hs +++ b/src/Text/Pandoc/Class/PandocMonad.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -37,7 +38,6 @@ module Text.Pandoc.Class.PandocMonad , setUserDataDir , getUserDataDir , fetchItem - , fetchMediaResource , getInputFiles , setInputFiles , getOutputFile @@ -51,30 +51,31 @@ module Text.Pandoc.Class.PandocMonad , setTranslations , translateTerm , makeCanonical + , getTimestamp ) where import Codec.Archive.Zip import Control.Monad.Except (MonadError (catchError, throwError), MonadTrans, lift, when) -import Data.Digest.Pure.SHA (sha1, showDigest) -import Data.Maybe (fromMaybe) +import Data.List (foldl') import Data.Time (UTCTime) -import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds) +import Data.Time.Clock.POSIX (POSIXTime, utcTimeToPOSIXSeconds, + posixSecondsToUTCTime) import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime) import Network.URI ( escapeURIString, nonStrictRelativeTo, unEscapeString, parseURIReference, isAllowedInURI, parseURI, URI(..) ) -import System.FilePath ((</>), (<.>), takeExtension, dropExtension, - isRelative, splitDirectories) +import System.FilePath ((</>), takeExtension, dropExtension, + isRelative, splitDirectories, makeRelative) import System.Random (StdGen) -import Text.Pandoc.BCP47 (Lang(..), parseBCP47, renderLang) +import Text.Collate.Lang (Lang(..), parseLang, renderLang) import Text.Pandoc.Class.CommonState (CommonState (..)) import Text.Pandoc.Definition import Text.Pandoc.Error import Text.Pandoc.Logging -import Text.Pandoc.MIME (MimeType, getMimeType, extensionFromMimeType) -import Text.Pandoc.MediaBag (MediaBag, lookupMedia) -import Text.Pandoc.Shared (uriPathToPath) +import Text.Pandoc.MIME (MimeType, getMimeType) +import Text.Pandoc.MediaBag (MediaBag, lookupMedia, MediaItem(..)) +import Text.Pandoc.Shared (uriPathToPath, safeRead) import Text.Pandoc.Translations (Term(..), Translations, lookupTerm, readTranslations) import Text.Pandoc.Walk (walkM) @@ -175,6 +176,21 @@ report msg = do when (level <= verbosity) $ logOutput msg modifyCommonState $ \st -> st{ stLog = msg : stLog st } +-- | Get the time from the @SOURCE_DATE_EPOCH@ +-- environment variable. The variable should contain a +-- unix time stamp, the number of seconds since midnight Jan 01 +-- 1970 UTC. If the variable is not set or cannot be +-- parsed as a unix time stamp, the current time is returned. +-- This function is designed to make possible reproducible +-- builds in formats that include a creation timestamp. +getTimestamp :: PandocMonad m => m UTCTime +getTimestamp = do + mbSourceDateEpoch <- lookupEnv "SOURCE_DATE_EPOCH" + case mbSourceDateEpoch >>= safeRead of + Just (epoch :: Integer) -> + return $ posixSecondsToUTCTime $ fromIntegral epoch + Nothing -> getCurrentTime + -- | Determine whether tracing is enabled. This affects -- the behavior of 'trace'. If tracing is not enabled, -- 'trace' does nothing. @@ -267,7 +283,7 @@ readFileFromDirs (d:ds) f = catchError toLang :: PandocMonad m => Maybe T.Text -> m (Maybe Lang) toLang Nothing = return Nothing toLang (Just s) = - case parseBCP47 s of + case parseLang s of Left _ -> do report $ InvalidLang s return Nothing @@ -358,7 +374,8 @@ fetchItem :: PandocMonad m fetchItem s = do mediabag <- getMediaBag case lookupMedia (T.unpack s) mediabag of - Just (mime, bs) -> return (BL.toStrict bs, Just mime) + Just item -> return (BL.toStrict (mediaContents item), + Just (mediaMimeType item)) Nothing -> downloadOrRead s -- | Returns the content and, if available, the MIME type of a resource. @@ -393,9 +410,10 @@ downloadOrRead s = do _ -> readLocalFile fp -- get from local file system where readLocalFile f = do resourcePath <- getResourcePath - cont <- if isRelative f - then withPaths resourcePath readFileStrict f - else readFileStrict f + (fp', cont) <- if isRelative f + then withPaths resourcePath readFileStrict f + else (f,) <$> readFileStrict f + report $ LoadedResource f (makeRelative "." fp') return (cont, mime) httpcolon = URI{ uriScheme = "http:", uriAuthority = Nothing, @@ -595,7 +613,7 @@ checkExistence fn = do -- | Canonicalizes a file path by removing redundant @.@ and @..@. makeCanonical :: FilePath -> FilePath makeCanonical = Posix.joinPath . transformPathParts . splitDirectories - where transformPathParts = reverse . foldl go [] + where transformPathParts = reverse . foldl' go [] go as "." = as go (_:as) ".." = as go as x = x : as @@ -605,25 +623,13 @@ makeCanonical = Posix.joinPath . transformPathParts . splitDirectories -- that filepath. Returns the result of the first successful execution -- of the action, or throws a @PandocResourceNotFound@ exception if the -- action errors for all filepaths. -withPaths :: PandocMonad m => [FilePath] -> (FilePath -> m a) -> FilePath -> m a +withPaths :: PandocMonad m + => [FilePath] -> (FilePath -> m a) -> FilePath -> m (FilePath, a) withPaths [] _ fp = throwError $ PandocResourceNotFound $ T.pack fp withPaths (p:ps) action fp = - catchError (action (p </> fp)) + catchError ((p </> fp,) <$> action (p </> fp)) (\_ -> withPaths ps action fp) --- | Fetch local or remote resource (like an image) and provide data suitable --- for adding it to the MediaBag. -fetchMediaResource :: PandocMonad m - => T.Text -> m (FilePath, Maybe MimeType, BL.ByteString) -fetchMediaResource src = do - (bs, mt) <- downloadOrRead src - let ext = fromMaybe (T.pack $ takeExtension $ T.unpack src) - (mt >>= extensionFromMimeType) - let bs' = BL.fromChunks [bs] - let basename = showDigest $ sha1 bs' - let fname = basename <.> T.unpack ext - return (fname, mt, bs') - -- | Traverse tree, filling media bag for any images that -- aren't already in the media bag. fillMediaBag :: PandocMonad m => Pandoc -> m Pandoc @@ -631,12 +637,13 @@ fillMediaBag d = walkM handleImage d where handleImage :: PandocMonad m => Inline -> m Inline handleImage (Image attr lab (src, tit)) = catchError (do mediabag <- getMediaBag - case lookupMedia (T.unpack src) mediabag of - Just (_, _) -> return $ Image attr lab (src, tit) + let fp = T.unpack src + case lookupMedia fp mediabag of + Just _ -> return () Nothing -> do - (fname, mt, bs) <- fetchMediaResource src - insertMedia fname mt bs - return $ Image attr lab (T.pack fname, tit)) + (bs, mt) <- fetchItem src + insertMedia fp mt (BL.fromStrict bs) + return $ Image attr lab (src, tit)) (\e -> case e of PandocResourceNotFound _ -> do |