diff --git a/hsfm.cabal b/hsfm.cabal index 11adfa4..2fcd497 100644 --- a/hsfm.cabal +++ b/hsfm.cabal @@ -29,7 +29,8 @@ library process, stm, text, - time >= 1.4.2 + time >= 1.4.2, + unix hs-source-dirs: src default-language: Haskell2010 Default-Extensions: RecordWildCards @@ -56,7 +57,8 @@ executable hsfm-gtk stm, text, time >= 1.4.2, - transformers >= 0.4 + transformers >= 0.4, + unix hs-source-dirs: src default-language: Haskell2010 Default-Extensions: RecordWildCards diff --git a/src/IO/Error.hs b/src/IO/Error.hs index 1df9c98..3f44b10 100644 --- a/src/IO/Error.hs +++ b/src/IO/Error.hs @@ -11,6 +11,10 @@ import Control.Monad , void , when ) +import Data.List + ( + isPrefixOf + ) import Data.Typeable import System.Directory ( @@ -31,6 +35,7 @@ data FmIOException = FileDoesNotExist String | SameFile String String | NotAFile String | NotADir String + | DestinationInSource String String deriving (Show, Typeable) @@ -79,3 +84,10 @@ throwSameFile :: FilePath -- ^ should be canonicalized -> FilePath -- ^ should be canonicalized -> IO () throwSameFile fp1 fp2 = when (equalFilePath fp1 fp2) (throw $ SameFile fp1 fp2) + + +throwDestinationInSource :: FilePath -- ^ should be canonicalized + -> FilePath -- ^ should be canonicalized + -> IO () +throwDestinationInSource source dest = + when (source `isPrefixOf` dest) (throw $ DestinationInSource dest source) diff --git a/src/IO/File.hs b/src/IO/File.hs index d994c47..e2dde6c 100644 --- a/src/IO/File.hs +++ b/src/IO/File.hs @@ -15,14 +15,18 @@ import Control.Monad ) import Data.DirTree import Data.DirTree.Zipper +import Data.Foldable + ( + for_ + ) import IO.Error import System.Directory ( canonicalizePath + , createDirectoryIfMissing , doesDirectoryExist , doesFileExist , executable - , getPermissions , removeDirectory , removeFile ) @@ -34,6 +38,11 @@ import System.FilePath , takeDirectory , () ) +import System.Posix.Files + ( + createSymbolicLink + , readSymbolicLink + ) import System.Process ( spawnProcess @@ -50,22 +59,58 @@ import qualified System.Directory as SD -- |Data type describing an actual file operation that can be -- carried out via `doFile`. Useful to build up a list of operations -- or delay operations. -data FileOperation a b = FCopy (DTZipper a b) (DTZipper a b) +data FileOperation = FCopy DTInfoZipper DTInfoZipper | FMove FilePath FilePath - | FDelete (DTZipper a b) - | FOpen (DTZipper a b) - | FExecute (DTZipper a b) [String] + | FDelete DTInfoZipper + | FOpen DTInfoZipper + | FExecute DTInfoZipper [String] | None -runFileOp :: FileOperation a b -> IO () -runFileOp (FCopy from to) = copyFileToDir from to +runFileOp :: FileOperation -> IO () +runFileOp (FCopy from@(File {}, _) to) = copyFileToDir from to +runFileOp (FCopy from@(Dir {}, _) to) = copyDir from to runFileOp (FDelete fp) = easyDelete fp runFileOp (FOpen fp) = void $ openFile fp runFileOp (FExecute fp args) = void $ executeFile fp args runFileOp _ = return () +-- TODO: copy modes +copyDir :: DTInfoZipper -- ^ source dir + -> DTInfoZipper -- ^ destination dir + -> IO () +copyDir from@(Dir fn _ _, _) to@(Dir {}, _) = do + let fromp = getFullPath from + top = getFullPath to + destdir = getFullPath to fn + + dirSanityThrow fromp + dirSanityThrow top + throwDestinationInSource fromp top + + createDirectoryIfMissing False destdir + + for_ (goAllDown from) $ \f -> do + newDest <- zipLazy mkDirInfo mkFileInfo destdir + case f of + -- recreate symlink + sz@(Dir { name = n, dir = (DirInfo { sym = True }) }, _) -> do + let sympoint = getFullPath newDest n + -- delete old file/dir to be able to create symlink + for_ (goDown n newDest) $ \odtz -> + easyDelete odtz + symname <- readSymbolicLink (getFullPath sz) + createSymbolicLink symname sympoint + sz@(Dir {}, _) -> + copyDir sz newDest + sz@(File {}, _) -> + copyFileToDir sz newDest +copyDir from@(File _ _, _) _ = throw $ NotADir (getFullPath from) +copyDir _ to@(File _ _, _) = throw $ NotADir (getFullPath to) + + + -- |Copies the given file. -- -- This will throw an exception if any of the filepaths are not absolute @@ -84,6 +129,7 @@ copyFile from@(File name _, _) to = do let to' = toC takeFileName to throwSameFile fp to' SD.copyFile fp to' +copyFile from _ = throw $ NotAFile (getFullPath from) -- |Copies the given file to the given dir with the same filename. @@ -108,27 +154,31 @@ easyCopyFile from (Left to) = copyFile from to easyCopyFile from (Right to) = copyFileToDir from to --- |Deletes the given file. +-- |Deletes the given file or symlink. -- -- This will throw an exception if the filepath is not absolute -- or the file does not exist. -- -- It also throws exceptions from `removeFile`. -deleteFile :: DTZipper a b -> IO () +deleteFile :: DTInfoZipper -> IO () deleteFile dtz@(File {}, _) = do let fp = getFullPath dtz fileSanityThrow fp removeFile fp +deleteFile dtz@(Dir { dir = (DirInfo { sym = True }) }, _) = do + let fp = getFullPath dtz + throwNotAbsolute fp + removeFile fp deleteFile dtz = throw $ NotAFile (getFullPath dtz) --- |Deletes the given directory. +-- |Deletes the given directory. Does not work on symlinks. -- -- This will throw an exception if the filepath is not absolute -- or the directory does not exist. -- -- It also throws exceptions from `removeDirectory`. -deleteDir :: DTZipper a b -> IO () +deleteDir :: DTInfoZipper -> IO () deleteDir dtz@(Dir {}, _) = do let fp = getFullPath dtz dirSanityThrow fp @@ -137,8 +187,9 @@ deleteDir dtz = throw $ NotADir (getFullPath dtz) -- |Deletes a file or directory, whatever it may be. -easyDelete :: DTZipper a b -> IO () +easyDelete :: DTInfoZipper -> IO () easyDelete dtz@(File {}, _) = deleteFile dtz +easyDelete dtz@(Dir { dir = (DirInfo { sym = True }) }, _) = deleteFile dtz easyDelete dtz@(Dir {}, _) = deleteDir dtz @@ -160,13 +211,12 @@ openFile dtz = throw $ NotAFile (getFullPath dtz) -- This will throw an exception if the filepath is not absolute -- or the file does not exist. It will also throw an exception -- if the file is not executable. -executeFile :: DTZipper a b -- ^ program +executeFile :: DTInfoZipper -- ^ program -> [String] -- ^ arguments -> IO ProcessHandle -executeFile dtz@(File {}, _) args = do +executeFile dtz@(File { file = (FileInfo { permissions = p }) }, _) args = do let fp = getFullPath dtz fileSanityThrow fp - p <- getPermissions fp unless (executable p) (throw $ FileNotExecutable fp) spawnProcess fp args executeFile dtz _ = throw $ NotAFile (getFullPath dtz)