@@ -1,17 +1,6 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE PatternGuards #-}
3−{-# LANGUAGE DeriveFunctor #-}
4−{-# LANGUAGE MultiParamTypeClasses #-}
5−{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE UndecidableInstances #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
10−{-# LANGUAGE OverloadedStrings #-}
11−{-# LANGUAGE ViewPatterns #-}
121{- |
132 Module : Text.Pandoc.Class
14− Copyright : Copyright (C) 2016-17 Jesse Rosenthal, John MacFarlane
3+ Copyright : Copyright (C) 2016-2020 Jesse Rosenthal, John MacFarlane
154 License : GNU GPL, version 2 or above
165
176 Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
@@ -25,388 +14,16 @@ whether they want conversions to perform IO operations (such as
2514reading include files or images).
2615-}
2716
28−module Text.Pandoc.Class ( PandocMonad(..)
29− , CommonState(..)
30− , PureState(..)
31− , getPureState
32− , getsPureState
33− , putPureState
34− , modifyPureState
35− , getPOSIXTime
36− , getZonedTime
37− , readFileFromDirs
38− , report
39− , setTrace
40− , setRequestHeader
41− , getLog
42− , setVerbosity
43− , getVerbosity
44− , getMediaBag
45− , setMediaBag
46− , insertMedia
47− , setUserDataDir
48− , getUserDataDir
49− , fetchItem
50− , getInputFiles
51− , setInputFiles
52− , getOutputFile
53− , setOutputFile
54− , setResourcePath
55− , getResourcePath
56− , PandocIO(..)
57− , PandocPure(..)
58− , FileTree
59− , FileInfo(..)
60− , addToFileTree
61− , insertInFileTree
62− , runIO
63− , runIOorExplode
64− , runPure
65− , readDefaultDataFile
66− , readDataFile
67− , fetchMediaResource
68− , fillMediaBag
69− , extractMedia
70− , toLang
71− , setTranslations
72− , translateTerm
73− , Translations
74− ) where
17+module Text.Pandoc.Class
18+ ( module Text.Pandoc.Class.CommonState
19+ , module Text.Pandoc.Class.PandocIO
20+ , module Text.Pandoc.Class.PandocMonad
21+ , module Text.Pandoc.Class.PandocPure
22+ , Translations
23+ ) where
7524
76−import Codec.Archive.Zip
77−import Control.Monad.Except
78−import Control.Monad.State.Strict
79−import Data.ByteString.Base64 (decodeLenient)
80−import Data.ByteString.Lazy (toChunks)
81−import Data.Default
82−import Data.Time (UTCTime)
83−import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
84−import Data.Time.LocalTime (TimeZone, utc)
85−import Data.Unique (hashUnique)
86−import Data.Word (Word8)
87−import Network.HTTP.Client
88− (httpLbs, responseBody, responseHeaders,
89− Request(port, host, requestHeaders), parseRequest, newManager)
90−import Network.HTTP.Client.Internal (addProxy)
91−import Network.HTTP.Client.TLS (tlsManagerSettings)
92−import Network.HTTP.Types.Header ( hContentType )
93−import Network.Socket (withSocketsDo)
94−import Network.URI ( unEscapeString )
95−import Prelude
96−import System.Directory (createDirectoryIfMissing, getDirectoryContents,
97− doesDirectoryExist)
98−import System.Environment (getEnv)
99−import System.FilePath ((</>), takeDirectory, normalise)
100−import System.FilePath.Glob (match, compile)
101−import System.IO (stderr)
102−import System.IO.Error
103−import System.Random (StdGen, next, mkStdGen)
10425import Text.Pandoc.Class.CommonState (CommonState (..))
10526import Text.Pandoc.Class.PandocMonad
106−import Text.Pandoc.Definition
107−import Text.Pandoc.Error
108−import Text.Pandoc.Logging
109−import Text.Pandoc.MediaBag (MediaBag, lookupMedia, mediaDirectory)
27+import Text.Pandoc.Class.PandocIO
28+import Text.Pandoc.Class.PandocPure
11029import Text.Pandoc.Translations (Translations)
111−import Text.Pandoc.Walk (walk)
112−import qualified Control.Exception as E
113−import qualified Data.ByteString as B
114−import qualified Data.ByteString.Lazy as BL
115−import qualified Data.CaseInsensitive as CI
116−import qualified Data.Map as M
117−import qualified Data.Text as T
118−import qualified Data.Time as IO (getCurrentTime)
119−import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
120−import qualified Data.Unique as IO (newUnique)
121−import qualified System.Directory as Directory
122−import qualified System.Directory as IO (getModificationTime)
123−import qualified System.Environment as IO (lookupEnv)
124−import qualified System.FilePath.Glob as IO (glob)
125−import qualified System.Random as IO (newStdGen)
126−import qualified Text.Pandoc.UTF8 as UTF8
127−#ifndef EMBED_DATA_FILES
128−import qualified Paths_pandoc as Paths
129−#endif
130−
131−-- | Evaluate a 'PandocIO' operation.
132−runIO :: PandocIO a -> IO (Either PandocError a)
133−runIO ma = flip evalStateT def $ runExceptT $ unPandocIO ma
134−
135−-- | Evaluate a 'PandocIO' operation, handling any errors
136−-- by exiting with an appropriate message and error status.
137−runIOorExplode :: PandocIO a -> IO a
138−runIOorExplode ma = runIO ma >>= handleError
139−
140−newtype PandocIO a = PandocIO {
141− unPandocIO :: ExceptT PandocError (StateT CommonState IO) a
142− } deriving ( MonadIO
143− , Functor
144− , Applicative
145− , Monad
146− , MonadError PandocError
147− )
148−
149−-- | Utility function to lift IO errors into 'PandocError's.
150−liftIOError :: (String -> IO a) -> String -> PandocIO a
151−liftIOError f u = do
152− res <- liftIO $ tryIOError $ f u
153− case res of
154− Left e -> throwError $ PandocIOError (T.pack u) e
155− Right r -> return r
156−
157−-- | Show potential IO errors to the user continuing execution anyway
158−logIOError :: IO () -> PandocIO ()
159−logIOError f = do
160− res <- liftIO $ tryIOError f
161− case res of
162− Left e -> report $ IgnoredIOError $ T.pack $ E.displayException e
163− Right _ -> pure ()
164−
165−instance PandocMonad PandocIO where
166− lookupEnv = fmap (fmap T.pack) . liftIO . IO.lookupEnv . T.unpack
167− getCurrentTime = liftIO IO.getCurrentTime
168− getCurrentTimeZone = liftIO IO.getCurrentTimeZone
169− newStdGen = liftIO IO.newStdGen
170− newUniqueHash = hashUnique <$> liftIO IO.newUnique
171−
172− openURL u
173− | Just u'' <- T.stripPrefix "data:" u = do
174− let mime = T.takeWhile (/=',') u''
175− let contents = UTF8.fromString $
176− unEscapeString $ T.unpack $ T.drop 1 $ T.dropWhile (/=',') u''
177− return (decodeLenient contents, Just mime)
178− | otherwise = do
179− let toReqHeader (n, v) = (CI.mk (UTF8.fromText n), UTF8.fromText v)
180− customHeaders <- map toReqHeader <$> getsCommonState stRequestHeaders
181− report $ Fetching u
182− res <- liftIO $ E.try $ withSocketsDo $ do
183− let parseReq = parseRequest
184− proxy <- tryIOError (getEnv "http_proxy")
185− let addProxy' x = case proxy of
186− Left _ -> return x
187− Right pr -> parseReq pr >>= \r ->
188− return (addProxy (host r) (port r) x)
189− req <- parseReq (T.unpack u) >>= addProxy'
190− let req' = req{requestHeaders = customHeaders ++ requestHeaders req}
191− resp <- newManager tlsManagerSettings >>= httpLbs req'
192− return (B.concat $ toChunks $ responseBody resp,
193− UTF8.toText `fmap` lookup hContentType (responseHeaders resp))
194−
195− case res of
196− Right r -> return r
197− Left e -> throwError $ PandocHttpError u e
198−
199− readFileLazy s = liftIOError BL.readFile s
200− readFileStrict s = liftIOError B.readFile s
201−
202− glob = liftIOError IO.glob
203− fileExists = liftIOError Directory.doesFileExist
204−#ifdef EMBED_DATA_FILES
205− getDataFileName = return
206−#else
207− getDataFileName = liftIOError Paths.getDataFileName
208−#endif
209− getModificationTime = liftIOError IO.getModificationTime
210− getCommonState = PandocIO $ lift get
211− putCommonState x = PandocIO $ lift $ put x
212− logOutput msg = liftIO $ do
213− UTF8.hPutStr stderr $
214− "[" ++ show (messageVerbosity msg) ++ "] "
215− alertIndent $ T.lines $ showLogMessage msg
216−
217−alertIndent :: [T.Text] -> IO ()
218−alertIndent [] = return ()
219−alertIndent (l:ls) = do
220− UTF8.hPutStrLn stderr $ T.unpack l
221− mapM_ go ls
222− where go l' = do UTF8.hPutStr stderr " "
223− UTF8.hPutStrLn stderr $ T.unpack l'
224−
225−-- | Extract media from the mediabag into a directory.
226−extractMedia :: FilePath -> Pandoc -> PandocIO Pandoc
227−extractMedia dir d = do
228− media <- getMediaBag
229− case [fp | (fp, _, _) <- mediaDirectory media] of
230− [] -> return d
231− fps -> do
232− mapM_ (writeMedia dir media) fps
233− return $ walk (adjustImagePath dir fps) d
234−
235−-- Write the contents of a media bag to a path.
236−writeMedia :: FilePath -> MediaBag -> FilePath -> PandocIO ()
237−writeMedia dir mediabag subpath = do
238− -- we join and split to convert a/b/c to a\b\c on Windows;
239− -- in zip containers all paths use /
240− let fullpath = dir </> unEscapeString (normalise subpath)
241− let mbcontents = lookupMedia subpath mediabag
242− case mbcontents of
243− Nothing -> throwError $ PandocResourceNotFound $ T.pack subpath
244− Just (_, bs) -> do
245− report $ Extracting $ T.pack fullpath
246− liftIOError (createDirectoryIfMissing True) (takeDirectory fullpath)
247− logIOError $ BL.writeFile fullpath bs
248−
249−adjustImagePath :: FilePath -> [FilePath] -> Inline -> Inline
250−adjustImagePath dir paths (Image attr lab (src, tit))
251− | T.unpack src `elem` paths = Image attr lab (T.pack dir <> "/" <> src, tit)
252−adjustImagePath _ _ x = x
253−
254−-- | The 'PureState' contains ersatz representations
255−-- of things that would normally be obtained through IO.
256−data PureState = PureState { stStdGen :: StdGen
257− , stWord8Store :: [Word8] -- should be
258− -- infinite,
259− -- i.e. [1..]
260− , stUniqStore :: [Int] -- should be
261− -- infinite and
262− -- contain every
263− -- element at most
264− -- once, e.g. [1..]
265− , stEnv :: [(T.Text, T.Text)]
266− , stTime :: UTCTime
267− , stTimeZone :: TimeZone
268− , stReferenceDocx :: Archive
269− , stReferencePptx :: Archive
270− , stReferenceODT :: Archive
271− , stFiles :: FileTree
272− , stUserDataFiles :: FileTree
273− , stCabalDataFiles :: FileTree
274− }
275−
276−instance Default PureState where
277− def = PureState { stStdGen = mkStdGen 1848
278− , stWord8Store = [1..]
279− , stUniqStore = [1..]
280− , stEnv = [("USER", "pandoc-user")]
281− , stTime = posixSecondsToUTCTime 0
282− , stTimeZone = utc
283− , stReferenceDocx = emptyArchive
284− , stReferencePptx = emptyArchive
285− , stReferenceODT = emptyArchive
286− , stFiles = mempty
287− , stUserDataFiles = mempty
288− , stCabalDataFiles = mempty
289− }
290−
291−
292−getPureState :: PandocPure PureState
293−getPureState = PandocPure $ lift $ lift get
294−
295−getsPureState :: (PureState -> a) -> PandocPure a
296−getsPureState f = f <$> getPureState
297−
298−putPureState :: PureState -> PandocPure ()
299−putPureState ps= PandocPure $ lift $ lift $ put ps
300−
301−modifyPureState :: (PureState -> PureState) -> PandocPure ()
302−modifyPureState f = PandocPure $ lift $ lift $ modify f
303−
304−
305−data FileInfo = FileInfo { infoFileMTime :: UTCTime
306− , infoFileContents :: B.ByteString
307− }
308−
309−newtype FileTree = FileTree {unFileTree :: M.Map FilePath FileInfo}
310− deriving (Semigroup, Monoid)
311−
312−getFileInfo :: FilePath -> FileTree -> Maybe FileInfo
313−getFileInfo fp tree =
314− M.lookup (makeCanonical fp) (unFileTree tree)
315−
316−-- | Add the specified file to the FileTree. If file
317−-- is a directory, add its contents recursively.
318−addToFileTree :: FileTree -> FilePath -> IO FileTree
319−addToFileTree tree fp = do
320− isdir <- doesDirectoryExist fp
321− if isdir
322− then do -- recursively add contents of directories
323− let isSpecial ".." = True
324− isSpecial "." = True
325− isSpecial _ = False
326− fs <- (map (fp </>) . filter (not . isSpecial)) <$> getDirectoryContents fp
327− foldM addToFileTree tree fs
328− else do
329− contents <- B.readFile fp
330− mtime <- IO.getModificationTime fp
331− return $ insertInFileTree fp FileInfo{ infoFileMTime = mtime
332− , infoFileContents = contents } tree
333−
334−-- | Insert an ersatz file into the 'FileTree'.
335−insertInFileTree :: FilePath -> FileInfo -> FileTree -> FileTree
336−insertInFileTree fp info (FileTree treemap) =
337− FileTree $ M.insert (makeCanonical fp) info treemap
338−
339−newtype PandocPure a = PandocPure {
340− unPandocPure :: ExceptT PandocError
341− (StateT CommonState (State PureState)) a
342− } deriving ( Functor
343− , Applicative
344− , Monad
345− , MonadError PandocError
346− )
347−
348−-- Run a 'PandocPure' operation.
349−runPure :: PandocPure a -> Either PandocError a
350−runPure x = flip evalState def $
351− flip evalStateT def $
352− runExceptT $
353− unPandocPure x
354−
355−instance PandocMonad PandocPure where
356− lookupEnv s = do
357− env <- getsPureState stEnv
358− return (lookup s env)
359−
360− getCurrentTime = getsPureState stTime
361−
362− getCurrentTimeZone = getsPureState stTimeZone
363−
364− newStdGen = do
365− g <- getsPureState stStdGen
366− let (_, nxtGen) = next g
367− modifyPureState $ \st -> st { stStdGen = nxtGen }
368− return g
369−
370− newUniqueHash = do
371− uniqs <- getsPureState stUniqStore
372− case uniqs of
373− u : us -> do
374− modifyPureState $ \st -> st { stUniqStore = us }
375− return u
376− _ -> throwError $ PandocShouldNeverHappenError
377− "uniq store ran out of elements"
378− openURL u = throwError $ PandocResourceNotFound u
379− readFileLazy fp = do
380− fps <- getsPureState stFiles
381− case infoFileContents <$> getFileInfo fp fps of
382− Just bs -> return (BL.fromStrict bs)
383− Nothing -> throwError $ PandocResourceNotFound $ T.pack fp
384− readFileStrict fp = do
385− fps <- getsPureState stFiles
386− case infoFileContents <$> getFileInfo fp fps of
387− Just bs -> return bs
388− Nothing -> throwError $ PandocResourceNotFound $ T.pack fp
389−
390− glob s = do
391− FileTree ftmap <- getsPureState stFiles
392− return $ filter (match (compile s)) $ M.keys ftmap
393−
394− fileExists fp = do
395− fps <- getsPureState stFiles
396− case getFileInfo fp fps of
397− Nothing -> return False
398− Just _ -> return True
399−
400− getDataFileName fp = return $ "data/" ++ fp
401−
402− getModificationTime fp = do
403− fps <- getsPureState stFiles
404− case infoFileMTime <$> getFileInfo fp fps of
405− Just tm -> return tm
406− Nothing -> throwError $ PandocIOError (T.pack fp)
407− (userError "Can't get modification time")
408−
409− getCommonState = PandocPure $ lift get
410− putCommonState x = PandocPure $ lift $ put x
411−
412− logOutput _msg = return ()