From d460b4ce11e122ac25e53a1024e8b98b1871c463 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 2 Jun 2016 13:44:47 +0200 Subject: [PATCH] LIB: simplify error handling in FileType We don't have a Failed constructor anymore. --- src/HSFM/FileSystem/FileType.hs | 104 +++++++------------------------- src/HSFM/GUI/Gtk.hs | 2 +- src/HSFM/GUI/Gtk/MyView.hs | 3 +- 3 files changed, 23 insertions(+), 86 deletions(-) diff --git a/src/HSFM/FileSystem/FileType.hs b/src/HSFM/FileSystem/FileType.hs index 1937b5c..8cf138d 100644 --- a/src/HSFM/FileSystem/FileType.hs +++ b/src/HSFM/FileSystem/FileType.hs @@ -59,11 +59,6 @@ import HPath.IO hiding (FileType(..)) import HPath.IO.Errors import HSFM.Utils.MyPrelude import Prelude hiding(readFile) -import System.IO.Error - ( - ioeGetErrorType - , isDoesNotExistErrorType - ) import System.Posix.FilePath ( () @@ -98,13 +93,9 @@ import System.Posix.Types -- |The String in the path field is always a full path. -- The free type variable is used in the File/Dir constructor and can hold -- Handles, Strings representing a file's contents or anything else you can --- think of. We catch any IO errors in the Failed constructor. +-- think of. data File a = - Failed { - path :: !(Path Abs) - , err :: IOError - } - | Dir { + Dir { path :: !(Path Abs) , fvar :: a } @@ -115,8 +106,8 @@ data File a = | SymLink { path :: !(Path Abs) , fvar :: a - , sdest :: File a -- ^ symlink madness, - -- we need to know where it points to + , sdest :: Maybe (File a) -- ^ symlink madness, + -- we need to know where it points to , rawdest :: !ByteString } | BlockDev { @@ -187,14 +178,14 @@ fileLike f = (False, f) sdir :: File FileInfo -> (Bool, File FileInfo) -sdir f@SymLink{ sdest = (s@SymLink{} )} +sdir f@SymLink{ sdest = (Just s@SymLink{} )} -- we have to follow a chain of symlinks here, but -- return only the very first level -- TODO: this is probably obsolete now = case sdir s of (True, _) -> (True, f) _ -> (False, f) -sdir f@SymLink{ sdest = Dir{} } +sdir f@SymLink{ sdest = Just Dir{} } = (True, f) sdir f@Dir{} = (True, f) sdir f = (False, f) @@ -223,24 +214,24 @@ brokenSymlink f = (isBrokenSymlink f, f) fileLikeSym :: File FileInfo -> (Bool, File FileInfo) -fileLikeSym f@SymLink{ sdest = s@SymLink{} } +fileLikeSym f@SymLink{ sdest = Just 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 = NamedPipe{} } = (True, f) -fileLikeSym f@SymLink{ sdest = Socket{} } = (True, f) +fileLikeSym f@SymLink{ sdest = Just RegFile{} } = (True, f) +fileLikeSym f@SymLink{ sdest = Just BlockDev{} } = (True, f) +fileLikeSym f@SymLink{ sdest = Just CharDev{} } = (True, f) +fileLikeSym f@SymLink{ sdest = Just NamedPipe{} } = (True, f) +fileLikeSym f@SymLink{ sdest = Just Socket{} } = (True, f) fileLikeSym f = (False, f) dirSym :: File FileInfo -> (Bool, File FileInfo) -dirSym f@SymLink{ sdest = s@SymLink{} } +dirSym f@SymLink{ sdest = Just s@SymLink{} } = case dirSym s of (True, _) -> (True, f) _ -> (False, f) -dirSym f@SymLink{ sdest = Dir{} } = (True, f) +dirSym f@SymLink{ sdest = Just Dir{} } = (True, f) dirSym f = (False, f) @@ -306,8 +297,7 @@ instance Ord (File FileInfo) where readFile :: (Path Abs -> IO a) -> Path Abs -> IO (File a) -readFile ff p = - handleDT p $ do +readFile ff p = do fs <- PF.getSymbolicLinkStatus (P.toFilePath p) fv <- ff p constructFile fs fv p @@ -317,11 +307,12 @@ readFile ff p = -- symlink madness, we need to make sure we save the correct -- File x <- PF.readSymbolicLink (P.fromAbs p') - resolvedSyml <- handleDT p' $ do + resolvedSyml <- handleIOError (\_ -> return Nothing) $ do -- watch out, we call from 'filepath' here, but it is safe let sfp = (P.fromAbs . P.dirname $ p') x rsfp <- realpath sfp - readFile ff =<< P.parseAbs rsfp + f <- readFile ff =<< P.parseAbs rsfp + return $ Just f return $ SymLink p' fv resolvedSyml x | PF.isDirectory fs = return $ Dir p' fv | PF.isRegularFile fs = return $ RegFile p' fv @@ -329,8 +320,7 @@ readFile ff p = | PF.isCharacterDevice fs = return $ CharDev p' fv | PF.isNamedPipe fs = return $ NamedPipe p' fv | PF.isSocket fs = return $ Socket p' fv - | otherwise = return $ Failed p' (userError - "Unknown filetype!") + | otherwise = ioError $ userError "Unknown filetype!" -- |Get the contents of a given directory and return them as a list @@ -340,8 +330,7 @@ readDirectoryContents :: (Path Abs -> IO a) -- ^ fills free a variable -> IO [File a] readDirectoryContents ff p = do files <- getDirsFiles p - fcs <- mapM (readFile ff) files - return fcs + mapM (readFile ff) files -- |A variant of `readDirectoryContents` where the second argument @@ -373,28 +362,6 @@ goUp' fp = readFile getFileInfo $ P.dirname fp ----- HANDLING FAILURES ---- - - --- |True if any Failed constructors in the tree. -anyFailed :: [File a] -> Bool -anyFailed = not . successful - --- |True if there are no Failed constructors in the tree. -successful :: [File a] -> Bool -successful = null . failures - - --- |Returns true if argument is a `Failed` constructor. -failed :: File a -> Bool -failed (Failed _ _) = True -failed _ = False - - --- |Returns a list of 'Failed' constructors only. -failures :: [File a] -> [File a] -failures = filter failed - ---- ORDERING AND EQUALITY ---- @@ -402,11 +369,7 @@ failures = filter failed -- HELPER: a non-recursive comparison comparingConstr :: File FileInfo -> File FileInfo -> Ordering -comparingConstr (Failed _ _) (DirOrSym _) = LT -comparingConstr (Failed _ _) (FileLikeOrSym _) = LT -comparingConstr (FileLikeOrSym _) (Failed _ _) = GT comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT -comparingConstr (DirOrSym _) (Failed _ _) = GT comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT -- else compare on the names of constructors that are the same, without -- looking at the contents of Dir constructors: @@ -490,28 +453,6 @@ getFileInfo fp = do ----- FAILURE HELPERS: ---- - - --- Handles an IO exception by returning a Failed constructor filled with that --- exception. Does not handle FmIOExceptions. -handleDT :: Path Abs - -> IO (File a) - -> IO (File a) -handleDT p - = handleIOError $ \e -> return $ Failed p e - - --- |Carries out the action. If the action returns a file --- with a failed constructor, rethrows the IOError within. --- Otherwise, returns the file unchanged. -rethrowFailed :: IO (File a) -> IO (File a) -rethrowFailed a = do - file <- a - case file of - (Failed _ e) -> ioError e - _ -> return file - ---- SYMLINK HELPERS: ---- @@ -522,7 +463,7 @@ rethrowFailed a = do -- -- When called on a non-symlink, returns False. isBrokenSymlink :: File FileInfo -> Bool -isBrokenSymlink (SymLink _ _ Failed{} _) = True +isBrokenSymlink (SymLink _ _ Nothing _) = True isBrokenSymlink _ = False @@ -563,7 +504,6 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt CharDev {} -> "c" NamedPipe {} -> "p" Socket {} -> "s" - _ -> "?" ownerModeStr = hasFmStr PF.ownerReadMode "r" ++ hasFmStr PF.ownerWriteMode "w" ++ hasFmStr PF.ownerExecuteMode "x" @@ -588,7 +528,6 @@ packFileType file = case file of CharDev {} -> "Char Device" NamedPipe {} -> "Named Pipe" Socket {} -> "Socket" - _ -> "Unknown" packLinkDestination :: File a -> Maybe ByteString @@ -621,5 +560,4 @@ getFreeVar (BlockDev _ d) = Just d getFreeVar (CharDev _ d) = Just d getFreeVar (NamedPipe _ d) = Just d getFreeVar (Socket _ d) = Just d -getFreeVar _ = Nothing diff --git a/src/HSFM/GUI/Gtk.hs b/src/HSFM/GUI/Gtk.hs index 0692176..18233d0 100644 --- a/src/HSFM/GUI/Gtk.hs +++ b/src/HSFM/GUI/Gtk.hs @@ -52,7 +52,7 @@ main = do let mdir = fromMaybe (fromJust $ P.parseAbs "/") (P.parseAbs . headDef "/" $ args) - file <- catchIOError (rethrowFailed $ readFile getFileInfo mdir) $ + file <- catchIOError (readFile getFileInfo mdir) $ \_ -> readFile getFileInfo . fromJust $ P.parseAbs "/" _ <- initGUI diff --git a/src/HSFM/GUI/Gtk/MyView.hs b/src/HSFM/GUI/Gtk/MyView.hs index 3a4931a..72fc514 100644 --- a/src/HSFM/GUI/Gtk/MyView.hs +++ b/src/HSFM/GUI/Gtk/MyView.hs @@ -301,7 +301,7 @@ refreshView :: MyGUI -> MyView -> Item -> IO () -refreshView mygui myview SymLink { sdest = d@Dir{} } = +refreshView mygui myview SymLink { sdest = Just d@Dir{} } = refreshView mygui myview d refreshView mygui myview item@Dir{} = do newRawModel <- fileListStore item myview @@ -351,7 +351,6 @@ constructView mygui myview = do dirtreePix FileLike{} = filePix dirtreePix DirSym{} = folderSymPix dirtreePix FileLikeSym{} = fileSymPix - dirtreePix Failed{} = errorPix dirtreePix BrokenSymlink{} = errorPix dirtreePix _ = errorPix