From 5afc25d2d1e9a897de8c22b2128ef28d97ce6cd3 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 27 Dec 2015 16:25:24 +0100 Subject: [PATCH] LIB: improve error handling * close all directory streams in case of IOErrors * raise error on invalid input types in File operations * properly catch eXDEV in moveFile instead of all errors --- src/Data/DirTree.hs | 46 +++++++++++++++----------------- src/IO/Error.hs | 26 ++++++++++++++++++ src/IO/File.hs | 65 +++++++++++++++++---------------------------- 3 files changed, 72 insertions(+), 65 deletions(-) diff --git a/src/Data/DirTree.hs b/src/Data/DirTree.hs index 9e8917a..2253574 100644 --- a/src/Data/DirTree.hs +++ b/src/Data/DirTree.hs @@ -43,7 +43,8 @@ import Control.Exception ) import Control.Exception.Base ( - IOException + onException + , IOException ) import Control.Monad.State.Lazy ( @@ -240,7 +241,6 @@ convertViewP f af@(bp :/ constr) = in (b, bp :/ file) - afileLike :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo) afileLike f@(bp :/ constr) = convertViewP fileLike f @@ -289,12 +289,12 @@ fileLikeSym f@(SymLink { sdest = (_ :/ s@(SymLink {}) )}) = case (fileLikeSym s) of (True, _) -> (True, f) _ -> (False, f) -fileLikeSym f@(SymLink { sdest = (_ :/ RegFile {} )}) = (True, f) -fileLikeSym f@(SymLink { sdest = (_ :/ BlockDev {} )}) = (True, f) -fileLikeSym f@(SymLink { sdest = (_ :/ CharDev {} )}) = (True, f) +fileLikeSym f@(SymLink { sdest = (_ :/ RegFile {} )}) = (True, f) +fileLikeSym f@(SymLink { sdest = (_ :/ BlockDev {} )}) = (True, f) +fileLikeSym f@(SymLink { sdest = (_ :/ CharDev {} )}) = (True, f) fileLikeSym f@(SymLink { sdest = (_ :/ NamedPipe {} )}) = (True, f) -fileLikeSym f@(SymLink { sdest = (_ :/ Socket {} )}) = (True, f) -fileLikeSym f = (False, f) +fileLikeSym f@(SymLink { sdest = (_ :/ Socket {} )}) = (True, f) +fileLikeSym f = (False, f) adirSym :: AnchoredFile FileInfo -> (Bool, AnchoredFile FileInfo) @@ -634,36 +634,34 @@ getContents (ADirOrSym af) = readDirectory (fullPath af) getContents _ = return [] --- |Get all files of a given directory and return them as a List. --- This includes "." and "..". -getAllDirsFiles :: FilePath -> IO [FilePath] -getAllDirsFiles fp = do +getDirsFiles' :: (FilePath -> [FilePath] -> [FilePath]) + -> FilePath + -> IO [FilePath] +getDirsFiles' filterf fp = do dirstream <- PFD.openDirStream fp let mdirs :: [FilePath] -> IO [FilePath] mdirs dirs = do - dir <- PFD.readDirStream dirstream + -- make sure we close the directory stream in case of errors + dir <- onException (PFD.readDirStream dirstream) + (PFD.closeDirStream dirstream) if dir == "" then return dirs - else mdirs (dir : dirs) + else mdirs (dir `filterf` dirs) dirs <- mdirs [] PFD.closeDirStream dirstream return dirs +-- |Get all files of a given directory and return them as a List. +-- This includes "." and "..". +getAllDirsFiles :: FilePath -> IO [FilePath] +getAllDirsFiles = getDirsFiles' (:) + + -- |Get all files of a given directory and return them as a List. -- This excludes "." and "..". getDirsFiles :: FilePath -> IO [FilePath] -getDirsFiles fp = do - dirstream <- PFD.openDirStream fp - let mdirs :: [FilePath] -> IO [FilePath] - mdirs dirs = do - dir <- PFD.readDirStream dirstream - if dir == "" - then return dirs - else mdirs (insert dir dirs) - dirs <- mdirs [] - PFD.closeDirStream dirstream - return dirs +getDirsFiles = getDirsFiles' insert where insert dir dirs = case dir of "." -> dirs diff --git a/src/IO/Error.hs b/src/IO/Error.hs index 8d4fd20..972a571 100644 --- a/src/IO/Error.hs +++ b/src/IO/Error.hs @@ -39,6 +39,11 @@ import Data.List isPrefixOf ) import Data.Typeable +import Foreign.C.Error + ( + getErrno + , Errno + ) import IO.Utils import System.Directory ( @@ -51,6 +56,10 @@ import System.FilePath , isAbsolute , takeFileName ) +import System.IO.Error + ( + catchIOError + ) import qualified System.Posix.Files as PF @@ -66,6 +75,7 @@ data FmIOException = FileDoesNotExist String | FileDoesExist String | DirDoesExist String | IsSymlink String + | InvalidOperation String deriving (Show, Typeable) @@ -125,3 +135,19 @@ throwIsSymlink :: FilePath -> IO () throwIsSymlink fp = whenM (PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp) (throw $ IsSymlink fp) + + +-- |Carries out an action, then checks if there is an IOException and +-- a specific errno. If so, then it carries out another action, otherwise +-- it rethrows the error. +catchErrno :: Errno -- ^ errno to catch + -> IO a -- ^ action to try, which can raise an IOException + -> IO a -- ^ action to carry out in case of an IOException and + -- if errno matches + -> IO a +catchErrno en a1 a2 = + catchIOError a1 $ \e -> do + errno <- getErrno + if errno == en + then a2 + else ioError e diff --git a/src/IO/File.hs b/src/IO/File.hs index eb5c0ec..5f77983 100644 --- a/src/IO/File.hs +++ b/src/IO/File.hs @@ -35,35 +35,27 @@ import Control.Applicative ) import Control.Exception ( - handle - , throw - , SomeException(..) - ) -import Control.Monad - ( - unless - , void + throw ) import Data.DirTree import Data.Foldable ( for_ ) +import Foreign.C.Error + ( + eXDEV + ) import IO.Error import IO.Utils import System.Directory ( doesDirectoryExist - , doesFileExist , removeDirectoryRecursive ) import System.FilePath ( - equalFilePath - , isAbsolute - , takeFileName - , takeDirectory - , () + () ) import System.Posix.Directory ( @@ -74,8 +66,6 @@ import System.Posix.Files ( createSymbolicLink , readSymbolicLink - , fileAccess - , getFileStatus , groupExecuteMode , groupReadMode , groupWriteMode @@ -86,7 +76,6 @@ import System.Posix.Files , ownerReadMode , ownerWriteMode , rename - , touchFile , unionFileModes , removeLink ) @@ -107,7 +96,6 @@ import System.Process import qualified System.Directory as SD -import qualified System.Posix.Files as PF -- TODO: file operations should be threaded and not block the UI @@ -157,7 +145,6 @@ runFileOp (FMove fo) = return $ Just $ FMove fo runFileOp (FDelete fp) = easyDelete fp >> return Nothing runFileOp (FOpen fp) = openFile fp >> return Nothing runFileOp (FExecute fp args) = executeFile fp args >> return Nothing -runFileOp _ = return Nothing @@ -216,7 +203,7 @@ copyDir cm from@(_ :/ Dir fromn _) _ -> return () recreateSymlink f destdir -copyDir _ _ _ = return () +copyDir _ _ _ = throw $ InvalidOperation "wrong input type" -- |Recreate a symlink. @@ -229,7 +216,7 @@ recreateSymlink symf@(_ :/ SymLink {}) = do symname <- readSymbolicLink (fullPath symf) createSymbolicLink symname (fullPath symdest (name . file $ symf)) -recreateSymlink _ _ = return () +recreateSymlink _ _ = throw $ InvalidOperation "wrong input type" -- |Copies the given file to the given file destination. @@ -243,7 +230,7 @@ copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do to' = fullPath to throwSameFile from' to' SD.copyFile from' to' -copyFile _ _ = return () +copyFile _ _ = throw $ InvalidOperation "wrong input type" -- |Copies the given file to the given dir with the same filename. @@ -258,7 +245,7 @@ copyFileToDir from@(_ :/ RegFile fn _) let from' = fullPath from to' = fullPath to fn SD.copyFile from' to' -copyFileToDir _ _ = return () +copyFileToDir _ _ = throw $ InvalidOperation "wrong input type" -- |Copies a file, directory or symlink. In case of a symlink, it is just @@ -277,7 +264,7 @@ easyCopy _ from@(_ :/ RegFile fn _) easyCopy cm from@(_ :/ Dir fn _) to@(_ :/ Dir {}) = copyDir cm from to -easyCopy _ _ _ = return () +easyCopy _ _ _ = throw $ InvalidOperation "wrong input type" @@ -292,8 +279,7 @@ easyCopy _ _ _ = return () deleteSymlink :: AnchoredFile FileInfo -> IO () deleteSymlink f@(_ :/ SymLink {}) = removeLink (fullPath f) -deleteSymlink _ - = return () +deleteSymlink _ = throw $ InvalidOperation "wrong input type" -- |Deletes the given file, never symlinks. @@ -301,8 +287,7 @@ deleteFile :: AnchoredFile FileInfo -> IO () deleteFile (_ :/ SymLink {}) = return () deleteFile f@(_ :/ RegFile {}) = removeLink (fullPath f) -deleteFile _ - = return () +deleteFile _ = throw $ InvalidOperation "wrong input type" -- |Deletes the given directory, never symlinks. @@ -310,7 +295,7 @@ deleteDir :: AnchoredFile FileInfo -> IO () deleteDir (_ :/ SymLink {}) = return () deleteDir f@(_ :/ Dir {}) = removeDirectory (fullPath f) -deleteDir _ = return () +deleteDir _ = throw $ InvalidOperation "wrong input type" -- |Deletes the given directory recursively, never symlinks. @@ -318,7 +303,7 @@ deleteDirRecursive :: AnchoredFile FileInfo -> IO () deleteDirRecursive (_ :/ SymLink {}) = return () deleteDirRecursive f@(_ :/ Dir {}) = removeDirectoryRecursive (fullPath f) -deleteDirRecursive _ = return () +deleteDirRecursive _ = throw $ InvalidOperation "wrong input type" -- |Deletes a file, directory or symlink, whatever it may be. @@ -330,8 +315,7 @@ easyDelete f@(_ :/ RegFile {}) = deleteFile f easyDelete f@(_ :/ Dir {}) = deleteDirRecursive f -easyDelete _ - = return () +easyDelete _ = throw $ InvalidOperation "wrong input type" @@ -350,10 +334,10 @@ openFile f = spawnProcess "xdg-open" [fullPath f] -- |Executes a program with the given arguments. executeFile :: AnchoredFile FileInfo -- ^ program -> [String] -- ^ arguments - -> IO (Maybe ProcessHandle) + -> IO ProcessHandle executeFile prog@(_ :/ RegFile {}) args - = Just <$> spawnProcess (fullPath prog) args -executeFile _ _ = return Nothing + = spawnProcess (fullPath prog) args +executeFile _ _ = throw $ InvalidOperation "wrong input type" @@ -369,7 +353,7 @@ createFile (ADirOrSym td) (ValFN fn) = do throwFileDoesExist fullp fd <- System.Posix.IO.createFile fullp newFilePerms closeFd fd -createFile _ _ = return () +createFile _ _ = throw $ InvalidOperation "wrong input type" createDir :: AnchoredFile FileInfo -> FileName -> IO () @@ -377,7 +361,7 @@ createDir (ADirOrSym td) (ValFN fn) = do let fullp = fullPath td fn throwDirDoesExist fullp createDirectory fullp newFilePerms -createDir _ _ = return () +createDir _ _ = throw $ InvalidOperation "wrong input type" @@ -395,7 +379,7 @@ renameFile af (ValFN fn) = do throwFileDoesExist tof throwSameFile fromf tof rename fromf tof -renameFile _ _ = return () +renameFile _ _ = throw $ InvalidOperation "wrong input type" -- |Move a given file to the given target directory. @@ -407,11 +391,10 @@ moveFile from to@(_ :/ Dir {}) = do to' = fullPath to (name . file $ from) throwFileDoesExist to' throwSameFile from' to' - handle (\(SomeException e) -> do + catchErrno eXDEV (rename from' to') $ do easyCopy Strict from to easyDelete from - ) $ rename from' to' -moveFile _ _ = return () +moveFile _ _ = throw $ InvalidOperation "wrong input type"