From 65595fa9c5b514d4036d5bbd16195a44e04bb194 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 31 Mar 2016 15:49:35 +0200 Subject: [PATCH] LIB/GTK: refactor HSFM.FileSystem.Error to use Path type --- src/HSFM/FileSystem/Errors.hs | 125 +++++++++++++------------- src/HSFM/FileSystem/FileOperations.hs | 46 +++++----- src/HSFM/GUI/Gtk/Callbacks.hs | 11 ++- 3 files changed, 89 insertions(+), 93 deletions(-) diff --git a/src/HSFM/FileSystem/Errors.hs b/src/HSFM/FileSystem/Errors.hs index b739efe..a4a024a 100644 --- a/src/HSFM/FileSystem/Errors.hs +++ b/src/HSFM/FileSystem/Errors.hs @@ -23,20 +23,10 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. module HSFM.FileSystem.Errors where -import Control.Applicative - ( - (<$>) - ) import Control.Exception import Control.Monad ( - unless - , void - , when - ) -import Data.List - ( - isPrefixOf + when ) import Data.Typeable import Foreign.C.Error @@ -44,12 +34,16 @@ import Foreign.C.Error getErrno , Errno ) +import qualified HPath as P +import HPath + ( + Abs + , Path + ) import HSFM.Utils.IO import System.FilePath ( equalFilePath - , isAbsolute - , takeFileName ) import System.IO.Error ( @@ -78,59 +72,78 @@ data FmIOException = FileDoesNotExist String instance Exception FmIOException --- Throws an exception if the filepath is not absolute --- or the file does not exist. -fileSanityThrow :: FilePath -> IO () -fileSanityThrow fp = throwNotAbsolute fp >> throwFileDoesNotExist fp --- Throws an exception if the filepath is not absolute --- or the dir does not exist. -dirSanityThrow :: FilePath -> IO () -dirSanityThrow fp = throwNotAbsolute fp >> throwDirDoesNotExist fp + ---------------------------- + --[ Path based functions ]-- + ---------------------------- -throwNotAbsolute :: FilePath -> IO () -throwNotAbsolute fp = unless (isAbsolute fp) (throw $ PathNotAbsolute fp) - - -throwFileDoesExist :: FilePath -> IO () +throwFileDoesExist :: Path Abs -> IO () throwFileDoesExist fp = - whenM (doesFileExist fp) (throw $ FileDoesExist fp) + whenM (doesFileExist fp) (throw $ FileDoesExist $ P.fromAbs fp) -throwDirDoesExist :: FilePath -> IO () +throwDirDoesExist :: Path Abs -> IO () throwDirDoesExist fp = - whenM (doesDirectoryExist fp) (throw $ DirDoesExist fp) + whenM (doesDirectoryExist fp) (throw $ DirDoesExist $ P.fromAbs fp) -throwDirDoesNotExist :: FilePath -> IO () -throwDirDoesNotExist fp = - unlessM (doesDirectoryExist fp) (throw $ DirDoesNotExist fp) - - -throwFileDoesNotExist :: FilePath -> IO () +throwFileDoesNotExist :: Path Abs -> IO () throwFileDoesNotExist fp = - unlessM (doesFileExist fp) (throw $ FileDoesNotExist fp) + whenM (doesFileExist fp) (throw $ FileDoesExist $ P.fromAbs fp) -throwSameFile :: FilePath -- ^ should be canonicalized - -> FilePath -- ^ should be canonicalized +throwDirDoesNotExist :: Path Abs -> IO () +throwDirDoesNotExist fp = + whenM (doesDirectoryExist fp) (throw $ DirDoesExist $ P.fromAbs fp) + + +throwSameFile :: Path Abs -- ^ will be canonicalized + -> Path Abs -- ^ will be canonicalized -> IO () -throwSameFile fp1 fp2 = when (equalFilePath fp1 fp2) (throw $ SameFile fp1 fp2) +throwSameFile fp1 fp2 = do + fp1' <- fmap P.fromAbs $ P.canonicalizePath fp1 + fp2' <- fmap P.fromAbs $ P.canonicalizePath fp2 + when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2') -throwDestinationInSource :: FilePath -- ^ should be canonicalized - -> FilePath -- ^ should be canonicalized +throwDestinationInSource :: Path Abs -- ^ will be canonicalized + -> Path Abs -- ^ will be canonicalized -> IO () -throwDestinationInSource source dest = - when (source `isPrefixOf` dest) (throw $ DestinationInSource dest source) +throwDestinationInSource source dest = do + source' <- P.canonicalizePath source + cDestbase <- fmap P.dirname $ P.canonicalizePath dest + let dest' = cDestbase P. P.basename dest + when (source' `P.isParentOf` dest') + (throw $ DestinationInSource (P.fromAbs dest') (P.fromAbs source')) -throwIsSymlink :: FilePath -> IO () -throwIsSymlink fp = - whenM (PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp) - (throw $ IsSymlink fp) +-- |Checks if the given file exists and is not a directory. This follows +-- symlinks, but will return True if the symlink is broken. +doesFileExist :: Path Abs -> IO Bool +doesFileExist fp = + handleIOError (\_ -> return False) $ do + fp' <- fmap P.fromAbs $ P.canonicalizePath fp + fs <- PF.getFileStatus 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 :: Path Abs -> IO Bool +doesDirectoryExist fp = + handleIOError (\_ -> return False) $ do + fp' <- fmap P.fromAbs $ P.canonicalizePath fp + fs <- PF.getFileStatus fp' + return $ PF.isDirectory fs + + + + + -------------------------------- + --[ Error handling functions ]-- + -------------------------------- -- |Carries out an action, then checks if there is an IOException and @@ -152,21 +165,3 @@ catchErrno en a1 a2 = 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/HSFM/FileSystem/FileOperations.hs b/src/HSFM/FileSystem/FileOperations.hs index 07e98da..4435bdf 100644 --- a/src/HSFM/FileSystem/FileOperations.hs +++ b/src/HSFM/FileSystem/FileOperations.hs @@ -179,12 +179,10 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode })) to@(_ :/ Dir {}) = do let fromp = fullPath from - fromp' = P.toFilePath fromp top = fullPath to destdirp = top P. fromn - destdirp' = P.toFilePath destdirp - throwDestinationInSource fromp' destdirp' - throwSameFile fromp' destdirp' + throwDestinationInSource fromp destdirp + throwSameFile fromp destdirp createDestdir destdirp fmode destdir <- HSFM.FileSystem.FileType.readFileWithFileInfo destdirp @@ -202,13 +200,13 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode })) let destdir' = P.toFilePath destdir in case cm of Merge -> - unlessM (doesDirectoryExist destdir') + unlessM (doesDirectoryExist destdir) (createDirectory destdir' fmode) Strict -> do - throwDirDoesExist destdir' + throwDirDoesExist destdir createDirectory destdir' fmode Replace -> do - whenM (doesDirectoryExist destdir') + whenM (doesDirectoryExist destdir) (deleteDirRecursive =<< HSFM.FileSystem.FileType.readFileWithFileInfo destdir) createDirectory destdir' fmode @@ -264,10 +262,10 @@ overwriteFile _ AFileInvFN = throw InvalidFileName overwriteFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do - let from' = fullPathS from - to' = fullPathS to + let from' = fullPath from + to' = fullPath to throwSameFile from' to' - copyFile' from' to' + copyFile' (P.fromAbs from') (P.fromAbs to') overwriteFile _ _ = throw $ InvalidOperation "wrong input type" @@ -282,12 +280,12 @@ copyFileToDir _ _ AFileInvFN = throw InvalidFileName copyFileToDir cm from@(_ :/ RegFile fn _) to@(_ :/ Dir {}) = do - let from' = fullPathS from - to' = P.fromAbs (fullPath to P. fn) + let from' = fullPath from + to' = fullPath to P. fn case cm of Strict -> throwFileDoesExist to' _ -> return () - copyFile' from' to' + copyFile' (P.fromAbs from') (P.fromAbs to') copyFileToDir _ _ _ = throw $ InvalidOperation "wrong input type" @@ -406,9 +404,9 @@ createFile :: AnchoredFile FileInfo -> Path Fn -> IO () createFile AFileInvFN _ = throw InvalidFileName createFile _ InvFN = throw InvalidFileName createFile (ADirOrSym td) (ValFN fn) = do - let fullp = P.fromAbs (fullPath td P. fn) + let fullp = fullPath td P. fn throwFileDoesExist fullp - fd <- System.Posix.IO.createFile fullp newFilePerms + fd <- System.Posix.IO.createFile (P.fromAbs fullp) newFilePerms closeFd fd createFile _ _ = throw $ InvalidOperation "wrong input type" @@ -417,9 +415,9 @@ createDir :: AnchoredFile FileInfo -> Path Fn -> IO () createDir AFileInvFN _ = throw InvalidFileName createDir _ InvFN = throw InvalidFileName createDir (ADirOrSym td) (ValFN fn) = do - let fullp = P.fromAbs (fullPath td P. fn) + let fullp = fullPath td P. fn throwDirDoesExist fullp - createDirectory fullp newFilePerms + createDirectory (P.fromAbs fullp) newFilePerms createDir _ _ = throw $ InvalidOperation "wrong input type" @@ -434,11 +432,11 @@ renameFile :: AnchoredFile FileInfo -> Path Fn -> IO () renameFile AFileInvFN _ = throw InvalidFileName renameFile _ InvFN = throw InvalidFileName renameFile af (ValFN fn) = do - let fromf = fullPathS af - tof = P.fromAbs (anchor af P. fn) + let fromf = fullPath af + tof = anchor af P. fn throwFileDoesExist tof throwSameFile fromf tof - rename fromf tof + rename (P.fromAbs fromf) (P.fromAbs tof) renameFile _ _ = throw $ InvalidOperation "wrong input type" @@ -455,16 +453,16 @@ moveFile cm from to@(_ :/ Dir {}) = do to' = fullPath to P. (name . file $ from) tos' = P.fromAbs (fullPath to P. (name . file $ from)) case cm of - Strict -> throwFileDoesExist tos' + Strict -> throwFileDoesExist to' Merge -> delOld to' Replace -> delOld to' - throwSameFile froms' tos' + throwSameFile from' to' catchErrno eXDEV (rename froms' tos') $ do easyCopy Strict from to easyDelete from where - delOld to = do - to' <- HSFM.FileSystem.FileType.readFileWithFileInfo to + delOld fp = do + to' <- HSFM.FileSystem.FileType.readFileWithFileInfo fp unless (failed . file $ to') (easyDelete to') moveFile _ _ _ = throw $ InvalidOperation "wrong input type" diff --git a/src/HSFM/GUI/Gtk/Callbacks.hs b/src/HSFM/GUI/Gtk/Callbacks.hs index 27a309c..d556e39 100644 --- a/src/HSFM/GUI/Gtk/Callbacks.hs +++ b/src/HSFM/GUI/Gtk/Callbacks.hs @@ -49,6 +49,11 @@ import Data.Foldable ) import Graphics.UI.Gtk import qualified HPath as P +import HPath + ( + Abs + , Path + ) import HSFM.FileSystem.Errors import HSFM.FileSystem.FileOperations import HSFM.FileSystem.FileType @@ -206,10 +211,8 @@ setCallbacks mygui myview = do urlGoTo :: MyGUI -> MyView -> IO () urlGoTo mygui myview = withErrorDialog $ do fp <- entryGetText (urlBar mygui) - let abs = isAbsolute fp - exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp - -- TODO: more explicit error handling? - refreshView mygui myview (Just fp) + forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' -> + refreshView mygui myview (Just $ P.fromAbs fp') -- |Supposed to be used with 'withRows'. Opens a file or directory.