{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Text.Pandoc.Readers.EPUB
(readEPUB)
where
import Codec.Archive.Zip (Archive (..), Entry, findEntryByPath, fromEntry,
toArchiveOrFail)
import Control.DeepSeq (NFData, deepseq)
import Control.Monad (guard, liftM, liftM2, mplus)
import Control.Monad.Except (throwError)
import qualified Data.ByteString.Lazy as BL (ByteString)
import Data.List (isInfixOf)
import qualified Data.Text as T
import qualified Data.Map as M (Map, elems, fromList, lookup)
import Data.Maybe (mapMaybe)
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.Encoding as TL
import Network.URI (unEscapeString)
import System.FilePath (dropFileName, dropFileName, normalise, splitFileName,
takeFileName, (</>))
import qualified Text.Pandoc.Builder as B
import Text.Pandoc.Class.PandocMonad (PandocMonad, insertMedia)
import Text.Pandoc.Definition hiding (Attr)
import Text.Pandoc.Error
import Text.Pandoc.Extensions (Extension (Ext_raw_html), enableExtension)
import Text.Pandoc.MIME (MimeType)
import Text.Pandoc.Options (ReaderOptions (..))
import Text.Pandoc.Readers.HTML (readHtml)
import Text.Pandoc.Shared (addMetaField, collapseFilePath, escapeURI)
import qualified Text.Pandoc.UTF8 as UTF8 (toStringLazy)
import Text.Pandoc.Walk (query, walk)
import Text.XML.Light
type Items = M.Map String (FilePath, MimeType)
readEPUB :: PandocMonad m => ReaderOptions -> BL.ByteString -> m Pandoc
readEPUB :: ReaderOptions -> ByteString -> m Pandoc
readEPUB ReaderOptions
opts ByteString
bytes = case ByteString -> Either String Archive
toArchiveOrFail ByteString
bytes of
Right Archive
archive -> ReaderOptions -> Archive -> m Pandoc
forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Archive -> m Pandoc
archiveToEPUB ReaderOptions
opts Archive
archive
Left String
_ -> PandocError -> m Pandoc
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m Pandoc) -> PandocError -> m Pandoc
forall a b. (a -> b) -> a -> b
$ Text -> PandocError
PandocParseError Text
"Couldn't extract ePub file"
archiveToEPUB :: (PandocMonad m) => ReaderOptions -> Archive -> m Pandoc
archiveToEPUB :: ReaderOptions -> Archive -> m Pandoc
archiveToEPUB ReaderOptions
os Archive
archive = do
(String
root, Element
content) <- Archive -> m (String, Element)
forall (m :: * -> *).
PandocMonad m =>
Archive -> m (String, Element)
getManifest Archive
archive
(Maybe String
coverId, Meta
meta) <- Element -> m (Maybe String, Meta)
forall (m :: * -> *).
PandocMonad m =>
Element -> m (Maybe String, Meta)
parseMeta Element
content
(Maybe String
cover, Items
items) <- Element -> Maybe String -> m (Maybe String, Items)
forall (m :: * -> *).
PandocMonad m =>
Element -> Maybe String -> m (Maybe String, Items)
parseManifest Element
content Maybe String
coverId
let coverDoc :: Pandoc
coverDoc = Pandoc -> (String -> Pandoc) -> Maybe String -> Pandoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pandoc
forall a. Monoid a => a
mempty String -> Pandoc
imageToPandoc Maybe String
cover
[(String, Text)]
spine <- Items -> Element -> m [(String, Text)]
forall (m :: * -> *).
PandocMonad m =>
Items -> Element -> m [(String, Text)]
parseSpine Items
items Element
content
let escapedSpine :: [Text]
escapedSpine = ((String, Text) -> Text) -> [(String, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text
escapeURI (Text -> Text)
-> ((String, Text) -> Text) -> (String, Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> ((String, Text) -> String) -> (String, Text) -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
takeFileName (String -> String)
-> ((String, Text) -> String) -> (String, Text) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Text) -> String
forall a b. (a, b) -> a
fst) [(String, Text)]
spine
Pandoc Meta
_ [Block]
bs <-
(Pandoc -> (String, Text) -> m Pandoc)
-> Pandoc -> [(String, Text)] -> m Pandoc
forall (m :: * -> *) a b.
(Monad m, NFData a) =>
(a -> b -> m a) -> a -> [b] -> m a
foldM' (\Pandoc
a (String, Text)
b -> ((Pandoc
a Pandoc -> Pandoc -> Pandoc
forall a. Semigroup a => a -> a -> a
<>) (Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk ([Text] -> Inline -> Inline
prependHash [Text]
escapedSpine))
(Pandoc -> Pandoc) -> m Pandoc -> m Pandoc
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` String -> (String, Text) -> m Pandoc
forall (m :: * -> *).
PandocMonad m =>
String -> (String, Text) -> m Pandoc
parseSpineElem String
root (String, Text)
b) Pandoc
forall a. Monoid a => a
mempty [(String, Text)]
spine
let ast :: Pandoc
ast = Pandoc
coverDoc Pandoc -> Pandoc -> Pandoc
forall a. Semigroup a => a -> a -> a
<> Meta -> [Block] -> Pandoc
Pandoc Meta
meta [Block]
bs
[(String, Text)] -> String -> Archive -> Pandoc -> m ()
forall (m :: * -> *).
PandocMonad m =>
[(String, Text)] -> String -> Archive -> Pandoc -> m ()
fetchImages (Items -> [(String, Text)]
forall k a. Map k a -> [a]
M.elems Items
items) String
root Archive
archive Pandoc
ast
Pandoc -> m Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
ast
where
os' :: ReaderOptions
os' = ReaderOptions
os {readerExtensions :: Extensions
readerExtensions = Extension -> Extensions -> Extensions
enableExtension Extension
Ext_raw_html (ReaderOptions -> Extensions
readerExtensions ReaderOptions
os)}
parseSpineElem :: PandocMonad m => FilePath -> (FilePath, MimeType) -> m Pandoc
parseSpineElem :: String -> (String, Text) -> m Pandoc
parseSpineElem (String -> String
normalise -> String
r) (String -> String
normalise -> String
path, Text
mime) = do
Pandoc
doc <- Text -> String -> String -> m Pandoc
forall (m :: * -> *).
PandocMonad m =>
Text -> String -> String -> m Pandoc
mimeToReader Text
mime String
r String
path
let docSpan :: Pandoc
docSpan = Blocks -> Pandoc
B.doc (Blocks -> Pandoc) -> Blocks -> Pandoc
forall a b. (a -> b) -> a -> b
$ Inlines -> Blocks
B.para (Inlines -> Blocks) -> Inlines -> Blocks
forall a b. (a -> b) -> a -> b
$ Attr -> Inlines -> Inlines
B.spanWith (String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
takeFileName String
path, [], []) Inlines
forall a. Monoid a => a
mempty
Pandoc -> m Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> m Pandoc) -> Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ Pandoc
docSpan Pandoc -> Pandoc -> Pandoc
forall a. Semigroup a => a -> a -> a
<> Pandoc
doc
mimeToReader :: PandocMonad m => MimeType -> FilePath -> FilePath -> m Pandoc
mimeToReader :: Text -> String -> String -> m Pandoc
mimeToReader Text
"application/xhtml+xml" (String -> String
unEscapeString -> String
root)
(String -> String
unEscapeString -> String
path) = do
Entry
fname <- String -> Archive -> m Entry
forall (m :: * -> *). PandocMonad m => String -> Archive -> m Entry
findEntryByPathE (String
root String -> String -> String
</> String
path) Archive
archive
Pandoc
html <- ReaderOptions -> Text -> m Pandoc
forall (m :: * -> *).
PandocMonad m =>
ReaderOptions -> Text -> m Pandoc
readHtml ReaderOptions
os' (Text -> m Pandoc)
-> (ByteString -> Text) -> ByteString -> m Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.toStrict (Text -> Text) -> (ByteString -> Text) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8 (ByteString -> m Pandoc) -> ByteString -> m Pandoc
forall a b. (a -> b) -> a -> b
$ Entry -> ByteString
fromEntry Entry
fname
Pandoc -> m Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> m Pandoc) -> Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ String -> Pandoc -> Pandoc
fixInternalReferences String
path Pandoc
html
mimeToReader Text
s String
_ (String -> String
unEscapeString -> String
path)
| Text
s Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
imageMimes = Pandoc -> m Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return (Pandoc -> m Pandoc) -> Pandoc -> m Pandoc
forall a b. (a -> b) -> a -> b
$ String -> Pandoc
imageToPandoc String
path
| Bool
otherwise = Pandoc -> m Pandoc
forall (m :: * -> *) a. Monad m => a -> m a
return Pandoc
forall a. Monoid a => a
mempty
fetchImages :: PandocMonad m
=> [(FilePath, MimeType)]
-> FilePath
-> Archive
-> Pandoc
-> m ()
fetchImages :: [(String, Text)] -> String -> Archive -> Pandoc -> m ()
fetchImages [(String, Text)]
mimes String
root Archive
arc ((Inline -> [String]) -> Pandoc -> [String]
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query Inline -> [String]
iq -> [String]
links) =
((String, Maybe Text, ByteString) -> m ())
-> [(String, Maybe Text, ByteString)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((String -> Maybe Text -> ByteString -> m ())
-> (String, Maybe Text, ByteString) -> m ()
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 String -> Maybe Text -> ByteString -> m ()
forall (m :: * -> *).
PandocMonad m =>
String -> Maybe Text -> ByteString -> m ()
insertMedia) ((String -> Maybe (String, Maybe Text, ByteString))
-> [String] -> [(String, Maybe Text, ByteString)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe (String, Maybe Text, ByteString)
getEntry [String]
links)
where
getEntry :: String -> Maybe (String, Maybe Text, ByteString)
getEntry String
link =
let abslink :: String
abslink = String -> String
normalise (String -> String
unEscapeString (String
root String -> String -> String
</> String
link)) in
(String
link , String -> [(String, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
link [(String, Text)]
mimes, ) (ByteString -> (String, Maybe Text, ByteString))
-> (Entry -> ByteString)
-> Entry
-> (String, Maybe Text, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> ByteString
fromEntry
(Entry -> (String, Maybe Text, ByteString))
-> Maybe Entry -> Maybe (String, Maybe Text, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> Archive -> Maybe Entry
findEntryByPath String
abslink Archive
arc
iq :: Inline -> [FilePath]
iq :: Inline -> [String]
iq (Image Attr
_ [Inline]
_ (Text
url, Text
_)) = [Text -> String
T.unpack Text
url]
iq Inline
_ = []
renameImages :: FilePath -> Inline -> Inline
renameImages :: String -> Inline -> Inline
renameImages String
root img :: Inline
img@(Image Attr
attr [Inline]
a (Text
url, Text
b))
| Text
"data:" Text -> Text -> Bool
`T.isPrefixOf` Text
url = Inline
img
| Bool
otherwise = Attr -> [Inline] -> (Text, Text) -> Inline
Image Attr
attr [Inline]
a ( String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ String -> String
collapseFilePath (String
root String -> String -> String
</> Text -> String
T.unpack Text
url)
, Text
b)
renameImages String
_ Inline
x = Inline
x
imageToPandoc :: FilePath -> Pandoc
imageToPandoc :: String -> Pandoc
imageToPandoc String
s = Blocks -> Pandoc
B.doc (Blocks -> Pandoc) -> (Inlines -> Blocks) -> Inlines -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Inlines -> Blocks
B.para (Inlines -> Pandoc) -> Inlines -> Pandoc
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Inlines -> Inlines
B.image (String -> Text
T.pack String
s) Text
"" Inlines
forall a. Monoid a => a
mempty
imageMimes :: [MimeType]
imageMimes :: [Text]
imageMimes = [Text
"image/gif", Text
"image/jpeg", Text
"image/png"]
type CoverId = String
type CoverImage = FilePath
parseManifest :: (PandocMonad m) => Element -> Maybe CoverId -> m (Maybe CoverImage, Items)
parseManifest :: Element -> Maybe String -> m (Maybe String, Items)
parseManifest Element
content Maybe String
coverId = do
Element
manifest <- QName -> Element -> m Element
forall (m :: * -> *).
PandocMonad m =>
QName -> Element -> m Element
findElementE (String -> QName
dfName String
"manifest") Element
content
let items :: [Element]
items = QName -> Element -> [Element]
findChildren (String -> QName
dfName String
"item") Element
manifest
[(String, (String, Text))]
r <- (Element -> m (String, (String, Text)))
-> [Element] -> m [(String, (String, Text))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Element -> m (String, (String, Text))
forall (m :: * -> *).
PandocMonad m =>
Element -> m (String, (String, Text))
parseItem [Element]
items
let cover :: Maybe String
cover = QName -> Element -> Maybe String
findAttr (String -> QName
emptyName String
"href") (Element -> Maybe String) -> Maybe Element -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Element -> Bool) -> Element -> Maybe Element
filterChild Element -> Bool
findCover Element
manifest
(Maybe String, Items) -> m (Maybe String, Items)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
cover Maybe String -> Maybe String -> Maybe String
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` Maybe String
coverId, [(String, (String, Text))] -> Items
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, (String, Text))]
r)
where
findCover :: Element -> Bool
findCover Element
e = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
"cover-image")
(QName -> Element -> Maybe String
findAttr (String -> QName
emptyName String
"properties") Element
e)
Bool -> Bool -> Bool
|| Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (String -> String -> Bool)
-> Maybe String -> Maybe String -> Maybe Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
(==) Maybe String
coverId (QName -> Element -> Maybe String
findAttr (String -> QName
emptyName String
"id") Element
e)
parseItem :: Element -> m (String, (String, Text))
parseItem Element
e = do
String
uid <- QName -> Element -> m String
forall (m :: * -> *). PandocMonad m => QName -> Element -> m String
findAttrE (String -> QName
emptyName String
"id") Element
e
String
href <- QName -> Element -> m String
forall (m :: * -> *). PandocMonad m => QName -> Element -> m String
findAttrE (String -> QName
emptyName String
"href") Element
e
String
mime <- QName -> Element -> m String
forall (m :: * -> *). PandocMonad m => QName -> Element -> m String
findAttrE (String -> QName
emptyName String
"media-type") Element
e
(String, (String, Text)) -> m (String, (String, Text))
forall (m :: * -> *) a. Monad m => a -> m a
return (String
uid, (String
href, String -> Text
T.pack String
mime))
parseSpine :: PandocMonad m => Items -> Element -> m [(FilePath, MimeType)]
parseSpine :: Items -> Element -> m [(String, Text)]
parseSpine Items
is Element
e = do
Element
spine <- QName -> Element -> m Element
forall (m :: * -> *).
PandocMonad m =>
QName -> Element -> m Element
findElementE (String -> QName
dfName String
"spine") Element
e
let itemRefs :: [Element]
itemRefs = QName -> Element -> [Element]
findChildren (String -> QName
dfName String
"itemref") Element
spine
(String -> m (String, Text)) -> [String] -> m [(String, Text)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Maybe (String, Text) -> m (String, Text)
forall (m :: * -> *) a. PandocMonad m => String -> Maybe a -> m a
mkE String
"parseSpine" (Maybe (String, Text) -> m (String, Text))
-> (String -> Maybe (String, Text)) -> String -> m (String, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Items -> Maybe (String, Text))
-> Items -> String -> Maybe (String, Text)
forall a b c. (a -> b -> c) -> b -> a -> c
flip String -> Items -> Maybe (String, Text)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Items
is) ([String] -> m [(String, Text)]) -> [String] -> m [(String, Text)]
forall a b. (a -> b) -> a -> b
$ (Element -> Maybe String) -> [Element] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe String
parseItemRef [Element]
itemRefs
where
parseItemRef :: Element -> Maybe String
parseItemRef Element
ref = do
let linear :: Bool
linear = Bool -> (String -> Bool) -> Maybe String -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"yes") (QName -> Element -> Maybe String
findAttr (String -> QName
emptyName String
"linear") Element
ref)
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard Bool
linear
QName -> Element -> Maybe String
findAttr (String -> QName
emptyName String
"idref") Element
ref
parseMeta :: PandocMonad m => Element -> m (Maybe CoverId, Meta)
parseMeta :: Element -> m (Maybe String, Meta)
parseMeta Element
content = do
Element
meta <- QName -> Element -> m Element
forall (m :: * -> *).
PandocMonad m =>
QName -> Element -> m Element
findElementE (String -> QName
dfName String
"metadata") Element
content
let dcspace :: QName -> Bool
dcspace (QName String
_ (Just String
"http://purl.org/dc/elements/1.1/") (Just String
"dc")) = Bool
True
dcspace QName
_ = Bool
False
let dcs :: [Element]
dcs = (QName -> Bool) -> Element -> [Element]
filterChildrenName QName -> Bool
dcspace Element
meta
let r :: Meta
r = (Element -> Meta -> Meta) -> Meta -> [Element] -> Meta
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Element -> Meta -> Meta
parseMetaItem Meta
nullMeta [Element]
dcs
let coverId :: Maybe String
coverId = QName -> Element -> Maybe String
findAttr (String -> QName
emptyName String
"content") (Element -> Maybe String) -> Maybe Element -> Maybe String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Element -> Bool) -> Element -> Maybe Element
filterChild Element -> Bool
findCover Element
meta
(Maybe String, Meta) -> m (Maybe String, Meta)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe String
coverId, Meta
r)
where
findCover :: Element -> Bool
findCover Element
e = QName -> Element -> Maybe String
findAttr (String -> QName
emptyName String
"name") Element
e Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Maybe String
forall a. a -> Maybe a
Just String
"cover"
parseMetaItem :: Element -> Meta -> Meta
parseMetaItem :: Element -> Meta -> Meta
parseMetaItem e :: Element
e@(QName -> String
stripNamespace (QName -> String) -> (Element -> QName) -> Element -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> QName
elName -> String
field) Meta
meta =
Text -> Inlines -> Meta -> Meta
forall a. ToMetaValue a => Text -> a -> Meta -> Meta
addMetaField (String -> Text
renameMeta String
field) (Text -> Inlines
B.str (Text -> Inlines) -> Text -> Inlines
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Element -> String
strContent Element
e) Meta
meta
renameMeta :: String -> T.Text
renameMeta :: String -> Text
renameMeta String
"creator" = Text
"author"
renameMeta String
s = String -> Text
T.pack String
s
getManifest :: PandocMonad m => Archive -> m (String, Element)
getManifest :: Archive -> m (String, Element)
getManifest Archive
archive = do
Entry
metaEntry <- String -> Archive -> m Entry
forall (m :: * -> *). PandocMonad m => String -> Archive -> m Entry
findEntryByPathE (String
"META-INF" String -> String -> String
</> String
"container.xml") Archive
archive
Element
docElem <- (String -> m Element
forall (m :: * -> *). PandocMonad m => String -> m Element
parseXMLDocE (String -> m Element) -> (Entry -> String) -> Entry -> m Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
UTF8.toStringLazy (ByteString -> String) -> (Entry -> ByteString) -> Entry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> ByteString
fromEntry) Entry
metaEntry
let namespaces :: [(String, String)]
namespaces = (Attr -> Maybe (String, String)) -> [Attr] -> [(String, String)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Attr -> Maybe (String, String)
attrToNSPair (Element -> [Attr]
elAttribs Element
docElem)
String
ns <- String -> Maybe String -> m String
forall (m :: * -> *) a. PandocMonad m => String -> Maybe a -> m a
mkE String
"xmlns not in namespaces" (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"xmlns" [(String, String)]
namespaces)
[(String, String)]
as <- (Element -> [(String, String)])
-> m Element -> m [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Attr -> (String, String)) -> [Attr] -> [(String, String)]
forall a b. (a -> b) -> [a] -> [b]
map Attr -> (String, String)
attrToPair ([Attr] -> [(String, String)])
-> (Element -> [Attr]) -> Element -> [(String, String)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Attr]
elAttribs)
(QName -> Element -> m Element
forall (m :: * -> *).
PandocMonad m =>
QName -> Element -> m Element
findElementE (String -> Maybe String -> Maybe String -> QName
QName String
"rootfile" (String -> Maybe String
forall a. a -> Maybe a
Just String
ns) Maybe String
forall a. Maybe a
Nothing) Element
docElem)
String
manifestFile <- String -> Maybe String -> m String
forall (m :: * -> *) a. PandocMonad m => String -> Maybe a -> m a
mkE String
"Root not found" (String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"full-path" [(String, String)]
as)
let rootdir :: String
rootdir = String -> String
dropFileName String
manifestFile
Entry
manifest <- String -> Archive -> m Entry
forall (m :: * -> *). PandocMonad m => String -> Archive -> m Entry
findEntryByPathE String
manifestFile Archive
archive
(String
rootdir,) (Element -> (String, Element)) -> m Element -> m (String, Element)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> m Element
forall (m :: * -> *). PandocMonad m => String -> m Element
parseXMLDocE (String -> m Element) -> (Entry -> String) -> Entry -> m Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
UTF8.toStringLazy (ByteString -> String) -> (Entry -> ByteString) -> Entry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> ByteString
fromEntry (Entry -> m Element) -> Entry -> m Element
forall a b. (a -> b) -> a -> b
$ Entry
manifest)
fixInternalReferences :: FilePath -> Pandoc -> Pandoc
fixInternalReferences :: String -> Pandoc -> Pandoc
fixInternalReferences String
pathToFile =
(Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk (String -> Inline -> Inline
renameImages String
root)
(Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> Block) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk (String -> Block -> Block
fixBlockIRs String
filename)
(Pandoc -> Pandoc) -> (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk (String -> Inline -> Inline
fixInlineIRs String
filename)
where
(String
root, Text -> String
T.unpack (Text -> String) -> (String -> Text) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
escapeURI (Text -> Text) -> (String -> Text) -> String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack -> String
filename) = String -> (String, String)
splitFileName String
pathToFile
fixInlineIRs :: String -> Inline -> Inline
fixInlineIRs :: String -> Inline -> Inline
fixInlineIRs String
s (Span Attr
as [Inline]
v) =
Attr -> [Inline] -> Inline
Span (String -> Attr -> Attr
fixAttrs String
s Attr
as) [Inline]
v
fixInlineIRs String
s (Code Attr
as Text
code) =
Attr -> Text -> Inline
Code (String -> Attr -> Attr
fixAttrs String
s Attr
as) Text
code
fixInlineIRs String
s (Link Attr
as [Inline]
is (Text -> Maybe (Char, Text)
T.uncons -> Just (Char
'#', Text
url), Text
tit)) =
Attr -> [Inline] -> (Text, Text) -> Inline
Link (String -> Attr -> Attr
fixAttrs String
s Attr
as) [Inline]
is (String -> Text -> Text
addHash String
s Text
url, Text
tit)
fixInlineIRs String
s (Link Attr
as [Inline]
is (Text, Text)
t) =
Attr -> [Inline] -> (Text, Text) -> Inline
Link (String -> Attr -> Attr
fixAttrs String
s Attr
as) [Inline]
is (Text, Text)
t
fixInlineIRs String
_ Inline
v = Inline
v
prependHash :: [T.Text] -> Inline -> Inline
prependHash :: [Text] -> Inline -> Inline
prependHash [Text]
ps l :: Inline
l@(Link Attr
attr [Inline]
is (Text
url, Text
tit))
| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Text
s Text -> Text -> Bool
`T.isPrefixOf` Text
url | Text
s <- [Text]
ps] =
Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attr [Inline]
is (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
url, Text
tit)
| Bool
otherwise = Inline
l
prependHash [Text]
_ Inline
i = Inline
i
fixBlockIRs :: String -> Block -> Block
fixBlockIRs :: String -> Block -> Block
fixBlockIRs String
s (Div Attr
as [Block]
b) =
Attr -> [Block] -> Block
Div (String -> Attr -> Attr
fixAttrs String
s Attr
as) [Block]
b
fixBlockIRs String
s (Header Int
i Attr
as [Inline]
b) =
Int -> Attr -> [Inline] -> Block
Header Int
i (String -> Attr -> Attr
fixAttrs String
s Attr
as) [Inline]
b
fixBlockIRs String
s (CodeBlock Attr
as Text
code) =
Attr -> Text -> Block
CodeBlock (String -> Attr -> Attr
fixAttrs String
s Attr
as) Text
code
fixBlockIRs String
_ Block
b = Block
b
fixAttrs :: FilePath -> B.Attr -> B.Attr
fixAttrs :: String -> Attr -> Attr
fixAttrs String
s (Text
ident, [Text]
cs, [(Text, Text)]
kvs) = (String -> Text -> Text
addHash String
s Text
ident, (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Bool
T.null) [Text]
cs, [(Text, Text)] -> [(Text, Text)]
removeEPUBAttrs [(Text, Text)]
kvs)
addHash :: String -> T.Text -> T.Text
addHash :: String -> Text -> Text
addHash String
_ Text
"" = Text
""
addHash String
s Text
ident = String -> Text
T.pack (String -> String
takeFileName String
s) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident
removeEPUBAttrs :: [(T.Text, T.Text)] -> [(T.Text, T.Text)]
removeEPUBAttrs :: [(Text, Text)] -> [(Text, Text)]
removeEPUBAttrs [(Text, Text)]
kvs = ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ((Text, Text) -> Bool) -> (Text, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Bool
forall a. (Text, a) -> Bool
isEPUBAttr) [(Text, Text)]
kvs
isEPUBAttr :: (T.Text, a) -> Bool
isEPUBAttr :: (Text, a) -> Bool
isEPUBAttr (Text
k, a
_) = Text
"epub:" Text -> Text -> Bool
`T.isPrefixOf` Text
k
foldM' :: (Monad m, NFData a) => (a -> b -> m a) -> a -> [b] -> m a
foldM' :: (a -> b -> m a) -> a -> [b] -> m a
foldM' a -> b -> m a
_ a
z [] = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
z
foldM' a -> b -> m a
f a
z (b
x:[b]
xs) = do
a
z' <- a -> b -> m a
f a
z b
x
a
z' a -> m a -> m a
forall a b. NFData a => a -> b -> b
`deepseq` (a -> b -> m a) -> a -> [b] -> m a
forall (m :: * -> *) a b.
(Monad m, NFData a) =>
(a -> b -> m a) -> a -> [b] -> m a
foldM' a -> b -> m a
f a
z' [b]
xs
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 a -> b -> c -> d
f (a
a, b
b, c
c) = a -> b -> c -> d
f a
a b
b c
c
stripNamespace :: QName -> String
stripNamespace :: QName -> String
stripNamespace (QName String
v Maybe String
_ Maybe String
_) = String
v
attrToNSPair :: Attr -> Maybe (String, String)
attrToNSPair :: Attr -> Maybe (String, String)
attrToNSPair (Attr (QName String
"xmlns" Maybe String
_ Maybe String
_) String
val) = (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
"xmlns", String
val)
attrToNSPair Attr
_ = Maybe (String, String)
forall a. Maybe a
Nothing
attrToPair :: Attr -> (String, String)
attrToPair :: Attr -> (String, String)
attrToPair (Attr (QName String
name Maybe String
_ Maybe String
_) String
val) = (String
name, String
val)
defaultNameSpace :: Maybe String
defaultNameSpace :: Maybe String
defaultNameSpace = String -> Maybe String
forall a. a -> Maybe a
Just String
"http://www.idpf.org/2007/opf"
dfName :: String -> QName
dfName :: String -> QName
dfName String
s = String -> Maybe String -> Maybe String -> QName
QName String
s Maybe String
defaultNameSpace Maybe String
forall a. Maybe a
Nothing
emptyName :: String -> QName
emptyName :: String -> QName
emptyName String
s = String -> Maybe String -> Maybe String -> QName
QName String
s Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
findAttrE :: PandocMonad m => QName -> Element -> m String
findAttrE :: QName -> Element -> m String
findAttrE QName
q Element
e = String -> Maybe String -> m String
forall (m :: * -> *) a. PandocMonad m => String -> Maybe a -> m a
mkE String
"findAttr" (Maybe String -> m String) -> Maybe String -> m String
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe String
findAttr QName
q Element
e
findEntryByPathE :: PandocMonad m => FilePath -> Archive -> m Entry
findEntryByPathE :: String -> Archive -> m Entry
findEntryByPathE (String -> String
normalise (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
unEscapeString -> String
path) Archive
a =
String -> Maybe Entry -> m Entry
forall (m :: * -> *) a. PandocMonad m => String -> Maybe a -> m a
mkE (String
"No entry on path: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
path) (Maybe Entry -> m Entry) -> Maybe Entry -> m Entry
forall a b. (a -> b) -> a -> b
$ String -> Archive -> Maybe Entry
findEntryByPath String
path Archive
a
parseXMLDocE :: PandocMonad m => String -> m Element
parseXMLDocE :: String -> m Element
parseXMLDocE String
doc = String -> Maybe Element -> m Element
forall (m :: * -> *) a. PandocMonad m => String -> Maybe a -> m a
mkE String
"Unable to parse XML doc" (Maybe Element -> m Element) -> Maybe Element -> m Element
forall a b. (a -> b) -> a -> b
$ String -> Maybe Element
forall s. XmlSource s => s -> Maybe Element
parseXMLDoc String
doc
findElementE :: PandocMonad m => QName -> Element -> m Element
findElementE :: QName -> Element -> m Element
findElementE QName
e Element
x = String -> Maybe Element -> m Element
forall (m :: * -> *) a. PandocMonad m => String -> Maybe a -> m a
mkE (String
"Unable to find element: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ QName -> String
forall a. Show a => a -> String
show QName
e) (Maybe Element -> m Element) -> Maybe Element -> m Element
forall a b. (a -> b) -> a -> b
$ QName -> Element -> Maybe Element
findElement QName
e Element
x
mkE :: PandocMonad m => String -> Maybe a -> m a
mkE :: String -> Maybe a -> m a
mkE String
s = m a -> (a -> m a) -> Maybe a -> m a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (PandocError -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (PandocError -> m a) -> (Text -> PandocError) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> PandocError
PandocParseError (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
s) a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return