4cb124d · typeable/pandoc

git.iko.soy/typeable/pandoc

on master help sign in

Add openURL and readFileStrict to PandocMonad.

4cb124dJohn MacFarlane10 years ago

src/Text/Pandoc/Class.hs+98−38

compare with master

unifiedsplit

@@ -46,6 +46,7 @@ module Text.Pandoc.Class ( PandocMonad(..)

46 , getMediaBag

47 , setMediaBag

48 , insertMedia

49+ , fetchItem

49 , getInputFiles

50 , getInputFiles

50 , getOutputFile

51 , getOutputFile

51 , PandocIO(..)

52 , PandocIO(..)

@@ -64,27 +65,28 @@ import qualified System.Random as IO (newStdGen)

64import Codec.Archive.Zip (Archive, fromArchive, emptyArchive)

65import Codec.Archive.Zip (Archive, fromArchive, emptyArchive)

65import Data.Unique (hashUnique)

66import Data.Unique (hashUnique)

66import qualified Data.Unique as IO (newUnique)

67import qualified Data.Unique as IO (newUnique)

67−import qualified Text.Pandoc.Shared as IO ( fetchItem

68+import qualified Text.Pandoc.Shared as IO ( readDataFile

68− , fetchItem'

69− , readDataFile

70− , warn)

69+ , warn

70+ , openURL )

71import Text.Pandoc.Compat.Time (UTCTime)

72import Text.Pandoc.Parsing (ParserT, SourcePos)

73import qualified Text.Pandoc.Compat.Time as IO (getCurrentTime)

74+import Text.Pandoc.MIME (MimeType, getMimeType)

74import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds

75import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds

75 , posixSecondsToUTCTime

76 , posixSecondsToUTCTime

76 , POSIXTime )

77 , POSIXTime )

77import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime, utc)

78import Data.Time.LocalTime (TimeZone, ZonedTime, utcToZonedTime, utc)

79+import Network.URI ( escapeURIString, nonStrictRelativeTo,

80+ unEscapeString, parseURIReference, isAllowedInURI,

81+ parseURI, URI(..) )

78import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)

82import qualified Data.Time.LocalTime as IO (getCurrentTimeZone)

79−import Text.Pandoc.MIME (MimeType, getMimeType)

83+import Text.Pandoc.MediaBag (MediaBag, lookupMedia)

80−import Text.Pandoc.MediaBag (MediaBag)

81import qualified Text.Pandoc.MediaBag as MB

84import qualified Text.Pandoc.MediaBag as MB

82import qualified Data.ByteString as B

85import qualified Data.ByteString as B

83import qualified Data.ByteString.Lazy as BL

86import qualified Data.ByteString.Lazy as BL

84−import qualified Control.Exception as E

85import qualified System.Environment as IO (lookupEnv)

87import qualified System.Environment as IO (lookupEnv)

86import System.FilePath.Glob (match, compile)

88import System.FilePath.Glob (match, compile)

87−import System.FilePath ((</>))

89+import System.FilePath ((</>), takeExtension, dropExtension)

88import qualified System.FilePath.Glob as IO (glob)

90import qualified System.FilePath.Glob as IO (glob)

89import qualified System.Directory as IO (getModificationTime)

91import qualified System.Directory as IO (getModificationTime)

90import Control.Monad as M (fail)

92import Control.Monad as M (fail)

@@ -106,17 +108,12 @@ class (Functor m, Applicative m, Monad m, MonadError PandocError m)

106 getCurrentTimeZone :: m TimeZone

108 getCurrentTimeZone :: m TimeZone

107 newStdGen :: m StdGen

109 newStdGen :: m StdGen

108 newUniqueHash :: m Int

110 newUniqueHash :: m Int

111+ openURL :: String -> m (B.ByteString, Maybe MimeType)

109 readFileLazy :: FilePath -> m BL.ByteString

112 readFileLazy :: FilePath -> m BL.ByteString

113+ readFileStrict :: FilePath -> m B.ByteString

110 readDataFile :: Maybe FilePath

114 readDataFile :: Maybe FilePath

111 -> FilePath

115 -> FilePath

112 -> m B.ByteString

116 -> 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))

120 glob :: String -> m [FilePath]

117 glob :: String -> m [FilePath]

121 getModificationTime :: FilePath -> m UTCTime

118 getModificationTime :: FilePath -> m UTCTime

122 getCommonState :: m CommonState

119 getCommonState :: m CommonState

@@ -213,19 +210,28 @@ instance PandocMonad PandocIO where

213 getCurrentTimeZone = liftIO IO.getCurrentTimeZone

210 getCurrentTimeZone = liftIO IO.getCurrentTimeZone

214 newStdGen = liftIO IO.newStdGen

211 newStdGen = liftIO IO.newStdGen

215 newUniqueHash = hashUnique <$> (liftIO IO.newUnique)

212 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

216 readFileLazy s = do

219 readFileLazy s = do

217 eitherBS <- liftIO (tryIOError $ BL.readFile s)

220 eitherBS <- liftIO (tryIOError $ BL.readFile s)

218 case eitherBS of

221 case eitherBS of

219 Right bs -> return bs

222 Right bs -> return bs

220 Left _ -> throwError $ PandocFileReadError s

223 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

221 -- TODO: Make this more sensitive to the different sorts of failure

229 -- TODO: Make this more sensitive to the different sorts of failure

222 readDataFile mfp fname = do

230 readDataFile mfp fname = do

223 eitherBS <- liftIO (tryIOError $ IO.readDataFile mfp fname)

231 eitherBS <- liftIO (tryIOError $ IO.readDataFile mfp fname)

224 case eitherBS of

232 case eitherBS of

225 Right bs -> return bs

233 Right bs -> return bs

226 Left _ -> throwError $ PandocFileReadError fname

234 Left _ -> throwError $ PandocFileReadError fname

227− fetchItem ms s = liftIO $ IO.fetchItem ms s

228− fetchItem' mb ms s = liftIO $ IO.fetchItem' mb ms s

229 glob = liftIO . IO.glob

235 glob = liftIO . IO.glob

230 getModificationTime fp = do

236 getModificationTime fp = do

231 eitherMtime <- liftIO (tryIOError $ IO.getModificationTime fp)

237 eitherMtime <- liftIO (tryIOError $ IO.getModificationTime fp)

@@ -235,6 +241,64 @@ instance PandocMonad PandocIO where

235 getCommonState = PandocIO $ lift get

241 getCommonState = PandocIO $ lift get

236 putCommonState x = PandocIO $ lift $ put x

242 putCommonState x = PandocIO $ lift $ put x

237

243

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+

238data PureState = PureState { stStdGen :: StdGen

302data PureState = PureState { stStdGen :: StdGen

239 , stWord8Store :: [Word8] -- should be

303 , stWord8Store :: [Word8] -- should be

240 -- inifinite,

304 -- inifinite,

@@ -332,33 +396,29 @@ instance PandocMonad PandocPure where

332 modifyPureState $ \st -> st { stUniqStore = us }

396 modifyPureState $ \st -> st { stUniqStore = us }

333 return u

397 return u

334 _ -> M.fail "uniq store ran out of elements"

398 _ -> M.fail "uniq store ran out of elements"

399+ openURL _ = undefined -- TODO

335 readFileLazy fp = do

400 readFileLazy fp = do

336 fps <- getsPureState stFiles

401 fps <- getsPureState stFiles

337 case infoFileContents <$> getFileInfo fp fps of

402 case infoFileContents <$> getFileInfo fp fps of

338 Just bs -> return (BL.fromStrict bs)

403 Just bs -> return (BL.fromStrict bs)

339 Nothing -> throwError $ PandocFileReadError fp

404 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

340 readDataFile Nothing "reference.docx" = do

410 readDataFile Nothing "reference.docx" = do

341 (B.concat . BL.toChunks . fromArchive) <$> getsPureState stReferenceDocx

411 (B.concat . BL.toChunks . fromArchive) <$> getsPureState stReferenceDocx

342 readDataFile Nothing "reference.odt" = do

412 readDataFile Nothing "reference.odt" = do

343 (B.concat . BL.toChunks . fromArchive) <$> getsPureState stReferenceODT

413 (B.concat . BL.toChunks . fromArchive) <$> getsPureState stReferenceODT

344 readDataFile Nothing fname = do

414 readDataFile Nothing fname = do

345 let fname' = if fname == "MANUAL.txt" then fname else "data" </> fname

415 let fname' = if fname == "MANUAL.txt" then fname else "data" </> fname

346− BL.toStrict <$> (readFileLazy fname')

416+ readFileStrict fname'

347 readDataFile (Just userDir) fname = do

417 readDataFile (Just userDir) fname = do

348 userDirFiles <- getsPureState stUserDataDir

418 userDirFiles <- getsPureState stUserDataDir

349 case infoFileContents <$> (getFileInfo (userDir </> fname) userDirFiles) of

419 case infoFileContents <$> (getFileInfo (userDir </> fname) userDirFiles) of

350 Just bs -> return bs

420 Just bs -> return bs

351 Nothing -> readDataFile Nothing fname

421 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))

362

422

363 glob s = do

423 glob s = do

364 fontFiles <- getsPureState stFontFiles

424 fontFiles <- getsPureState stFontFiles

@@ -379,10 +439,10 @@ instance PandocMonad m => PandocMonad (ParserT s st m) where

379 getCurrentTimeZone = lift getCurrentTimeZone

439 getCurrentTimeZone = lift getCurrentTimeZone

380 newStdGen = lift newStdGen

440 newStdGen = lift newStdGen

381 newUniqueHash = lift newUniqueHash

441 newUniqueHash = lift newUniqueHash

442+ openURL = lift . openURL

382 readFileLazy = lift . readFileLazy

443 readFileLazy = lift . readFileLazy

444+ readFileStrict = lift . readFileStrict

383 readDataFile mbuserdir = lift . readDataFile mbuserdir

445 readDataFile mbuserdir = lift . readDataFile mbuserdir

384− fetchItem media = lift . fetchItem media

385− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl

386 glob = lift . glob

446 glob = lift . glob

387 getModificationTime = lift . getModificationTime

447 getModificationTime = lift . getModificationTime

388 getCommonState = lift getCommonState

448 getCommonState = lift getCommonState

@@ -394,10 +454,10 @@ instance PandocMonad m => PandocMonad (ReaderT r m) where

394 getCurrentTimeZone = lift getCurrentTimeZone

454 getCurrentTimeZone = lift getCurrentTimeZone

395 newStdGen = lift newStdGen

455 newStdGen = lift newStdGen

396 newUniqueHash = lift newUniqueHash

456 newUniqueHash = lift newUniqueHash

457+ openURL = lift . openURL

397 readFileLazy = lift . readFileLazy

458 readFileLazy = lift . readFileLazy

459+ readFileStrict = lift . readFileStrict

398 readDataFile mbuserdir = lift . readDataFile mbuserdir

460 readDataFile mbuserdir = lift . readDataFile mbuserdir

399− fetchItem media = lift . fetchItem media

400− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl

401 glob = lift . glob

461 glob = lift . glob

402 getModificationTime = lift . getModificationTime

462 getModificationTime = lift . getModificationTime

403 getCommonState = lift getCommonState

463 getCommonState = lift getCommonState

@@ -409,10 +469,10 @@ instance (PandocMonad m, Monoid w) => PandocMonad (WriterT w m) where

409 getCurrentTimeZone = lift getCurrentTimeZone

469 getCurrentTimeZone = lift getCurrentTimeZone

410 newStdGen = lift newStdGen

470 newStdGen = lift newStdGen

411 newUniqueHash = lift newUniqueHash

471 newUniqueHash = lift newUniqueHash

472+ openURL = lift . openURL

412 readFileLazy = lift . readFileLazy

473 readFileLazy = lift . readFileLazy

474+ readFileStrict = lift . readFileStrict

413 readDataFile mbuserdir = lift . readDataFile mbuserdir

475 readDataFile mbuserdir = lift . readDataFile mbuserdir

414− fetchItem media = lift . fetchItem media

415− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl

416 glob = lift . glob

476 glob = lift . glob

417 getModificationTime = lift . getModificationTime

477 getModificationTime = lift . getModificationTime

418 getCommonState = lift getCommonState

478 getCommonState = lift getCommonState

@@ -424,10 +484,10 @@ instance (PandocMonad m, Monoid w) => PandocMonad (RWST r w st m) where

424 getCurrentTimeZone = lift getCurrentTimeZone

484 getCurrentTimeZone = lift getCurrentTimeZone

425 newStdGen = lift newStdGen

485 newStdGen = lift newStdGen

426 newUniqueHash = lift newUniqueHash

486 newUniqueHash = lift newUniqueHash

487+ openURL = lift . openURL

427 readFileLazy = lift . readFileLazy

488 readFileLazy = lift . readFileLazy

489+ readFileStrict = lift . readFileStrict

428 readDataFile mbuserdir = lift . readDataFile mbuserdir

490 readDataFile mbuserdir = lift . readDataFile mbuserdir

429− fetchItem media = lift . fetchItem media

430− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl

431 glob = lift . glob

491 glob = lift . glob

432 getModificationTime = lift . getModificationTime

492 getModificationTime = lift . getModificationTime

433 getCommonState = lift getCommonState

493 getCommonState = lift getCommonState

@@ -439,10 +499,10 @@ instance PandocMonad m => PandocMonad (StateT st m) where

439 getCurrentTimeZone = lift getCurrentTimeZone

499 getCurrentTimeZone = lift getCurrentTimeZone

440 newStdGen = lift newStdGen

500 newStdGen = lift newStdGen

441 newUniqueHash = lift newUniqueHash

501 newUniqueHash = lift newUniqueHash

502+ openURL = lift . openURL

442 readFileLazy = lift . readFileLazy

503 readFileLazy = lift . readFileLazy

504+ readFileStrict = lift . readFileStrict

443 readDataFile mbuserdir = lift . readDataFile mbuserdir

505 readDataFile mbuserdir = lift . readDataFile mbuserdir

444− fetchItem media = lift . fetchItem media

445− fetchItem' media sourceUrl = lift . fetchItem' media sourceUrl

446 glob = lift . glob

506 glob = lift . glob

447 getModificationTime = lift . getModificationTime

507 getModificationTime = lift . getModificationTime

448 getCommonState = lift getCommonState

508 getCommonState = lift getCommonState