git.iko.soy/typeable/pandoc
on 34412cf help sign in
typeable/pandoc/src/Text/Pandoc/Class.hs
558 lines 21 kB history raw
1{-# LANGUAGE DeriveFunctor, DeriveDataTypeable, TypeSynonymInstances,
2FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts,
3StandaloneDeriving #-}
5{-
6Copyright (C) 2016 Jesse Rosenthal <jrosenthal@jhu.edu>
8This program is free software; you can redistribute it and/or modify
9it under the terms of the GNU General Public License as published by
10the Free Software Foundation; either version 2 of the License, or
11(at your option) any later version.
13This program is distributed in the hope that it will be useful,
14but WITHOUT ANY WARRANTY; without even the implied warranty of
15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16GNU General Public License for more details.
18You should have received a copy of the GNU General Public License
19along with this program; if not, write to the Free Software
20Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21-}
23{- |
24 Module : Text.Pandoc.Class
25 Copyright : Copyright (C) 2016 Jesse Rosenthal
26 License : GNU GPL, version 2 or above
28 Maintainer : Jesse Rosenthal <jrosenthal@jhu.edu>
29 Stability : alpha
30 Portability : portable
32Typeclass for pandoc readers and writers, allowing both IO and pure instances.
33-}
35module Text.Pandoc.Class ( PandocMonad(..)
36 , CommonState(..)
37 , PureState(..)
38 , getPureState
39 , getsPureState
40 , putPureState
41 , modifyPureState
42 , getPOSIXTime
43 , getZonedTime
44 , readFileFromDirs
45 , report
46 , getLog
47 , setVerbosity
48 , getMediaBag
49 , setMediaBag
50 , insertMedia
51 , fetchItem
52 , getInputFiles
53 , getOutputFile
54 , setResourcePath
55 , getResourcePath
56 , PandocIO(..)
57 , PandocPure(..)
58 , FileTree(..)
59 , FileInfo(..)
60 , runIO
61 , runIOorExplode
62 , runPure
63 , withMediaBag
64 ) where
66import Prelude hiding (readFile)
67import System.Random (StdGen, next, mkStdGen)
68import qualified System.Random as IO (newStdGen)
69import Codec.Archive.Zip (Archive, fromArchive, emptyArchive)
70import Data.Unique (hashUnique)
71import qualified Data.Unique as IO (newUnique)
72import qualified Text.Pandoc.Shared as IO ( readDataFile
73 , openURL )
74import qualified Text.Pandoc.UTF8 as UTF8
75import Text.Pandoc.Compat.Time (UTCTime)
76import Text.Pandoc.Logging
77import Text.Parsec (ParsecT)
78import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime)
79import Text.Pandoc.MIME (MimeType, getMimeType)
80import Data.Char (toLower)
81import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds
82 , posixSecondsToUTCTime
83 , POSIXTime )
84import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime, utc)
85import Network.URI ( escapeURIString, nonStrictRelativeTo,
86 unEscapeString, parseURIReference, isAllowedInURI,
87 parseURI, URI(..) )
88import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
89import Text.Pandoc.MediaBag (MediaBag, lookupMedia)
90import qualified Text.Pandoc.MediaBag as MB
91import qualified Data.ByteString as B
92import qualified Data.ByteString.Lazy as BL
93import qualified System.Environment as IO (lookupEnv)
94import System.FilePath.Glob (match, compile)
95import System.FilePath ((</>), takeExtension, dropExtension, isRelative)
96import qualified System.FilePath.Glob as IO (glob)
97import qualified System.Directory as IO (getModificationTime)
98import Control.Monad as M (fail)
99import Control.Monad.Reader (ReaderT)
100import Control.Monad.State
101import Control.Monad.Except
102import Control.Monad.Writer (WriterT)
103import Control.Monad.RWS (RWST)
104import Data.Word (Word8)
105import Data.Default
106import System.IO.Error
107import System.IO (stderr)
108import qualified Data.Map as M
109import Text.Pandoc.Error
111class (Functor m, Applicative m, Monad m, MonadError PandocError m)
112 => PandocMonad m where
113 lookupEnv :: String -> m (Maybe String)
114 getCurrentTime :: m UTCTime
115 getCurrentTimeZone :: m TimeZone
116 newStdGen :: m StdGen
117 newUniqueHash :: m Int
118 openURL :: String -> m (B.ByteString, Maybe MimeType)
119 readFileLazy :: FilePath -> m BL.ByteString
120 readFileStrict :: FilePath -> m B.ByteString
121 readDataFile :: Maybe FilePath -> FilePath -> m B.ByteString
122 glob :: String -> m [FilePath]
123 getModificationTime :: FilePath -> m UTCTime
124 getCommonState :: m CommonState
125 putCommonState :: CommonState -> m ()
127 getsCommonState :: (CommonState -> a) -> m a
128 getsCommonState f = f <$> getCommonState
130 modifyCommonState :: (CommonState -> CommonState) -> m ()
131 modifyCommonState f = getCommonState >>= putCommonState . f
133 logOutput :: LogMessage -> m ()
135-- Functions defined for all PandocMonad instances
137setVerbosity :: PandocMonad m => Verbosity -> m ()
138setVerbosity verbosity =
139 modifyCommonState $ \st -> st{ stVerbosity = verbosity }
141getLog :: PandocMonad m => m [LogMessage]
142getLog = reverse <$> getsCommonState stLog
144report :: PandocMonad m => LogMessage -> m ()
145report msg = do
146 verbosity <- getsCommonState stVerbosity
147 let level = messageVerbosity msg
148 when (level <= verbosity) $ do
149 logOutput msg
150 unless (level == DEBUG) $
151 modifyCommonState $ \st -> st{ stLog = msg : stLog st }
153setMediaBag :: PandocMonad m => MediaBag -> m ()
154setMediaBag mb = modifyCommonState $ \st -> st{stMediaBag = mb}
156getMediaBag :: PandocMonad m => m MediaBag
157getMediaBag = getsCommonState stMediaBag
159insertMedia :: PandocMonad m => FilePath -> Maybe MimeType -> BL.ByteString -> m ()
160insertMedia fp mime bs = do
161 mb <- getsCommonState stMediaBag
162 let mb' = MB.insertMedia fp mime bs mb
163 modifyCommonState $ \st -> st{stMediaBag = mb' }
165getInputFiles :: PandocMonad m => m (Maybe [FilePath])
166getInputFiles = getsCommonState stInputFiles
168getOutputFile :: PandocMonad m => m (Maybe FilePath)
169getOutputFile = getsCommonState stOutputFile
171setResourcePath :: PandocMonad m => [FilePath] -> m ()
172setResourcePath ps = modifyCommonState $ \st -> st{stResourcePath = ps}
174getResourcePath :: PandocMonad m => m [FilePath]
175getResourcePath = getsCommonState stResourcePath
177getPOSIXTime :: (PandocMonad m) => m POSIXTime
178getPOSIXTime = utcTimeToPOSIXSeconds <$> getCurrentTime
180getZonedTime :: (PandocMonad m) => m ZonedTime
181getZonedTime = do
182 t <- getCurrentTime
183 tz <- getCurrentTimeZone
184 return $ utcToZonedTime tz t
186-- | Read file, checking in any number of directories.
187readFileFromDirs :: PandocMonad m => [FilePath] -> FilePath -> m (Maybe String)
188readFileFromDirs [] _ = return Nothing
189readFileFromDirs (d:ds) f = catchError
190 ((Just . UTF8.toStringLazy) <$> readFileLazy (d </> f))
191 (\_ -> readFileFromDirs ds f)
193--
195data CommonState = CommonState { stLog :: [LogMessage]
196 , stMediaBag :: MediaBag
197 , stInputFiles :: Maybe [FilePath]
198 , stOutputFile :: Maybe FilePath
199 , stResourcePath :: [FilePath]
200 , stVerbosity :: Verbosity
201 }
203instance Default CommonState where
204 def = CommonState { stLog = []
205 , stMediaBag = mempty
206 , stInputFiles = Nothing
207 , stOutputFile = Nothing
208 , stResourcePath = ["."]
209 , stVerbosity = WARNING
210 }
212runIO :: PandocIO a -> IO (Either PandocError a)
213runIO ma = flip evalStateT def $ runExceptT $ unPandocIO ma
215withMediaBag :: PandocMonad m => m a -> m (a, MediaBag)
216withMediaBag ma = ((,)) <$> ma <*> getMediaBag
218runIOorExplode :: PandocIO a -> IO a
219runIOorExplode ma = runIO ma >>= handleError
221newtype PandocIO a = PandocIO {
222 unPandocIO :: ExceptT PandocError (StateT CommonState IO) a
223 } deriving ( MonadIO
224 , Functor
225 , Applicative
226 , Monad
227 , MonadError PandocError
228 )
230liftIOError :: (String -> IO a) -> String -> PandocIO a
231liftIOError f u = do
232 res <- liftIO $ tryIOError $ f u
233 case res of
234 Left e -> throwError $ PandocIOError u e
235 Right r -> return r
237instance PandocMonad PandocIO where
238 lookupEnv = liftIO . IO.lookupEnv
239 getCurrentTime = liftIO IO.getCurrentTime
240 getCurrentTimeZone = liftIO IO.getCurrentTimeZone
241 newStdGen = liftIO IO.newStdGen
242 newUniqueHash = hashUnique <$> (liftIO IO.newUnique)
243 openURL u = do
244 report $ Fetching u
245 liftIOError IO.openURL u
246 readFileLazy s = liftIOError BL.readFile s
247 readFileStrict s = liftIOError B.readFile s
248 readDataFile mfp fname = liftIOError (IO.readDataFile mfp) fname
249 glob = liftIO . IO.glob
250 getModificationTime fp = liftIOError IO.getModificationTime fp
251 getCommonState = PandocIO $ lift get
252 putCommonState x = PandocIO $ lift $ put x
253 logOutput msg = liftIO $ do
254 UTF8.hPutStr stderr $ "[" ++
255 (map toLower $ show (messageVerbosity msg)) ++ "] "
256 alertIndent $ lines $ showLogMessage msg
258alertIndent :: [String] -> IO ()
259alertIndent [] = return ()
260alertIndent (l:ls) = do
261 UTF8.hPutStrLn stderr l
262 mapM_ go ls
263 where go l' = do UTF8.hPutStr stderr "! "
264 UTF8.hPutStrLn stderr l'
266-- | Specialized version of parseURIReference that disallows
267-- single-letter schemes. Reason: these are usually windows absolute
268-- paths.
269parseURIReference' :: String -> Maybe URI
270parseURIReference' s =
271 case parseURIReference s of
272 Just u
273 | length (uriScheme u) > 2 -> Just u
274 | null (uriScheme u) -> Just u -- protocol-relative
275 _ -> Nothing
277-- | Fetch an image or other item from the local filesystem or the net.
278-- Returns raw content and maybe mime type.
279fetchItem :: PandocMonad m
280 => Maybe String
281 -> String
282 -> m (B.ByteString, Maybe MimeType)
283fetchItem sourceURL s = do
284 mediabag <- getMediaBag
285 case lookupMedia s mediabag of
286 Just (mime, bs) -> return $ (BL.toStrict bs, Just mime)
287 Nothing -> downloadOrRead sourceURL s
289downloadOrRead :: PandocMonad m
290 => Maybe String
291 -> String
292 -> m (B.ByteString, Maybe MimeType)
293downloadOrRead sourceURL s = do
294 case (sourceURL >>= parseURIReference' .
295 ensureEscaped, ensureEscaped s) of
296 (Just u, s') -> -- try fetching from relative path at source
297 case parseURIReference' s' of
298 Just u' -> openURL $ show $ u' `nonStrictRelativeTo` u
299 Nothing -> openURL s' -- will throw error
300 (Nothing, s'@('/':'/':_)) -> -- protocol-relative URI
301 case parseURIReference' s' of
302 Just u' -> openURL $ show $ u' `nonStrictRelativeTo` httpcolon
303 Nothing -> openURL s' -- will throw error
304 (Nothing, s') ->
305 case parseURI s' of -- requires absolute URI
306 -- We don't want to treat C:/ as a scheme:
307 Just u' | length (uriScheme u') > 2 -> openURL (show u')
308 Just u' | uriScheme u' == "file:" ->
309 readLocalFile $ dropWhile (=='/') (uriPath u')
310 _ -> readLocalFile fp -- get from local file system
311 where readLocalFile f = do
312 resourcePath <- getResourcePath
313 cont <- if isRelative f
314 then withPaths resourcePath readFileStrict f
315 else readFileStrict f
316 return (cont, mime)
317 httpcolon = URI{ uriScheme = "http:",
318 uriAuthority = Nothing,
319 uriPath = "",
320 uriQuery = "",
321 uriFragment = "" }
322 dropFragmentAndQuery = takeWhile (\c -> c /= '?' && c /= '#')
323 fp = unEscapeString $ dropFragmentAndQuery s
324 mime = case takeExtension fp of
325 ".gz" -> getMimeType $ dropExtension fp
326 ".svgz" -> getMimeType $ dropExtension fp ++ ".svg"
327 x -> getMimeType x
328 ensureEscaped = escapeURIString isAllowedInURI . map convertSlash
329 convertSlash '\\' = '/'
330 convertSlash x = x
332withPaths :: PandocMonad m => [FilePath] -> (FilePath -> m a) -> FilePath -> m a
333withPaths [] _ fp = throwError $ PandocIOError fp
334 (userError "file not found in resource path")
335withPaths (p:ps) action fp =
336 catchError (action (p </> fp))
337 (\_ -> withPaths ps action fp)
339data PureState = PureState { stStdGen :: StdGen
340 , stWord8Store :: [Word8] -- should be
341 -- inifinite,
342 -- i.e. [1..]
343 , stUniqStore :: [Int] -- should be
344 -- inifinite and
345 -- contain every
346 -- element at most
347 -- once, e.g. [1..]
348 , stEnv :: [(String, String)]
349 , stTime :: UTCTime
350 , stTimeZone :: TimeZone
351 , stReferenceDocx :: Archive
352 , stReferenceODT :: Archive
353 , stFiles :: FileTree
354 , stUserDataDir :: FileTree
355 , stCabalDataDir :: FileTree
356 , stFontFiles :: [FilePath]
357 }
359instance Default PureState where
360 def = PureState { stStdGen = mkStdGen 1848
361 , stWord8Store = [1..]
362 , stUniqStore = [1..]
363 , stEnv = [("USER", "pandoc-user")]
364 , stTime = posixSecondsToUTCTime 0
365 , stTimeZone = utc
366 , stReferenceDocx = emptyArchive
367 , stReferenceODT = emptyArchive
368 , stFiles = mempty
369 , stUserDataDir = mempty
370 , stCabalDataDir = mempty
371 , stFontFiles = []
372 }
375getPureState :: PandocPure PureState
376getPureState = PandocPure $ lift $ lift $ get
378getsPureState :: (PureState -> a) -> PandocPure a
379getsPureState f = f <$> getPureState
381putPureState :: PureState -> PandocPure ()
382putPureState ps= PandocPure $ lift $ lift $ put ps
384modifyPureState :: (PureState -> PureState) -> PandocPure ()
385modifyPureState f = PandocPure $ lift $ lift $ modify f
388data FileInfo = FileInfo { infoFileMTime :: UTCTime
389 , infoFileContents :: B.ByteString
390 }
392newtype FileTree = FileTree {unFileTree :: M.Map FilePath FileInfo}
393 deriving (Monoid)
395getFileInfo :: FilePath -> FileTree -> Maybe FileInfo
396getFileInfo fp tree = M.lookup fp $ unFileTree tree
399newtype PandocPure a = PandocPure {
400 unPandocPure :: ExceptT PandocError
401 (StateT CommonState (State PureState)) a
402 } deriving ( Functor
403 , Applicative
404 , Monad
405 , MonadError PandocError
406 )
408runPure :: PandocPure a -> Either PandocError a
409runPure x = flip evalState def $
410 flip evalStateT def $
411 runExceptT $
412 unPandocPure x
414instance PandocMonad PandocPure where
415 lookupEnv s = do
416 env <- getsPureState stEnv
417 return (lookup s env)
419 getCurrentTime = getsPureState stTime
421 getCurrentTimeZone = getsPureState stTimeZone
423 newStdGen = do
424 g <- getsPureState stStdGen
425 let (_, nxtGen) = next g
426 modifyPureState $ \st -> st { stStdGen = nxtGen }
427 return g
429 newUniqueHash = do
430 uniqs <- getsPureState stUniqStore
431 case uniqs of
432 u : us -> do
433 modifyPureState $ \st -> st { stUniqStore = us }
434 return u
435 _ -> M.fail "uniq store ran out of elements"
436 openURL u = throwError $ PandocIOError u $
437 userError "Cannot open URL in PandocPure"
438 readFileLazy fp = do
439 fps <- getsPureState stFiles
440 case infoFileContents <$> getFileInfo fp fps of
441 Just bs -> return (BL.fromStrict bs)
442 Nothing -> throwError $ PandocIOError fp
443 (userError "File not found in PureState")
444 readFileStrict fp = do
445 fps <- getsPureState stFiles
446 case infoFileContents <$> getFileInfo fp fps of
447 Just bs -> return bs
448 Nothing -> throwError $ PandocIOError fp
449 (userError "File not found in PureState")
450 readDataFile Nothing "reference.docx" = do
451 (B.concat . BL.toChunks . fromArchive) <$> getsPureState stReferenceDocx
452 readDataFile Nothing "reference.odt" = do
453 (B.concat . BL.toChunks . fromArchive) <$> getsPureState stReferenceODT
454 readDataFile Nothing fname = do
455 let fname' = if fname == "MANUAL.txt" then fname else "data" </> fname
456 readFileStrict fname'
457 readDataFile (Just userDir) fname = do
458 userDirFiles <- getsPureState stUserDataDir
459 case infoFileContents <$> (getFileInfo (userDir </> fname) userDirFiles) of
460 Just bs -> return bs
461 Nothing -> readDataFile Nothing fname
463 glob s = do
464 fontFiles <- getsPureState stFontFiles
465 return (filter (match (compile s)) fontFiles)
467 getModificationTime fp = do
468 fps <- getsPureState stFiles
469 case infoFileMTime <$> (getFileInfo fp fps) of
470 Just tm -> return tm
471 Nothing -> throwError $ PandocIOError fp
472 (userError "Can't get modification time")
474 getCommonState = PandocPure $ lift $ get
475 putCommonState x = PandocPure $ lift $ put x
477 logOutput _msg = return ()
479instance PandocMonad m => PandocMonad (ParsecT s st m) where
480 lookupEnv = lift . lookupEnv
481 getCurrentTime = lift getCurrentTime
482 getCurrentTimeZone = lift getCurrentTimeZone
483 newStdGen = lift newStdGen
484 newUniqueHash = lift newUniqueHash
485 openURL = lift . openURL
486 readFileLazy = lift . readFileLazy
487 readFileStrict = lift . readFileStrict
488 readDataFile mbuserdir = lift . readDataFile mbuserdir
489 glob = lift . glob
490 getModificationTime = lift . getModificationTime
491 getCommonState = lift getCommonState
492 putCommonState = lift . putCommonState
493 logOutput = lift . logOutput
495instance PandocMonad m => PandocMonad (ReaderT r m) where
496 lookupEnv = lift . lookupEnv
497 getCurrentTime = lift getCurrentTime
498 getCurrentTimeZone = lift getCurrentTimeZone
499 newStdGen = lift newStdGen
500 newUniqueHash = lift newUniqueHash
501 openURL = lift . openURL
502 readFileLazy = lift . readFileLazy
503 readFileStrict = lift . readFileStrict
504 readDataFile mbuserdir = lift . readDataFile mbuserdir
505 glob = lift . glob
506 getModificationTime = lift . getModificationTime
507 getCommonState = lift getCommonState
508 putCommonState = lift . putCommonState
509 logOutput = lift . logOutput
511instance (PandocMonad m, Monoid w) => PandocMonad (WriterT w m) where
512 lookupEnv = lift . lookupEnv
513 getCurrentTime = lift getCurrentTime
514 getCurrentTimeZone = lift getCurrentTimeZone
515 newStdGen = lift newStdGen
516 newUniqueHash = lift newUniqueHash
517 openURL = lift . openURL
518 readFileLazy = lift . readFileLazy
519 readFileStrict = lift . readFileStrict
520 readDataFile mbuserdir = lift . readDataFile mbuserdir
521 glob = lift . glob
522 getModificationTime = lift . getModificationTime
523 getCommonState = lift getCommonState
524 putCommonState = lift . putCommonState
525 logOutput = lift . logOutput
527instance (PandocMonad m, Monoid w) => PandocMonad (RWST r w st m) where
528 lookupEnv = lift . lookupEnv
529 getCurrentTime = lift getCurrentTime
530 getCurrentTimeZone = lift getCurrentTimeZone
531 newStdGen = lift newStdGen
532 newUniqueHash = lift newUniqueHash
533 openURL = lift . openURL
534 readFileLazy = lift . readFileLazy
535 readFileStrict = lift . readFileStrict
536 readDataFile mbuserdir = lift . readDataFile mbuserdir
537 glob = lift . glob
538 getModificationTime = lift . getModificationTime
539 getCommonState = lift getCommonState
540 putCommonState = lift . putCommonState
541 logOutput = lift . logOutput
543instance PandocMonad m => PandocMonad (StateT st m) where
544 lookupEnv = lift . lookupEnv
545 getCurrentTime = lift getCurrentTime
546 getCurrentTimeZone = lift getCurrentTimeZone
547 newStdGen = lift newStdGen
548 newUniqueHash = lift newUniqueHash
549 openURL = lift . openURL
550 readFileLazy = lift . readFileLazy
551 readFileStrict = lift . readFileStrict
552 readDataFile mbuserdir = lift . readDataFile mbuserdir
553 glob = lift . glob
554 getModificationTime = lift . getModificationTime
555 getCommonState = lift getCommonState
556 putCommonState = lift . putCommonState
557 logOutput = lift . logOutput