module Codec.Archive.FileCollection
(
FileCollection(..),
File(..)
) where
import qualified System.Directory as SD
import Codec.Archive.Zip
import Data.Monoid((<>))
import qualified Data.List as L
import Data.Maybe(mapMaybe,listToMaybe)
import qualified Data.ByteString.Lazy as BS(ByteString,appendFile,readFile,writeFile)
import System.Clock(Clock(Realtime),getTime,sec)
import Prelude hiding (readFile,writeFile)
class File f where
fileName :: f → String
readFile :: f → IO BS.ByteString
writeFile :: f → BS.ByteString → IO f
appendFile :: f → BS.ByteString → IO f
instance File FilePath where
fileName = id
readFile f = BS.readFile f
writeFile f c = BS.writeFile f c >> return f
appendFile f c = BS.appendFile f c >> return f
instance File Entry where
fileName = eRelativePath
readFile = return . fromEntry
writeFile e newContents = do
now <- fromIntegral <$> sec <$> getTime Realtime
return $ toEntry (eRelativePath e) now newContents
appendFile e addContents = do
oldContents <- readFile e
writeFile e $ oldContents <> addContents
class File (AssocFile d) ⇒ FileCollection d where
type AssocFile d :: *
createDirectory :: d → FilePath → IO d
createDirectoryIfMissing :: d → FilePath → IO d
removeDirectory :: d → FilePath → IO d
removeDirectoryRecursive :: d → FilePath → IO d
renameDirectory :: d → FilePath → FilePath → IO d
getDirectoryContents :: d → FilePath → IO [FilePath]
getFile :: d → FilePath → AssocFile d
removeFile :: d → FilePath → IO d
renameFile :: d → FilePath → FilePath → IO d
copyFile :: d → FilePath → FilePath → IO d
addFile :: d → AssocFile d → IO d
findFile :: d → [FilePath] → String → IO (Maybe (AssocFile d))
findFiles :: d → [FilePath] → String → IO [AssocFile d]
doesFileExist :: d → FilePath → IO Bool
doesDirectoryExist :: d → FilePath → IO Bool
combine :: FilePath → FilePath → FilePath
combine root relative = root <> ('/':relative)
combineRunReturn :: (FilePath → IO a) → FilePath → FilePath → IO FilePath
combineRunReturn action root rel = do
let full = combine root rel
_ ← action full
return full
combineRunReturn2 :: (FilePath → FilePath → IO a) → FilePath → FilePath → FilePath → IO FilePath
combineRunReturn2 action root old new = do
let fullOld = combine root old
fullNew = combine root new
_ ← action fullOld fullNew
return fullNew
instance FileCollection [Char] where
type AssocFile [Char] = FilePath
createDirectory = combineRunReturn SD.createDirectory
createDirectoryIfMissing = combineRunReturn (SD.createDirectoryIfMissing True)
removeDirectory = combineRunReturn SD.removeDirectory
removeDirectoryRecursive = combineRunReturn SD.removeDirectoryRecursive
renameDirectory = combineRunReturn2 SD.renameDirectory
getDirectoryContents root rel = SD.getDirectoryContents $ combine root rel
getFile root f = combine root f
removeFile = combineRunReturn SD.removeFile
renameFile = combineRunReturn2 SD.renameFile
copyFile = combineRunReturn2 SD.copyFile
addFile dir = return . const dir
findFile root subs = SD.findFile (map (combine root) subs)
findFiles root subs = SD.findFiles (map (combine root) subs)
doesFileExist root rel = SD.doesFileExist $ combine root rel
doesDirectoryExist root rel = SD.doesDirectoryExist $ combine root rel
subFiles :: Archive → FilePath → [FilePath]
subFiles arch path = filter (L.isPrefixOf path) $ map eRelativePath $ zEntries arch
getDirectoryContents' :: Archive → FilePath → [FilePath]
getDirectoryContents' arch path = map (drop l) $ subFiles arch path
where l = length path
instance FileCollection Archive where
type AssocFile Archive = Entry
createDirectory a = return . const a
createDirectoryIfMissing a = return . const a
removeDirectory a = return . const a
removeDirectoryRecursive arch path = return $ foldr deleteEntryFromArchive arch $ subFiles arch path
renameDirectory arch oldPath newPath =
return $ foldr addEntryToArchive (foldr deleteEntryFromArchive arch oldNames) newEntries
where oldNames = subFiles arch oldPath
oldEntries = mapMaybe (`findEntryByPath` arch) oldNames
newEntries = map rename oldEntries
rename e@Entry{ eRelativePath = rp } =
e { eRelativePath = newPath <> drop l rp }
l = length oldPath
getDirectoryContents arch path = return $ getDirectoryContents' arch path
getFile arch path = case findEntryByPath path arch of
Nothing → error "Called Archive:getFile on a non-existant path"
Just e → e
removeFile arch path = return $ deleteEntryFromArchive path arch
renameFile arch old new
| old == new = return arch
| otherwise = copyFile arch old new >>= flip removeFile old
copyFile arch old new
| old == new = return arch
| otherwise = case newEntry of
(Just e) → return $ addEntryToArchive e arch
Nothing → return arch
where oldEntry = findEntryByPath old arch
newEntry = changeName <$> oldEntry
changeName e = e { eRelativePath = new }
addFile arch entry = return $ addEntryToArchive entry arch
findFile arch subs target = listToMaybe <$> findFiles arch subs target
findFiles arch subs target =
return $ map (getFile arch) $ map (<>target)
$ filter (elem target . getDirectoryContents' arch) subs
doesFileExist arch path= case findEntryByPath path arch of
Just e → if 1 == (length $ subFiles arch $ eRelativePath e)
then return True
else return False
Nothing → return False
doesDirectoryExist arch path= case findEntryByPath path arch of
Just e → if null $ subFiles arch $ eRelativePath e
then return False
else return True
Nothing → return False