@@ -0,0 +1,231 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{- |
4+Module : Text.Pandoc.Class.IO
5+Copyright : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane
6+License : GNU GPL, version 2 or above
7+
8+Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
9+Stability : alpha
10+Portability : portable
11+
12+Default ways to perform @'PandocMonad'@ actions in a @'MonadIO'@ type.
13+
14+These functions are used to make the @'PandocIO'@ type an instance of
15+@'PandocMonad'@, but can be reused for any other MonadIO-conforming
16+types.
17+-}
18+module Text.Pandoc.Class.IO
19+ ( fileExists
20+ , getCurrentTime
21+ , getCurrentTimeZone
22+ , getDataFileName
23+ , getModificationTime
24+ , glob
25+ , logOutput
26+ , logIOError
27+ , lookupEnv
28+ , newStdGen
29+ , newUniqueHash
30+ , openURL
31+ , readFileLazy
32+ , readFileStrict
33+ , extractMedia
34+ ) where
35+
36+import Control.Monad.Except (throwError)
37+import Control.Monad.IO.Class (MonadIO, liftIO)
38+import Data.ByteString.Base64 (decodeLenient)
39+import Data.ByteString.Lazy (toChunks)
40+import Data.Text (Text, pack, unpack)
41+import Data.Time (TimeZone, UTCTime)
42+import Data.Unique (hashUnique)
43+import Network.Connection (TLSSettings (TLSSettingsSimple))
44+import Network.HTTP.Client
45+ (httpLbs, responseBody, responseHeaders,
46+ Request(port, host, requestHeaders), parseRequest, newManager)
47+import Network.HTTP.Client.Internal (addProxy)
48+import Network.HTTP.Client.TLS (mkManagerSettings)
49+import Network.HTTP.Types.Header ( hContentType )
50+import Network.Socket (withSocketsDo)
51+import Network.URI (unEscapeString)
52+import System.Directory (createDirectoryIfMissing)
53+import System.Environment (getEnv)
54+import System.FilePath ((</>), takeDirectory, normalise)
55+import System.IO (stderr)
56+import System.IO.Error
57+import System.Random (StdGen)
58+import Text.Pandoc.Class.CommonState (CommonState (..))
59+import Text.Pandoc.Class.PandocMonad
60+ (PandocMonad, getsCommonState, getMediaBag, report)
61+import Text.Pandoc.Definition (Pandoc, Inline (Image))
62+import Text.Pandoc.Error (PandocError (..))
63+import Text.Pandoc.Logging (LogMessage (..), messageVerbosity, showLogMessage)
64+import Text.Pandoc.MIME (MimeType)
65+import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)
66+import Text.Pandoc.Walk (walk)
67+import qualified Control.Exception as E
68+import qualified Data.ByteString as B
69+import qualified Data.ByteString.Lazy as BL
70+import qualified Data.CaseInsensitive as CI
71+import qualified Data.Text as T
72+import qualified Data.Time
73+import qualified Data.Time.LocalTime
74+import qualified Data.Unique
75+import qualified System.Directory
76+import qualified System.Environment as Env
77+import qualified System.FilePath.Glob
78+import qualified System.Random
79+import qualified Text.Pandoc.UTF8 as UTF8
80+#ifndef EMBED_DATA_FILES
81+import qualified Paths_pandoc as Paths
82+#endif
83+
84+-- | Utility function to lift IO errors into 'PandocError's.
85+liftIOError :: (PandocMonad m, MonadIO m) => (String -> IO a) -> String -> m a
86+liftIOError f u = do
87+ res <- liftIO $ tryIOError $ f u
88+ case res of
89+ Left e -> throwError $ PandocIOError (pack u) e
90+ Right r -> return r
91+
92+-- | Show potential IO errors to the user continuing execution anyway
93+logIOError :: (PandocMonad m, MonadIO m) => IO () -> m ()
94+logIOError f = do
95+ res <- liftIO $ tryIOError f
96+ case res of
97+ Left e -> report $ IgnoredIOError $ pack $ E.displayException e
98+ Right _ -> pure ()
99+
100+-- | Lookup an environment variable in the programs environment.
101+lookupEnv :: MonadIO m => Text -> m (Maybe Text)
102+lookupEnv = fmap (fmap pack) . liftIO . Env.lookupEnv . unpack
103+
104+-- | Get the current (UTC) time.
105+getCurrentTime :: MonadIO m => m UTCTime
106+getCurrentTime = liftIO Data.Time.getCurrentTime
107+
108+-- | Get the locale's time zone.
109+getCurrentTimeZone :: MonadIO m => m TimeZone
110+getCurrentTimeZone = liftIO Data.Time.LocalTime.getCurrentTimeZone
111+
112+-- | Return a new generator for random numbers.
113+newStdGen :: MonadIO m => m StdGen
114+newStdGen = liftIO System.Random.newStdGen
115+
116+-- | Return a new unique integer.
117+newUniqueHash :: MonadIO m => m Int
118+newUniqueHash = hashUnique <$> liftIO Data.Unique.newUnique
119+
120+openURL :: (PandocMonad m, MonadIO m) => Text -> m (B.ByteString, Maybe MimeType)
121+openURL u
122+ | Just u'' <- T.stripPrefix "data:" u = do
123+ let mime = T.takeWhile (/=',') u''
124+ let contents = UTF8.fromString $
125+ unEscapeString $ T.unpack $ T.drop 1 $ T.dropWhile (/=',') u''
126+ return (decodeLenient contents, Just mime)
127+ | otherwise = do
128+ let toReqHeader (n, v) = (CI.mk (UTF8.fromText n), UTF8.fromText v)
129+ customHeaders <- map toReqHeader <$> getsCommonState stRequestHeaders
130+ disableCertificateValidation <- getsCommonState stNoCheckCertificate
131+ report $ Fetching u
132+ res <- liftIO $ E.try $ withSocketsDo $ do
133+ let parseReq = parseRequest
134+ proxy <- tryIOError (getEnv "http_proxy")
135+ let addProxy' x = case proxy of
136+ Left _ -> return x
137+ Right pr -> parseReq pr >>= \r ->
138+ return (addProxy (host r) (port r) x)
139+ req <- parseReq (unpack u) >>= addProxy'
140+ let req' = req{requestHeaders = customHeaders ++ requestHeaders req}
141+ let tlsSimple = TLSSettingsSimple disableCertificateValidation False False
142+ let tlsManagerSettings = mkManagerSettings tlsSimple Nothing
143+ resp <- newManager tlsManagerSettings >>= httpLbs req'
144+ return (B.concat $ toChunks $ responseBody resp,
145+ UTF8.toText `fmap` lookup hContentType (responseHeaders resp))
146+
147+ case res of
148+ Right r -> return r
149+ Left e -> throwError $ PandocHttpError u e
150+
151+-- | Read the lazy ByteString contents from a file path, raising an error on
152+-- failure.
153+readFileLazy :: (PandocMonad m, MonadIO m) => FilePath -> m BL.ByteString
154+readFileLazy s = liftIOError BL.readFile s
155+
156+-- | Read the strict ByteString contents from a file path,
157+-- raising an error on failure.
158+readFileStrict :: (PandocMonad m, MonadIO m) => FilePath -> m B.ByteString
159+readFileStrict s = liftIOError B.readFile s
160+
161+-- | Return a list of paths that match a glob, relative to the working
162+-- directory. See 'System.FilePath.Glob' for the glob syntax.
163+glob :: (PandocMonad m, MonadIO m) => String -> m [FilePath]
164+glob = liftIOError System.FilePath.Glob.glob
165+
166+-- | Returns True if file exists.
167+fileExists :: (PandocMonad m, MonadIO m) => FilePath -> m Bool
168+fileExists = liftIOError System.Directory.doesFileExist
169+
170+-- | Returns the path of data file.
171+getDataFileName :: (PandocMonad m, MonadIO m) => FilePath -> m FilePath
172+#ifdef EMBED_DATA_FILES
173+getDataFileName = return
174+#else
175+getDataFileName = liftIOError Paths.getDataFileName
176+#endif
177+
178+-- | Return the modification time of a file.
179+getModificationTime :: (PandocMonad m, MonadIO m) => FilePath -> m UTCTime
180+getModificationTime = liftIOError System.Directory.getModificationTime
181+
182+-- | Output a log message.
183+logOutput :: (PandocMonad m, MonadIO m) => LogMessage -> m ()
184+logOutput msg = liftIO $ do
185+ UTF8.hPutStr stderr $
186+ "[" ++ show (messageVerbosity msg) ++ "] "
187+ alertIndent $ T.lines $ showLogMessage msg
188+
189+-- | Prints the list of lines to @stderr@, indenting every but the first
190+-- line by two spaces.
191+alertIndent :: [Text] -> IO ()
192+alertIndent [] = return ()
193+alertIndent (l:ls) = do
194+ UTF8.hPutStrLn stderr $ unpack l
195+ mapM_ go ls
196+ where go l' = do UTF8.hPutStr stderr " "
197+ UTF8.hPutStrLn stderr $ unpack l'
198+
199+-- | Extract media from the mediabag into a directory.
200+extractMedia :: (PandocMonad m, MonadIO m) => FilePath -> Pandoc -> m Pandoc
201+extractMedia dir d = do
202+ media <- getMediaBag
203+ case [fp | (fp, _, _) <- mediaDirectory media] of
204+ [] -> return d
205+ fps -> do
206+ mapM_ (writeMedia dir media) fps
207+ return $ walk (adjustImagePath dir fps) d
208+
209+-- | Write the contents of a media bag to a path.
210+writeMedia :: (PandocMonad m, MonadIO m)
211+ => FilePath -> MediaBag -> FilePath
212+ -> m ()
213+writeMedia dir mediabag subpath = do
214+ -- we join and split to convert a/b/c to a\b\c on Windows;
215+ -- in zip containers all paths use /
216+ let fullpath = dir </> unEscapeString (normalise subpath)
217+ let mbcontents = lookupMedia subpath mediabag
218+ case mbcontents of
219+ Nothing -> throwError $ PandocResourceNotFound $ pack subpath
220+ Just (_, bs) -> do
221+ report $ Extracting $ pack fullpath
222+ liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath)
223+ logIOError $ BL.writeFile fullpath bs
224+
225+-- | If the given Inline element is an image with a @src@ path equal to
226+-- one in the list of @paths@, then prepends @dir@ to the image source;
227+-- returns the element unchanged otherwise.
228+adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
229+adjustImagePath dir paths (Image attr lab (src, tit))
230+ | unpack src `elem` paths = Image attr lab (pack dir <> "/" <> src, tit)
231+adjustImagePath _ _ x = x