{-# LANGUAGE FlexibleContexts #-}
module Codec.Epub.IO
( getPkgXmlFromZip
, getPkgPathXmlFromZip
, getPkgPathXmlFromBS
, getPkgPathXmlFromDir
, mkEpubArchive
, readArchive
, writeArchive
)
where
import Codec.Archive.Zip
import Control.Arrow.ListArrows ( (>>>), deep )
import Control.Exception
import Control.Monad ( (>=>), forM, liftM )
import Control.Monad.Except
import Control.Monad.IO.Class ( liftIO )
import Control.Monad.Trans ( MonadIO )
import qualified Data.ByteString.Char8 as BS
import Data.ByteString.Lazy ( fromChunks )
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Data.List ( (\\), isPrefixOf )
import System.Directory
import System.FilePath
import Text.XML.HXT.Arrow.ReadDocument ( readString )
import Text.XML.HXT.Arrow.XmlArrow ( getAttrValue, hasName, isElem )
import Text.XML.HXT.Arrow.XmlState ( no, runX, withValidate )
import Codec.Epub.Util
locateRootFile :: (MonadIO m, MonadError String m) =>
FilePath -> String -> m FilePath
locateRootFile :: forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
String -> String -> m String
locateRootFile String
containerPath' String
containerDoc = do
[String]
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall c. IOSArrow XmlTree c -> IO [c]
runX (
forall s b. SysConfigList -> String -> IOStateArrow s b XmlTree
readString [Bool -> SysConfig
withValidate Bool
no] String
containerDoc
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *) (t :: * -> *) b c.
(ArrowTree a, Tree t) =>
a (t b) c -> a (t b) c
deep (forall (a :: * -> * -> *). ArrowXml a => a XmlTree XmlTree
isElem forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *).
ArrowXml a =>
String -> a XmlTree XmlTree
hasName String
"rootfile")
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (a :: * -> * -> *). ArrowXml a => String -> a XmlTree String
getAttrValue String
"full-path"
)
case [String]
result of
(String
p : []) -> forall (m :: * -> *) a. Monad m => a -> m a
return String
p
[String]
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$
String
"ERROR: rootfile full-path missing from " forall a. [a] -> [a] -> [a]
++ String
containerPath'
fileFromArchive :: MonadError String m =>
FilePath -> Archive -> m String
fileFromArchive :: forall (m :: * -> *).
MonadError String m =>
String -> Archive -> m String
fileFromArchive String
filePath Archive
archive = do
let mbEntry :: Maybe Entry
mbEntry = String -> Archive -> Maybe Entry
findEntryByPath String
filePath Archive
archive
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
(forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall a b. (a -> b) -> a -> b
$ String
"Unable to locate file " forall a. [a] -> [a] -> [a]
++ String
filePath)
(forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
UTF8.toString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> ByteString
fromEntry) Maybe Entry
mbEntry
containerPath :: FilePath
containerPath :: String
containerPath = String
"META-INF/container.xml"
getPkgPathXmlFromBS :: (MonadError String m, MonadIO m)
=> BS.ByteString
-> m (FilePath, String)
getPkgPathXmlFromBS :: forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
ByteString -> m (String, String)
getPkgPathXmlFromBS ByteString
strictBytes = do
let lazyBytes :: ByteString
lazyBytes = [ByteString] -> ByteString
fromChunks [ByteString
strictBytes]
Either SomeException Archive
result <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ( forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
evaluate
(ByteString -> Archive
toArchive ByteString
lazyBytes) :: IO (Either SomeException Archive) )
Archive
archive <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall (m :: * -> *) a. Monad m => a -> m a
return Either SomeException Archive
result
String
containerDoc <- forall (m :: * -> *).
MonadError String m =>
String -> Archive -> m String
fileFromArchive String
containerPath Archive
archive
let cleanedContents :: String
cleanedContents = String -> String
removeIllegalStartChars forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
removeEncoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
removeDoctype forall a b. (a -> b) -> a -> b
$ String
containerDoc
String
rootPath <- forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
String -> String -> m String
locateRootFile String
containerPath String
cleanedContents
String
rootContents <- forall (m :: * -> *).
MonadError String m =>
String -> Archive -> m String
fileFromArchive String
rootPath Archive
archive
forall (m :: * -> *) a. Monad m => a -> m a
return (String
rootPath, String
rootContents)
getPkgPathXmlFromZip :: (MonadError String m, MonadIO m)
=> FilePath
-> m (FilePath, String)
getPkgPathXmlFromZip :: forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
String -> m (String, String)
getPkgPathXmlFromZip String
zipPath = do
ByteString
zipFileBytes <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
BS.readFile String
zipPath
forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
ByteString -> m (String, String)
getPkgPathXmlFromBS ByteString
zipFileBytes
getPkgXmlFromZip :: (MonadError String m, MonadIO m)
=> FilePath
-> m String
getPkgXmlFromZip :: forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
String -> m String
getPkgXmlFromZip String
zipPath = forall a b. (a, b) -> b
snd forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
String -> m (String, String)
getPkgPathXmlFromZip String
zipPath
getPkgPathXmlFromDir :: (MonadError String m, MonadIO m)
=> FilePath
-> m (FilePath, String)
getPkgPathXmlFromDir :: forall (m :: * -> *).
(MonadError String m, MonadIO m) =>
String -> m (String, String)
getPkgPathXmlFromDir String
dir = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
setCurrentDirectory String
dir
String
containerDoc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
containerPath
String
rootPath <- forall (m :: * -> *).
(MonadIO m, MonadError String m) =>
String -> String -> m String
locateRootFile (String
dir String -> String -> String
</> String
containerPath) String
containerDoc
String
rootContents <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO String
readFile String
rootPath
forall (m :: * -> *) a. Monad m => a -> m a
return (String
rootPath, String
rootContents)
getRecursiveContents :: FilePath -> IO [FilePath]
getRecursiveContents :: String -> IO [String]
getRecursiveContents String
parent = do
[String]
fullContents <- String -> IO [String]
getDirectoryContents String
parent
let contents :: [String]
contents = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
".") [String]
fullContents
[[String]]
paths <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [String]
contents forall a b. (a -> b) -> a -> b
$ \String
name -> do
let path :: String
path = String
parent String -> String -> String
</> String
name
Bool
isDirectory <- String -> IO Bool
doesDirectoryExist String
path
if Bool
isDirectory
then String -> IO [String]
getRecursiveContents String
path
else forall (m :: * -> *) a. Monad m => a -> m a
return [String
path]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]]
paths
mkEpubArchive :: FilePath -> IO Archive
mkEpubArchive :: String -> IO Archive
mkEpubArchive String
rootDir = do
String -> IO ()
setCurrentDirectory String
rootDir
let mimetype :: [String]
mimetype = [String
"mimetype"]
[String]
allFiles <- String -> IO [String]
getRecursiveContents String
"."
let restFiles :: [String]
restFiles = [String]
allFiles forall a. Eq a => [a] -> [a] -> [a]
\\ [String]
mimetype
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([ZipOption] -> Archive -> [String] -> IO Archive
addFilesToArchive [ZipOption
OptRecursive]) [String]
restFiles forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=>
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([ZipOption] -> Archive -> [String] -> IO Archive
addFilesToArchive []) [String
"mimetype"]
forall a b. (a -> b) -> a -> b
$ Archive
emptyArchive
readArchive :: FilePath -> IO Archive
readArchive :: String -> IO Archive
readArchive = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Archive
toArchive forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ByteString
B.readFile
writeArchive :: FilePath -> Archive -> IO ()
writeArchive :: String -> Archive -> IO ()
writeArchive String
zipPath = (String -> ByteString -> IO ()
B.writeFile String
zipPath) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Archive -> ByteString
fromArchive