git.iko.soy/typeable/pandoc
on master help sign in
Class: generalize PandocIO functions to MonadIO
eceb8eaAlbert Krewinkel
pandoc.cabal+1
compare with master
unifiedsplit
@@ -571,6 +571,7 @@ library
571 Text.Pandoc.App.Opt,
571 Text.Pandoc.App.Opt,
572 Text.Pandoc.App.OutputSettings,
572 Text.Pandoc.App.OutputSettings,
573 Text.Pandoc.Class.CommonState,
573 Text.Pandoc.Class.CommonState,
574+ Text.Pandoc.Class.IO,
574 Text.Pandoc.Class.PandocMonad,
575 Text.Pandoc.Class.PandocMonad,
575 Text.Pandoc.Class.PandocIO,
576 Text.Pandoc.Class.PandocIO,
576 Text.Pandoc.Class.PandocPure,
577 Text.Pandoc.Class.PandocPure,
src/Text/Pandoc/Class/IO.hsnew file+231
@@ -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
src/Text/Pandoc/Class/PandocIO.hs+21−167
@@ -1,7 +1,5 @@
1−{-# LANGUAGE CPP #-}
2{-# LANGUAGE DeriveFunctor #-}
1{-# LANGUAGE DeriveFunctor #-}
3{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4−{-# LANGUAGE OverloadedStrings #-}
5{- |
3{- |
6Module : Text.Pandoc.Class.PandocIO
4Module : Text.Pandoc.Class.PandocIO
7Copyright : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane
5Copyright : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane
@@ -16,79 +14,21 @@ This module defines @'PandocIO'@, an IO-based instance of the
16using IO operators.
14using IO operators.
17-}
15-}
18module Text.Pandoc.Class.PandocIO
16module Text.Pandoc.Class.PandocIO
19− ( getPOSIXTime
20− , getZonedTime
21− , readFileFromDirs
22− , report
23− , setTrace
24− , setRequestHeader
25− , getLog
26− , setVerbosity
27− , getVerbosity
28− , getMediaBag
29− , setMediaBag
30− , insertMedia
31− , setUserDataDir
32− , getUserDataDir
33− , fetchItem
34− , getInputFiles
35− , setInputFiles
36− , getOutputFile
37− , setOutputFile
38− , setResourcePath
39− , getResourcePath
40− , PandocIO(..)
17+ ( PandocIO(..)
41 , runIO
18 , runIO
42 , runIOorExplode
19 , runIOorExplode
43 , extractMedia
20 , extractMedia
44 ) where
21 ) where
45
22
46−import Control.Monad.Except
23+import Control.Monad.Except (ExceptT, MonadError, runExceptT)
24+import Control.Monad.IO.Class (MonadIO)
47−import Control.Monad.State.Strict
25+import Control.Monad.State (StateT, evalStateT, lift, get, put)
48−import Data.ByteString.Base64 (decodeLenient)
26+import Data.Default (Default (def))
49−import Data.ByteString.Lazy (toChunks)
50−import Data.Default
51−import Data.Text (Text)
52−import Data.Unique (hashUnique)
53−import Network.HTTP.Client
54− (httpLbs, responseBody, responseHeaders,
55− Request(port, host, requestHeaders), parseRequest, newManager)
56−import Network.HTTP.Client.Internal (addProxy)
57−import Network.HTTP.Client.TLS (mkManagerSettings)
58−import Network.Connection (TLSSettings (..))
59−import Network.HTTP.Types.Header ( hContentType )
60−import Network.Socket (withSocketsDo)
61−import Network.URI ( unEscapeString )
62−import Prelude
63−import System.Directory (createDirectoryIfMissing)
64−import System.Environment (getEnv)
65−import System.FilePath ((</>), takeDirectory, normalise)
66−import System.IO (stderr)
67−import System.IO.Error
68import Text.Pandoc.Class.CommonState (CommonState (..))
27import Text.Pandoc.Class.CommonState (CommonState (..))
69import Text.Pandoc.Class.PandocMonad
28import Text.Pandoc.Class.PandocMonad
70import Text.Pandoc.Definition
29import Text.Pandoc.Definition
71import Text.Pandoc.Error
30import Text.Pandoc.Error
72−import Text.Pandoc.Logging
31+import qualified Text.Pandoc.Class.IO as IO
73−import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)
74−import Text.Pandoc.Walk (walk)
75−import qualified Control.Exception as E
76−import qualified Data.ByteString as B
77−import qualified Data.ByteString.Lazy as BL
78−import qualified Data.CaseInsensitive as CI
79−import qualified Data.Text as T
80−import qualified Data.Time as IO (getCurrentTime)
81−import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
82−import qualified Data.Unique as IO (newUnique)
83−import qualified System.Directory as Directory
84−import qualified System.Directory as IO (getModificationTime)
85−import qualified System.Environment as IO (lookupEnv)
86−import qualified System.FilePath.Glob as IO (glob)
87−import qualified System.Random as IO (newStdGen)
88−import qualified Text.Pandoc.UTF8 as UTF8
89−#ifndef EMBED_DATA_FILES
90−import qualified Paths_pandoc as Paths
91−#endif
92
32
93-- | Evaluate a 'PandocIO' operation.
33-- | Evaluate a 'PandocIO' operation.
94runIO :: PandocIO a -> IO (Either PandocError a)
34runIO :: PandocIO a -> IO (Either PandocError a)
@@ -108,113 +48,27 @@ newtype PandocIO a = PandocIO {
108 , MonadError PandocError
48 , MonadError PandocError
109 )
49 )
110
50
111−-- | Utility function to lift IO errors into 'PandocError's.
112−liftIOError :: (String -> IO a) -> String -> PandocIO a
113−liftIOError f u = do
114− res <- liftIO $ tryIOError $ f u
115− case res of
116− Left e -> throwError $ PandocIOError (T.pack u) e
117− Right r -> return r
118−
119−-- | Show potential IO errors to the user continuing execution anyway
120−logIOError :: IO () -> PandocIO ()
121−logIOError f = do
122− res <- liftIO $ tryIOError f
123− case res of
124− Left e -> report $ IgnoredIOError $ T.pack $ E.displayException e
125− Right _ -> pure ()
126−
127instance PandocMonad PandocIO where
51instance PandocMonad PandocIO where
128− lookupEnv = fmap (fmap T.pack) . liftIO . IO.lookupEnv . T.unpack
52+ lookupEnv = IO.lookupEnv
129− getCurrentTime = liftIO IO.getCurrentTime
53+ getCurrentTime = IO.getCurrentTime
130− getCurrentTimeZone = liftIO IO.getCurrentTimeZone
54+ getCurrentTimeZone = IO.getCurrentTimeZone
131− newStdGen = liftIO IO.newStdGen
55+ newStdGen = IO.newStdGen
132− newUniqueHash = hashUnique <$> liftIO IO.newUnique
56+ newUniqueHash = IO.newUniqueHash
133−
134− openURL u
135− | Just u'' <- T.stripPrefix "data:" u = do
136− let mime = T.takeWhile (/=',') u''
137− let contents = UTF8.fromString $
138− unEscapeString $ T.unpack $ T.drop 1 $ T.dropWhile (/=',') u''
139− return (decodeLenient contents, Just mime)
140− | otherwise = do
141− let toReqHeader (n, v) = (CI.mk (UTF8.fromText n), UTF8.fromText v)
142− customHeaders <- map toReqHeader <$> getsCommonState stRequestHeaders
143− disableCertificateValidation <- getsCommonState stNoCheckCertificate
144− report $ Fetching u
145− res <- liftIO $ E.try $ withSocketsDo $ do
146− let parseReq = parseRequest
147− proxy <- tryIOError (getEnv "http_proxy")
148− let addProxy' x = case proxy of
149− Left _ -> return x
150− Right pr -> parseReq pr >>= \r ->
151− return (addProxy (host r) (port r) x)
152− req <- parseReq (T.unpack u) >>= addProxy'
153− let req' = req{requestHeaders = customHeaders ++ requestHeaders req}
154− resp <- newManager (mkManagerSettings (TLSSettingsSimple disableCertificateValidation False False) Nothing) >>= httpLbs req'
155− return (B.concat $ toChunks $ responseBody resp,
156− UTF8.toText `fmap` lookup hContentType (responseHeaders resp))
157
57
158− case res of
58+ openURL = IO.openURL
159− Right r -> return r
59+ readFileLazy = IO.readFileLazy
160− Left e -> throwError $ PandocHttpError u e
60+ readFileStrict = IO.readFileStrict
161
61
162− readFileLazy s = liftIOError BL.readFile s
62+ glob = IO.glob
163− readFileStrict s = liftIOError B.readFile s
63+ fileExists = IO.fileExists
64+ getDataFileName = IO.getDataFileName
65+ getModificationTime = IO.getModificationTime
164
66
165− glob = liftIOError IO.glob
166− fileExists = liftIOError Directory.doesFileExist
167−#ifdef EMBED_DATA_FILES
168− getDataFileName = return
169−#else
170− getDataFileName = liftIOError Paths.getDataFileName
171−#endif
172− getModificationTime = liftIOError IO.getModificationTime
173 getCommonState = PandocIO $ lift get
67 getCommonState = PandocIO $ lift get
174− putCommonState x = PandocIO $ lift $ put x
68+ putCommonState = PandocIO . lift . put
175− logOutput msg = liftIO $ do
176− UTF8.hPutStr stderr $
177− "[" ++ show (messageVerbosity msg) ++ "] "
178− alertIndent $ T.lines $ showLogMessage msg
179
69
180−-- | Prints the list of lines to @stderr@, indenting every but the first
70+ logOutput = IO.logOutput
181−-- line by two spaces.
182−alertIndent :: [Text] -> IO ()
183−alertIndent [] = return ()
184−alertIndent (l:ls) = do
185− UTF8.hPutStrLn stderr $ T.unpack l
186− mapM_ go ls
187− where go l' = do UTF8.hPutStr stderr " "
188− UTF8.hPutStrLn stderr $ T.unpack l'
189
71
190-- | Extract media from the mediabag into a directory.
72-- | Extract media from the mediabag into a directory.
191extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
73extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
192−extractMedia dir d = do
74+extractMedia = IO.extractMedia
193− media <- getMediaBag
194− case [fp | (fp, _, _) <- mediaDirectory media] of
195− [] -> return d
196− fps -> do
197− mapM_ (writeMedia dir media) fps
198− return $ walk (adjustImagePath dir fps) d
199−
200−-- | Write the contents of a media bag to a path.
201−writeMedia :: FilePath -> MediaBag -> FilePath -> PandocIO ()
202−writeMedia dir mediabag subpath = do
203− -- we join and split to convert a/b/c to a\b\c on Windows;
204− -- in zip containers all paths use /
205− let fullpath = dir </> unEscapeString (normalise subpath)
206− let mbcontents = lookupMedia subpath mediabag
207− case mbcontents of
208− Nothing -> throwError $ PandocResourceNotFound $ T.pack subpath
209− Just (_, bs) -> do
210− report $ Extracting $ T.pack fullpath
211− liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath)
212− logIOError $ BL.writeFile fullpath bs
213−
214−-- | If the given Inline element is an image with a @src@ path equal to
215−-- one in the list of @paths@, then prepends @dir@ to the image source;
216−-- returns the element unchanged otherwise.
217−adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
218−adjustImagePath dir paths (Image attr lab (src, tit))
219− | T.unpack src `elem` paths = Image attr lab (T.pack dir <> "/" <> src, tit)
220−adjustImagePath _ _ x = x