aboutsummaryrefslogtreecommitdiff
path: root/src/Text/Pandoc/Class/PandocMonad.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Text/Pandoc/Class/PandocMonad.hs')
-rw-r--r--src/Text/Pandoc/Class/PandocMonad.hs79
1 files changed, 43 insertions, 36 deletions
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-06-30 06:57:15 +0000