@@ -46,6 +46,7 @@ module Text.Pandoc.Class ( PandocMonad(..)
4646 , getMediaBag
4747 , setMediaBag
4848 , insertMedia
49+ , fetchItem
4950 , getInputFiles
5051 , getOutputFile
5152 , PandocIO(..)
@@ -64,27 +65,28 @@ import qualified System.Random as IO (newStdGen)
6465import Codec.Archive.Zip (Archive, fromArchive, emptyArchive)
6566import Data.Unique (hashUnique)
6667import qualified Data.Unique as IO (newUnique)
67−import qualified Text.Pandoc.Shared as IO ( fetchItem
68− , fetchItem'
69− , readDataFile
70− , warn)
68+import qualified Text.Pandoc.Shared as IO ( readDataFile
69+ , warn
70+ , openURL )
7171import Text.Pandoc.Compat.Time (UTCTime)
7272import Text.Pandoc.Parsing (ParserT, SourcePos)
7373import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime)
74+import Text.Pandoc.MIME (MimeType, getMimeType)
7475import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds
7576 , posixSecondsToUTCTime
7677 , POSIXTime )
7778import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime, utc)
79+import Network.URI ( escapeURIString, nonStrictRelativeTo,
80+ unEscapeString, parseURIReference, isAllowedInURI,
81+ parseURI, URI(..) )
7882import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)
79−import Text.Pandoc.MIME (MimeType, getMimeType)
80−import Text.Pandoc.MediaBag (MediaBag)
83+import Text.Pandoc.MediaBag (MediaBag, lookupMedia)
8184import qualified Text.Pandoc.MediaBag as MB
8285import qualified Data.ByteString as B
8386import qualified Data.ByteString.Lazy as BL
84−import qualified Control.Exception as E
8587import qualified System.Environment as IO (lookupEnv)
8688import System.FilePath.Glob (match, compile)
87−import System.FilePath ((</>))
89+import System.FilePath ((</>), takeExtension, dropExtension)
8890import qualified System.FilePath.Glob as IO (glob)
8991import qualified System.Directory as IO (getModificationTime)
9092import Control.Monad as M (fail)
@@ -106,17 +108,12 @@ class (Functor m, Applicative m, Monad m, MonadError PandocError m)
106108 getCurrentTimeZone :: m TimeZone
107109 newStdGen :: m StdGen
108110 newUniqueHash :: m Int
111+ openURL :: String -> m (B.ByteString, Maybe MimeType)
109112 readFileLazy :: FilePath -> m BL.ByteString
113+ readFileStrict :: FilePath -> m B.ByteString
110114 readDataFile :: Maybe FilePath
111115 -> FilePath
112116 -> m B.ByteString
113− fetchItem :: Maybe String
114− -> String
115− -> m (Either E.SomeException (B.ByteString, Maybe MimeType))
116− fetchItem' :: MediaBag
117− -> Maybe String
118− -> String
119− -> m (Either E.SomeException (B.ByteString, Maybe MimeType))
120117 glob :: String -> m [FilePath]
121118 getModificationTime :: FilePath -> m UTCTime
122119 getCommonState :: m CommonState
@@ -213,19 +210,28 @@ instance PandocMonad PandocIO where
213210 getCurrentTimeZone = liftIO IO.getCurrentTimeZone
214211 newStdGen = liftIO IO.newStdGen
215212 newUniqueHash = hashUnique <$> (liftIO IO.newUnique)
213+ openURL u = do
214+ eitherRes <- liftIO $ (tryIOError $ IO.openURL u)
215+ case eitherRes of
216+ Right (Right res) -> return res
217+ Right (Left _) -> throwError $ PandocFileReadError u
218+ Left _ -> throwError $ PandocFileReadError u
216219 readFileLazy s = do
217220 eitherBS <- liftIO (tryIOError $ BL.readFile s)
218221 case eitherBS of
219222 Right bs -> return bs
220223 Left _ -> throwError $ PandocFileReadError s
224+ readFileStrict s = do
225+ eitherBS <- liftIO (tryIOError $ B.readFile s)
226+ case eitherBS of
227+ Right bs -> return bs
228+ Left _ -> throwError $ PandocFileReadError s
221229 -- TODO: Make this more sensitive to the different sorts of failure
222230 readDataFile mfp fname = do
223231 eitherBS <- liftIO (tryIOError $ IO.readDataFile mfp fname)
224232 case eitherBS of
225233 Right bs -> return bs
226234 Left _ -> throwError $ PandocFileReadError fname
227− fetchItem ms s = liftIO $ IO.fetchItem ms s
228− fetchItem' mb ms s = liftIO $ IO.fetchItem' mb ms s
229235 glob = liftIO . IO.glob
230236 getModificationTime fp = do
231237 eitherMtime <- liftIO (tryIOError $ IO.getModificationTime fp)
@@ -235,6 +241,64 @@ instance PandocMonad PandocIO where
235241 getCommonState = PandocIO $ lift get
236242 putCommonState x = PandocIO $ lift $ put x
237243
244+
245+-- | Specialized version of parseURIReference that disallows
246+-- single-letter schemes. Reason: these are usually windows absolute
247+-- paths.
248+parseURIReference' :: String -> Maybe URI
249+parseURIReference' s =
250+ case parseURIReference s of
251+ Just u
252+ | length (uriScheme u) > 2 -> Just u
253+ | null (uriScheme u) -> Just u -- protocol-relative
254+ _ -> Nothing
255+
256+-- | Fetch an image or other item from the local filesystem or the net.
257+-- Returns raw content and maybe mime type.
258+fetchItem :: PandocMonad m
259+ => Maybe String
260+ -> String
261+ -> m (B.ByteString, Maybe MimeType)
262+fetchItem sourceURL s = do
263+ mediabag <- getMediaBag
264+ case lookupMedia s mediabag of
265+ Just (mime, bs) -> return $ (BL.toStrict bs, Just mime)
266+ Nothing ->
267+ case (sourceURL >>= parseURIReference' .
268+ ensureEscaped, ensureEscaped s) of
269+ (Just u, s') -> -- try fetching from relative path at source
270+ case parseURIReference' s' of
271+ Just u' -> openURL $ show $ u' `nonStrictRelativeTo` u
272+ Nothing -> openURL s' -- will throw error
273+ (Nothing, s'@('/':'/':_)) -> -- protocol-relative URI
274+ case parseURIReference' s' of
275+ Just u' -> openURL $ show $ u' `nonStrictRelativeTo` httpcolon
276+ Nothing -> openURL s' -- will throw error
277+ (Nothing, s') ->
278+ case parseURI s' of -- requires absolute URI
279+ -- We don't want to treat C:/ as a scheme:
280+ Just u' | length (uriScheme u') > 2 -> openURL (show u')
281+ Just u' | uriScheme u' == "file:" ->
282+ readLocalFile $ dropWhile (=='/') (uriPath u')
283+ _ -> readLocalFile fp -- get from local file system
284+ where readLocalFile f = do
285+ cont <- readFileStrict f
286+ return (cont, mime)
287+ httpcolon = URI{ uriScheme = "http:",
288+ uriAuthority = Nothing,
289+ uriPath = "",
290+ uriQuery = "",
291+ uriFragment = "" }
292+ dropFragmentAndQuery = takeWhile (\c -> c /= '?' && c /= '#')
293+ fp = unEscapeString $ dropFragmentAndQuery s
294+ mime = case takeExtension fp of
295+ ".gz" -> getMimeType $ dropExtension fp
296+ ".svgz" -> getMimeType $ dropExtension fp ++ ".svg"
297+ x -> getMimeType x
298+ ensureEscaped = escapeURIString isAllowedInURI . map convertSlash
299+ convertSlash '\\' = '/'
300+ convertSlash x = x
301+
238302data PureState = PureState { stStdGen :: StdGen
239303 , stWord8Store :: [Word8] -- should be
240304 -- inifinite,
@@ -332,33 +396,29 @@ instance PandocMonad PandocPure where
332396 modifyPureState $ \st -> st { stUniqStore = us }
333397 return u
334398 _ -> M.fail "uniq store ran out of elements"
399+ openURL _ = undefined -- TODO
335400 readFileLazy fp = do
336401 fps <- getsPureState stFiles
337402 case infoFileContents <$> getFileInfo fp fps of
338403 Just bs -> return (BL.fromStrict bs)
339404 Nothing -> throwError $ PandocFileReadError fp
405+ readFileStrict fp = do
406+ fps <- getsPureState stFiles
407+ case infoFileContents <$> getFileInfo fp fps of
408+ Just bs -> return bs
409+ Nothing -> throwError $ PandocFileReadError fp
340410 readDataFile Nothing "reference.docx" = do
341411 (B.concat . BL.toChunks . fromArchive) <$> getsPureState stReferenceDocx
342412 readDataFile Nothing "reference.odt" = do
343413 (B.concat . BL.toChunks . fromArchive) <$> getsPureState stReferenceODT
344414 readDataFile Nothing fname = do
345415 let fname' = if fname == "MANUAL.txt" then fname else "data" </> fname
346− BL.toStrict <$> (readFileLazy fname')
416+ readFileStrict fname'
347417 readDataFile (Just userDir) fname = do
348418 userDirFiles <- getsPureState stUserDataDir
349419 case infoFileContents <$> (getFileInfo (userDir </> fname) userDirFiles) of
350420 Just bs -> return bs
351421 Nothing -> readDataFile Nothing fname
352− fetchItem _ fp = do
353− fps <- getsPureState stFiles
354− case infoFileContents <$> (getFileInfo fp fps) of
355− Just bs -> return (Right (bs, getMimeType fp))
356− Nothing -> return (Left $ E.toException $ PandocFileReadError fp)
357−
358− fetchItem' media sourceUrl nm = do
359− case MB.lookupMedia nm media of
360− Nothing -> fetchItem sourceUrl nm
361− Just (mime, bs) -> return (Right (B.concat $ BL.toChunks bs, Just mime))
362422
363423 glob s = do
364424 fontFiles <- getsPureState stFontFiles
@@ -379,10 +439,10 @@ instance PandocMonad m => PandocMonad (ParserT s st m) where
379439 getCurrentTimeZone = lift getCurrentTimeZone
380440 newStdGen = lift newStdGen
381441 newUniqueHash = lift newUniqueHash
442+ openURL = lift . openURL
382443 readFileLazy = lift . readFileLazy
444+ readFileStrict = lift . readFileStrict
383445 readDataFile mbuserdir = lift . readDataFile mbuserdir
384− fetchItem media = lift . fetchItem media
385− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl
386446 glob = lift . glob
387447 getModificationTime = lift . getModificationTime
388448 getCommonState = lift getCommonState
@@ -394,10 +454,10 @@ instance PandocMonad m => PandocMonad (ReaderT r m) where
394454 getCurrentTimeZone = lift getCurrentTimeZone
395455 newStdGen = lift newStdGen
396456 newUniqueHash = lift newUniqueHash
457+ openURL = lift . openURL
397458 readFileLazy = lift . readFileLazy
459+ readFileStrict = lift . readFileStrict
398460 readDataFile mbuserdir = lift . readDataFile mbuserdir
399− fetchItem media = lift . fetchItem media
400− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl
401461 glob = lift . glob
402462 getModificationTime = lift . getModificationTime
403463 getCommonState = lift getCommonState
@@ -409,10 +469,10 @@ instance (PandocMonad m, Monoid w) => PandocMonad (WriterT w m) where
409469 getCurrentTimeZone = lift getCurrentTimeZone
410470 newStdGen = lift newStdGen
411471 newUniqueHash = lift newUniqueHash
472+ openURL = lift . openURL
412473 readFileLazy = lift . readFileLazy
474+ readFileStrict = lift . readFileStrict
413475 readDataFile mbuserdir = lift . readDataFile mbuserdir
414− fetchItem media = lift . fetchItem media
415− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl
416476 glob = lift . glob
417477 getModificationTime = lift . getModificationTime
418478 getCommonState = lift getCommonState
@@ -424,10 +484,10 @@ instance (PandocMonad m, Monoid w) => PandocMonad (RWST r w st m) where
424484 getCurrentTimeZone = lift getCurrentTimeZone
425485 newStdGen = lift newStdGen
426486 newUniqueHash = lift newUniqueHash
487+ openURL = lift . openURL
427488 readFileLazy = lift . readFileLazy
489+ readFileStrict = lift . readFileStrict
428490 readDataFile mbuserdir = lift . readDataFile mbuserdir
429− fetchItem media = lift . fetchItem media
430− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl
431491 glob = lift . glob
432492 getModificationTime = lift . getModificationTime
433493 getCommonState = lift getCommonState
@@ -439,10 +499,10 @@ instance PandocMonad m => PandocMonad (StateT st m) where
439499 getCurrentTimeZone = lift getCurrentTimeZone
440500 newStdGen = lift newStdGen
441501 newUniqueHash = lift newUniqueHash
502+ openURL = lift . openURL
442503 readFileLazy = lift . readFileLazy
504+ readFileStrict = lift . readFileStrict
443505 readDataFile mbuserdir = lift . readDataFile mbuserdir
444− fetchItem media = lift . fetchItem media
445− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl
446506 glob = lift . glob
447507 getModificationTime = lift . getModificationTime
448508 getCommonState = lift getCommonState