From 54af33f3a782df5733f648218984c28c38705e68 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 27 Dec 2015 19:26:58 +0100 Subject: [PATCH] LIB/GTK: remove the rest of the directory package --- hsfm.cabal | 4 ++-- src/Data/DirTree.hs | 16 --------------- src/GUI/Gtk.hs | 5 ----- src/GUI/Gtk/Callbacks.hs | 5 ----- src/IO/Error.hs | 28 ++++++++++++++++++++----- src/IO/File.hs | 44 +++++++++++++++++++++++++++------------- 6 files changed, 55 insertions(+), 47 deletions(-) diff --git a/hsfm.cabal b/hsfm.cabal index 20cf914..1b9123b 100644 --- a/hsfm.cabal +++ b/hsfm.cabal @@ -28,10 +28,10 @@ library MyPrelude build-depends: base >= 4.7, + bytestring, data-default, bifunctors >= 5, containers, - directory >= 1.1.0.0 && < 1.2.3.0, filepath >= 1.3.0.0, hinotify, mtl >= 2.2, @@ -63,13 +63,13 @@ executable hsfm-gtk build-depends: hsfm, base >= 4.7, + bytestring, Cabal >= 1.22.0.0, containers, data-default, gtk3 >= 0.14.1, glib >= 0.13, bifunctors >= 5, - directory >= 1.1.0.0 && < 1.2.3.0, filepath >= 1.3.0.0, hinotify, mtl >= 2.2, diff --git a/src/Data/DirTree.hs b/src/Data/DirTree.hs index 793bdbe..3e5a0ba 100644 --- a/src/Data/DirTree.hs +++ b/src/Data/DirTree.hs @@ -86,10 +86,6 @@ import Safe atDef , initDef ) -import System.Directory - ( - canonicalizePath - ) import System.FilePath ( combine @@ -605,18 +601,6 @@ normalize fp = ff x y = x ++ [y] --- |Like `canonicalizePath` from System.Directory, but preserves the last --- component if it's a symlink. -canonicalizePath' :: FilePath -> IO FilePath -canonicalizePath' fp = do - -- TODO: throw fileDoesNotExist error earlier - isSymlink <- PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp - if isSymlink - then do - cbase <- canonicalizePath (baseDir fp) - return $ cbase topDir fp - else canonicalizePath fp - ---- IO HELPERS: ---- diff --git a/src/GUI/Gtk.hs b/src/GUI/Gtk.hs index 71e6073..710f000 100644 --- a/src/GUI/Gtk.hs +++ b/src/GUI/Gtk.hs @@ -88,11 +88,6 @@ import Safe ( headDef ) -import System.Directory - ( - doesFileExist - , doesDirectoryExist - ) import System.Environment ( getArgs diff --git a/src/GUI/Gtk/Callbacks.hs b/src/GUI/Gtk/Callbacks.hs index 7da7260..8632629 100644 --- a/src/GUI/Gtk/Callbacks.hs +++ b/src/GUI/Gtk/Callbacks.hs @@ -57,11 +57,6 @@ import GUI.Gtk.Utils import IO.Error import IO.File import IO.Utils -import System.Directory - ( - doesFileExist - , doesDirectoryExist - ) import System.FilePath ( isAbsolute diff --git a/src/IO/Error.hs b/src/IO/Error.hs index 972a571..82eb837 100644 --- a/src/IO/Error.hs +++ b/src/IO/Error.hs @@ -45,11 +45,6 @@ import Foreign.C.Error , Errno ) import IO.Utils -import System.Directory - ( - doesDirectoryExist - , doesFileExist - ) import System.FilePath ( equalFilePath @@ -151,3 +146,26 @@ catchErrno en a1 a2 = if errno == en then a2 else ioError e + + +handleIOError :: (IOError -> IO a) -> IO a -> IO a +handleIOError a1 a2 = catchIOError a2 a1 + + +-- |Checks if the given file exists and is not a directory. This follows +-- symlinks, but will return True if the symlink is broken. +doesFileExist :: FilePath -> IO Bool +doesFileExist fp = + handleIOError (\_ -> return False) $ do + fs <- catchIOError (PF.getFileStatus fp) $ \_ -> + PF.getSymbolicLinkStatus fp + return $ not . PF.isDirectory $ fs + + +-- |Checks if the given file exists and is a directory. This follows +-- symlinks, but will return False if the symlink is broken. +doesDirectoryExist :: FilePath -> IO Bool +doesDirectoryExist fp = + handleIOError (\_ -> return False) $ do + fs <- PF.getFileStatus fp + return $ PF.isDirectory fs diff --git a/src/IO/File.hs b/src/IO/File.hs index 5f77983..de24d17 100644 --- a/src/IO/File.hs +++ b/src/IO/File.hs @@ -48,11 +48,6 @@ import Foreign.C.Error ) import IO.Error import IO.Utils -import System.Directory - ( - doesDirectoryExist - , removeDirectoryRecursive - ) import System.FilePath ( () @@ -65,7 +60,9 @@ import System.Posix.Directory import System.Posix.Files ( createSymbolicLink + , fileMode , readSymbolicLink + , getSymbolicLinkStatus , groupExecuteMode , groupReadMode , groupWriteMode @@ -94,7 +91,7 @@ import System.Process , ProcessHandle ) -import qualified System.Directory as SD +import qualified Data.ByteString as BS @@ -191,7 +188,8 @@ copyDir cm from@(_ :/ Dir fromn _) throwDirDoesExist destdir createDirectory destdir newDirPerms Replace -> do - whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir) + whenM (doesDirectoryExist destdir) + (deleteDirRecursive =<< Data.DirTree.readFile destdir) createDirectory destdir newDirPerms recreateSymlink' f destdir = do let destfilep = fullPath destdir (name . file $ f) @@ -219,6 +217,19 @@ recreateSymlink symf@(_ :/ SymLink {}) recreateSymlink _ _ = throw $ InvalidOperation "wrong input type" +-- |TODO: handle EAGAIN exception for non-blocking IO +-- |Low-level function to copy a given file to the given path. The fileMode +-- is preserved. +copyFile' :: FilePath -> FilePath -> IO () +copyFile' from to = do + fromFstatus <- getSymbolicLinkStatus from + fromContent <- BS.readFile from + fd <- System.Posix.IO.createFile to + (System.Posix.Files.fileMode fromFstatus) + closeFd fd + BS.writeFile to fromContent + + -- |Copies the given file to the given file destination. -- Excludes symlinks. copyFile :: AnchoredFile FileInfo -- ^ source file @@ -229,7 +240,7 @@ copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do let from' = fullPath from to' = fullPath to throwSameFile from' to' - SD.copyFile from' to' + copyFile' from' to' copyFile _ _ = throw $ InvalidOperation "wrong input type" @@ -244,7 +255,7 @@ copyFileToDir from@(_ :/ RegFile fn _) do let from' = fullPath from to' = fullPath to fn - SD.copyFile from' to' + copyFile' from' to' copyFileToDir _ _ = throw $ InvalidOperation "wrong input type" @@ -298,11 +309,17 @@ deleteDir f@(_ :/ Dir {}) deleteDir _ = throw $ InvalidOperation "wrong input type" --- |Deletes the given directory recursively, never symlinks. +-- |Deletes the given directory recursively. deleteDirRecursive :: AnchoredFile FileInfo -> IO () -deleteDirRecursive (_ :/ SymLink {}) = return () -deleteDirRecursive f@(_ :/ Dir {}) - = removeDirectoryRecursive (fullPath f) +deleteDirRecursive f@(_ :/ Dir {}) = do + let fp = fullPath f + files <- readDirectory' fp + for_ files $ \file -> + case file of + (_ :/ SymLink {}) -> deleteSymlink file + (_ :/ Dir {}) -> deleteDirRecursive file + (_ :/ f) -> removeLink (fullPath file) + removeDirectory fp deleteDirRecursive _ = throw $ InvalidOperation "wrong input type" @@ -422,4 +439,3 @@ newDirPerms `unionFileModes` groupReadMode `unionFileModes` otherExecuteMode `unionFileModes` otherReadMode -