{-# LANGUAGE DeriveDataTypeable #-}
module Path.IO
(getWorkingDir
,parseRelAsAbsDir
,parseRelAsAbsFile
,listDirectory
,resolveDir
,resolveFile
,resolveDirMaybe
,resolveFileMaybe
,ResolveException(..)
,removeFile
,removeFileIfExists
,removeTree
,removeTreeIfExists
,renameFile
,renameFileIfExists
,renameDir
,renameDirIfExists
,moveFile
,moveFileIfExists
,moveDir
,moveDirIfExists
,fileExists
,dirExists
,copyFile
,copyFileIfExists
,copyDirectoryRecursive
,createTree
,withCanonicalizedSystemTempDirectory
,withCanonicalizedTempDirectory)
where
import Control.Exception hiding (catch)
import Control.Monad
import Control.Monad.Catch
import Control.Monad.IO.Class
import Data.Either
import Data.Maybe.Extra
import Data.Typeable
import Path
import qualified System.Directory as D
import qualified System.FilePath as FP
import System.IO.Error
import System.IO.Temp
data ResolveException
= ResolveDirFailed (Path Abs Dir) FilePath FilePath
| ResolveFileFailed (Path Abs Dir) FilePath FilePath
deriving Typeable
instance Exception ResolveException
instance Show ResolveException where
show (ResolveDirFailed _ _ z) = "Could not resolve directory " ++ z
show (ResolveFileFailed _ _ z) = "Could not resolve file " ++ z
getWorkingDir :: (MonadIO m) => m (Path Abs Dir)
getWorkingDir = liftIO (D.canonicalizePath "." >>= parseAbsDir)
parseRelAsAbsDir :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs Dir)
parseRelAsAbsDir fp = parseAbsDir =<< liftIO (D.canonicalizePath fp)
parseRelAsAbsFile :: (MonadThrow m, MonadIO m) => FilePath -> m (Path Abs File)
parseRelAsAbsFile fp = parseAbsFile =<< liftIO (D.canonicalizePath fp)
resolveDir :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs Dir)
resolveDir x y =
do result <- resolveDirMaybe x y
case result of
Nothing ->
throwM $ ResolveDirFailed x y fp
where fp = toFilePath x FP.</> y
Just fp -> return fp
resolveFile :: (MonadIO m, MonadThrow m) => Path Abs Dir -> FilePath -> m (Path Abs File)
resolveFile x y =
do result <- resolveFileMaybe x y
case result of
Nothing ->
throwM $
ResolveFileFailed x y fp
where fp = toFilePath x FP.</> y
Just fp -> return fp
resolveCheckParse :: (MonadIO m)
=> (FilePath -> IO Bool)
-> (FilePath -> m a)
-> Path Abs Dir
-> FilePath
-> m (Maybe a)
resolveCheckParse check parse x y = do
let fp = toFilePath x FP.</> y
exists <- liftIO $ check fp
if exists
then do
canonic <- liftIO $ D.canonicalizePath fp
liftM Just (parse canonic)
else return Nothing
resolveDirMaybe :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -> FilePath -> m (Maybe (Path Abs Dir))
resolveDirMaybe = resolveCheckParse D.doesDirectoryExist parseAbsDir
resolveFileMaybe :: (MonadIO m,MonadThrow m)
=> Path Abs Dir -> FilePath -> m (Maybe (Path Abs File))
resolveFileMaybe = resolveCheckParse D.doesFileExist parseAbsFile
listDirectory :: (MonadIO m,MonadThrow m) => Path Abs Dir -> m ([Path Abs Dir],[Path Abs File])
listDirectory dir =
do entriesFP <- liftIO (D.getDirectoryContents dirFP)
entries <-
forMaybeM (map (dirFP ++) entriesFP)
(\entryFP ->
do isDir <- liftIO (D.doesDirectoryExist entryFP)
if isDir
then case parseAbsDir entryFP of
Nothing -> return Nothing
Just entryDir ->
if dir `isParentOf` entryDir
then return (Just (Left entryDir))
else return Nothing
else case parseAbsFile entryFP of
Nothing -> return Nothing
Just entryFile -> return (Just (Right entryFile)))
return (lefts entries,rights entries)
where dirFP = toFilePath dir
removeFile :: MonadIO m => Path b File -> m ()
removeFile = liftIO . D.removeFile . toFilePath
removeFileIfExists :: MonadIO m => Path b File -> m ()
removeFileIfExists = ignoreDoesNotExist . removeFile
renameFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()
renameFile from to = liftIO (D.renameFile (toFilePath from) (toFilePath to))
renameFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()
renameFileIfExists from to = ignoreDoesNotExist (renameFile from to)
renameDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
renameDir from to = liftIO (D.renameDirectory (toFilePath from) (toFilePath to))
renameDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
renameDirIfExists from to = ignoreDoesNotExist (renameDir from to)
createTree :: MonadIO m => Path b Dir -> m ()
createTree = liftIO . D.createDirectoryIfMissing True . toFilePath
moveFile :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()
moveFile from to = renameFile from (to </> filename from)
moveFileIfExists :: MonadIO m => Path b1 File -> Path b2 Dir -> m ()
moveFileIfExists from to = ignoreDoesNotExist (moveFile from to)
moveDir :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
moveDir from to = renameDir from (to </> dirname from)
moveDirIfExists :: MonadIO m => Path b1 Dir -> Path b2 Dir -> m ()
moveDirIfExists from to = ignoreDoesNotExist (moveDir from to)
removeTree :: MonadIO m => Path b Dir -> m ()
removeTree = liftIO . D.removeDirectoryRecursive . toFilePath
removeTreeIfExists :: MonadIO m => Path b Dir -> m ()
removeTreeIfExists = ignoreDoesNotExist . removeTree
fileExists :: MonadIO m => Path b File -> m Bool
fileExists = liftIO . D.doesFileExist . toFilePath
dirExists :: MonadIO m => Path b Dir -> m Bool
dirExists = liftIO . D.doesDirectoryExist . toFilePath
copyFile :: MonadIO m => Path b1 File -> Path b2 File -> m ()
copyFile from to = liftIO (D.copyFile (toFilePath from) (toFilePath to))
copyFileIfExists :: MonadIO m => Path b1 File -> Path b2 File -> m ()
copyFileIfExists from to = ignoreDoesNotExist (copyFile from to)
copyDirectoryRecursive :: (MonadIO m,MonadThrow m)
=> Path Abs Dir
-> Path Abs Dir
-> m ()
copyDirectoryRecursive srcDir destDir =
do liftIO (D.createDirectoryIfMissing False (toFilePath destDir))
(srcSubDirs,srcFiles) <- listDirectory srcDir
forM_ srcFiles
(\srcFile ->
case stripDir srcDir srcFile of
Nothing -> return ()
Just relFile -> copyFile srcFile (destDir </> relFile))
forM_ srcSubDirs
(\srcSubDir ->
case stripDir srcDir srcSubDir of
Nothing -> return ()
Just relSubDir -> copyDirectoryRecursive srcSubDir (destDir </> relSubDir))
ignoreDoesNotExist :: MonadIO m => IO () -> m ()
ignoreDoesNotExist f =
liftIO $ catch f $ \e -> unless (isDoesNotExistError e) (throwIO e)
withCanonicalizedSystemTempDirectory :: (MonadMask m, MonadIO m)
=> String
-> (Path Abs Dir -> m a)
-> m a
withCanonicalizedSystemTempDirectory template action =
withSystemTempDirectory template (parseRelAsAbsDir >=> action)
withCanonicalizedTempDirectory :: (MonadMask m, MonadIO m)
=> FilePath
-> String
-> (Path Abs Dir -> m a)
-> m a
withCanonicalizedTempDirectory targetDir template action =
withTempDirectory targetDir template (parseRelAsAbsDir >=> action)