module Extra.Files
( getSubDirectories
, renameAlways
, renameMissing
, deleteMaybe
, installFiles
, writeAndZipFileWithBackup
, writeAndZipFile
, backupFile
, writeFileIfMissing
, maybeWriteFile
, createSymbolicLinkIfMissing
, prepareSymbolicLink
, forceRemoveLink
, replaceFile
) where
import qualified Codec.Compression.GZip as GZip
import qualified Codec.Compression.BZip as BZip
import Control.Exception
import Control.Monad
import qualified Data.ByteString.Lazy as B
import Data.List
import Data.Maybe
import Extra.Misc
import System.Unix.Directory
import System.Directory
import System.IO.Error hiding (try, catch)
import System.Posix.Files
getSubDirectories :: FilePath -> IO [String]
getSubDirectories path =
getDirectoryContents path >>=
return . filter (not . (flip elem) [".", ".."]) >>=
filterM isRealDirectory
where
isRealDirectory name = getSymbolicLinkStatus (path ++ "/" ++ name) >>= return . not . isSymbolicLink
installFiles :: [(FilePath, FilePath)] -> IO (Either [String] ())
installFiles pairs =
do backedUp <- mapM (uncurry renameAlways) (zip originalFiles backupFiles)
case lefts backedUp of
[] ->
do renamed <- mapM (uncurry renameAlways) (zip replacementFiles originalFiles)
case lefts renamed of
[] -> return $ Right ()
_ ->
do restored <- mapM (uncurry renameAlways) (zip backupFiles originalFiles)
case lefts restored of
[] -> return . Left . concat . lefts $ renamed
_ -> error ("installFiles: Couldn't restore original files after write failure:" ++
concat (map message (zip3 replacementFiles originalFiles renamed)) ++
concat (map message (zip3 originalFiles backupFiles restored)))
_ ->
do restored <- mapM (uncurry renameMissing) (zip backupFiles originalFiles)
case lefts restored of
[] -> return . Left . concat . lefts $ backedUp
_ -> error ("installFiles: Couldn't restore original files after write failure: " ++
concat (map message (zip3 originalFiles backupFiles backedUp)) ++
concat (map message (zip3 backupFiles originalFiles restored)))
where
replacementFiles = map fst pairs
originalFiles = map snd pairs
backupFiles = map (++ "~") originalFiles
message (path1, path2, Left problems) =
"\n " ++ path1 ++ " -> " ++ path2 ++ ": " ++ concat (intersperse ", " (map show problems))
message (_, _, Right ()) = ""
lefts :: [Either a b] -> [a]
lefts xs = catMaybes $ map (either Just (const Nothing)) xs
renameMissing :: FilePath -> FilePath -> IO (Either [String] ())
renameMissing old new =
do exists <- fileExist new
case exists of
True -> return $ Right ()
False -> renameAlways old new
renameAlways :: FilePath -> FilePath -> IO (Either [String] ())
renameAlways old new =
do deleted <- deleteMaybe new
case deleted of
Right () ->
try (rename old new) >>=
return . either (\ (e :: SomeException) -> Left ["Couldn't rename " ++ old ++ " -> " ++ new ++ ": " ++ show e]) (\ _ -> Right ())
x -> return x
renameMaybe :: FilePath -> FilePath -> IO (Either [String] ())
renameMaybe old new =
do exists <- fileExist old
case exists of
False -> return $ Right ()
True -> renameAlways old new
deleteMaybe :: FilePath -> IO (Either [String] ())
deleteMaybe path =
do exists <- fileExist path
case exists of
False -> return $ Right ()
True ->
do status <- getSymbolicLinkStatus path
let rm = if isDirectory status then removeDirectory else removeLink
try (rm path) >>= return . either (\ (e :: SomeException) -> Left ["Couldn't remove " ++ path ++ ": " ++ show e]) (const . Right $ ())
zipFile :: FilePath -> IO (Either [String] ())
zipFile path =
try (do forceRemoveLink gz
forceRemoveLink bz2
B.readFile path >>= B.writeFile gz . GZip.compress
B.readFile path >>= B.writeFile bz2 . BZip.compress) >>=
return . either (\ (e :: SomeException) -> Left ["Failure writing and zipping " ++ path, show e]) Right
where
gz = path ++ ".gz"
bz2 = path ++ ".bz2"
forceRemoveLink :: FilePath -> IO ()
forceRemoveLink fp = removeLink fp `Control.Exception.catch` (\e -> unless (isDoesNotExistError e) (ioError e))
writeAndZipFileWithBackup :: FilePath -> B.ByteString -> IO (Either [String] ())
writeAndZipFileWithBackup path text =
backupFile path >>=
either (\ e -> return (Left ["Failure renaming " ++ path ++ " -> " ++ path ++ "~: " ++ show e]))
(\ _ -> try (B.writeFile path text) >>=
either (\ (e :: SomeException) ->
restoreBackup path >>=
either (\ e -> error ("Failed to restore backup: " ++ path ++ "~ -> " ++ path ++ ": " ++ show e))
(\ _ -> return (Left ["Failure writing " ++ path ++ ": " ++ show e])))
(\ _ -> zipFile path))
writeAndZipFile :: FilePath -> B.ByteString -> IO (Either [String] ())
writeAndZipFile path text =
deleteMaybe path >>=
either (\ e -> return (Left ["Failure removing " ++ path ++ ": " ++ show e]))
(\ _ -> try (B.writeFile path text) >>=
either (\ (e :: SomeException) -> return (Left ["Failure writing " ++ path ++ ": " ++ show e]))
(\ _ -> zipFile path))
backupFile :: FilePath -> IO (Either [String] ())
backupFile path = renameMaybe path (path ++ "~")
restoreBackup :: FilePath -> IO (Either [String] ())
restoreBackup path = renameMaybe (path ++ "~") path
writeFileIfMissing :: Bool -> FilePath -> String -> IO ()
writeFileIfMissing mkdirs path text =
do
exists <- doesFileExist path
case exists of
False ->
do
if mkdirs then
createDirectoryIfMissing True (parentPath path) else
return ()
replaceFile path text
True ->
return ()
maybeWriteFile :: FilePath -> String -> IO ()
maybeWriteFile path text =
try (readFile path) >>= maybeWrite
where
maybeWrite (Left (e :: IOException)) | isDoesNotExistError e = writeFile path text
maybeWrite (Left e) = error ("maybeWriteFile: " ++ show e)
maybeWrite (Right old) | old == text = return ()
maybeWrite (Right _old) =
replaceFile path text
createSymbolicLinkIfMissing :: String -> FilePath -> IO ()
createSymbolicLinkIfMissing text path =
try (getSymbolicLinkStatus path) >>=
either (\ (_ :: SomeException) -> createSymbolicLink text path) (\ _ -> return ())
prepareSymbolicLink :: FilePath -> FilePath -> IO ()
prepareSymbolicLink name path =
checkExists >>= checkType >>= checkContent
where
checkExists = doesDirectoryExist path >>= orCreate
checkType False = return False
checkType True = getSymbolicLinkStatus path >>= return . isSymbolicLink >>= orReplace
checkContent False = return ()
checkContent True = readSymbolicLink path >>= return . (== name) >>= orReplace >> return ()
orReplace True = return True
orReplace False = do removeRecursiveSafely path; orCreate False
orCreate True = return True
orCreate False = do createSymbolicLink name path; return False
replaceFile :: FilePath -> String -> IO ()
replaceFile path text =
f
where
f :: IO ()
f = removeFile path `Control.Exception.catch` (\ e -> if isDoesNotExistError e then return () else ioError e) >> writeFile path text