hasufell/hsfm
1
1
Fork 0
Code Issues 33 Pull Requests Releases Wiki Activity

LIB: improve error handling

Browse Source 
* 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
This commit is contained in:
Julian Ospald 2015-12-27 16:25:24 +01:00
parent 27673b0751
commit 5afc25d2d1
No known key found for this signature in database
GPG Key ID: 220CD1C5BDEED020
3 changed files with 72 additions and 65 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

46
src/Data/DirTree.hs
View File

@ -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

26
src/IO/Error.hs
View File

@ -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

65
src/IO/File.hs
View File

@ -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"