LIB: simplify error handling in FileType
We don't have a Failed constructor anymore.
This commit is contained in:
parent
244a58d8c2
commit
d460b4ce11
@ -59,11 +59,6 @@ import HPath.IO hiding (FileType(..))
|
|||||||
import HPath.IO.Errors
|
import HPath.IO.Errors
|
||||||
import HSFM.Utils.MyPrelude
|
import HSFM.Utils.MyPrelude
|
||||||
import Prelude hiding(readFile)
|
import Prelude hiding(readFile)
|
||||||
import System.IO.Error
|
|
||||||
(
|
|
||||||
ioeGetErrorType
|
|
||||||
, isDoesNotExistErrorType
|
|
||||||
)
|
|
||||||
import System.Posix.FilePath
|
import System.Posix.FilePath
|
||||||
(
|
(
|
||||||
(</>)
|
(</>)
|
||||||
@ -98,13 +93,9 @@ import System.Posix.Types
|
|||||||
-- |The String in the path field is always a full path.
|
-- |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
|
-- 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
|
-- 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 =
|
data File a =
|
||||||
Failed {
|
Dir {
|
||||||
path :: !(Path Abs)
|
|
||||||
, err :: IOError
|
|
||||||
}
|
|
||||||
| Dir {
|
|
||||||
path :: !(Path Abs)
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
}
|
}
|
||||||
@ -115,8 +106,8 @@ data File a =
|
|||||||
| SymLink {
|
| SymLink {
|
||||||
path :: !(Path Abs)
|
path :: !(Path Abs)
|
||||||
, fvar :: a
|
, fvar :: a
|
||||||
, sdest :: File a -- ^ symlink madness,
|
, sdest :: Maybe (File a) -- ^ symlink madness,
|
||||||
-- we need to know where it points to
|
-- we need to know where it points to
|
||||||
, rawdest :: !ByteString
|
, rawdest :: !ByteString
|
||||||
}
|
}
|
||||||
| BlockDev {
|
| BlockDev {
|
||||||
@ -187,14 +178,14 @@ fileLike f = (False, f)
|
|||||||
|
|
||||||
|
|
||||||
sdir :: File FileInfo -> (Bool, File FileInfo)
|
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
|
-- we have to follow a chain of symlinks here, but
|
||||||
-- return only the very first level
|
-- return only the very first level
|
||||||
-- TODO: this is probably obsolete now
|
-- TODO: this is probably obsolete now
|
||||||
= case sdir s of
|
= case sdir s of
|
||||||
(True, _) -> (True, f)
|
(True, _) -> (True, f)
|
||||||
_ -> (False, f)
|
_ -> (False, f)
|
||||||
sdir f@SymLink{ sdest = Dir{} }
|
sdir f@SymLink{ sdest = Just Dir{} }
|
||||||
= (True, f)
|
= (True, f)
|
||||||
sdir f@Dir{} = (True, f)
|
sdir f@Dir{} = (True, f)
|
||||||
sdir f = (False, f)
|
sdir f = (False, f)
|
||||||
@ -223,24 +214,24 @@ brokenSymlink f = (isBrokenSymlink f, f)
|
|||||||
|
|
||||||
|
|
||||||
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
|
fileLikeSym :: File FileInfo -> (Bool, File FileInfo)
|
||||||
fileLikeSym f@SymLink{ sdest = s@SymLink{} }
|
fileLikeSym f@SymLink{ sdest = Just s@SymLink{} }
|
||||||
= case fileLikeSym s of
|
= case fileLikeSym s of
|
||||||
(True, _) -> (True, f)
|
(True, _) -> (True, f)
|
||||||
_ -> (False, f)
|
_ -> (False, f)
|
||||||
fileLikeSym f@SymLink{ sdest = RegFile{} } = (True, f)
|
fileLikeSym f@SymLink{ sdest = Just RegFile{} } = (True, f)
|
||||||
fileLikeSym f@SymLink{ sdest = BlockDev{} } = (True, f)
|
fileLikeSym f@SymLink{ sdest = Just BlockDev{} } = (True, f)
|
||||||
fileLikeSym f@SymLink{ sdest = CharDev{} } = (True, f)
|
fileLikeSym f@SymLink{ sdest = Just CharDev{} } = (True, f)
|
||||||
fileLikeSym f@SymLink{ sdest = NamedPipe{} } = (True, f)
|
fileLikeSym f@SymLink{ sdest = Just NamedPipe{} } = (True, f)
|
||||||
fileLikeSym f@SymLink{ sdest = Socket{} } = (True, f)
|
fileLikeSym f@SymLink{ sdest = Just Socket{} } = (True, f)
|
||||||
fileLikeSym f = (False, f)
|
fileLikeSym f = (False, f)
|
||||||
|
|
||||||
|
|
||||||
dirSym :: File FileInfo -> (Bool, File FileInfo)
|
dirSym :: File FileInfo -> (Bool, File FileInfo)
|
||||||
dirSym f@SymLink{ sdest = s@SymLink{} }
|
dirSym f@SymLink{ sdest = Just s@SymLink{} }
|
||||||
= case dirSym s of
|
= case dirSym s of
|
||||||
(True, _) -> (True, f)
|
(True, _) -> (True, f)
|
||||||
_ -> (False, f)
|
_ -> (False, f)
|
||||||
dirSym f@SymLink{ sdest = Dir{} } = (True, f)
|
dirSym f@SymLink{ sdest = Just Dir{} } = (True, f)
|
||||||
dirSym f = (False, f)
|
dirSym f = (False, f)
|
||||||
|
|
||||||
|
|
||||||
@ -306,8 +297,7 @@ instance Ord (File FileInfo) where
|
|||||||
readFile :: (Path Abs -> IO a)
|
readFile :: (Path Abs -> IO a)
|
||||||
-> Path Abs
|
-> Path Abs
|
||||||
-> IO (File a)
|
-> IO (File a)
|
||||||
readFile ff p =
|
readFile ff p = do
|
||||||
handleDT p $ do
|
|
||||||
fs <- PF.getSymbolicLinkStatus (P.toFilePath p)
|
fs <- PF.getSymbolicLinkStatus (P.toFilePath p)
|
||||||
fv <- ff p
|
fv <- ff p
|
||||||
constructFile fs fv p
|
constructFile fs fv p
|
||||||
@ -317,11 +307,12 @@ readFile ff p =
|
|||||||
-- symlink madness, we need to make sure we save the correct
|
-- symlink madness, we need to make sure we save the correct
|
||||||
-- File
|
-- File
|
||||||
x <- PF.readSymbolicLink (P.fromAbs p')
|
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
|
-- watch out, we call </> from 'filepath' here, but it is safe
|
||||||
let sfp = (P.fromAbs . P.dirname $ p') </> x
|
let sfp = (P.fromAbs . P.dirname $ p') </> x
|
||||||
rsfp <- realpath sfp
|
rsfp <- realpath sfp
|
||||||
readFile ff =<< P.parseAbs rsfp
|
f <- readFile ff =<< P.parseAbs rsfp
|
||||||
|
return $ Just f
|
||||||
return $ SymLink p' fv resolvedSyml x
|
return $ SymLink p' fv resolvedSyml x
|
||||||
| PF.isDirectory fs = return $ Dir p' fv
|
| PF.isDirectory fs = return $ Dir p' fv
|
||||||
| PF.isRegularFile fs = return $ RegFile p' fv
|
| PF.isRegularFile fs = return $ RegFile p' fv
|
||||||
@ -329,8 +320,7 @@ readFile ff p =
|
|||||||
| PF.isCharacterDevice fs = return $ CharDev p' fv
|
| PF.isCharacterDevice fs = return $ CharDev p' fv
|
||||||
| PF.isNamedPipe fs = return $ NamedPipe p' fv
|
| PF.isNamedPipe fs = return $ NamedPipe p' fv
|
||||||
| PF.isSocket fs = return $ Socket p' fv
|
| PF.isSocket fs = return $ Socket p' fv
|
||||||
| otherwise = return $ Failed p' (userError
|
| otherwise = ioError $ userError "Unknown filetype!"
|
||||||
"Unknown filetype!")
|
|
||||||
|
|
||||||
|
|
||||||
-- |Get the contents of a given directory and return them as a list
|
-- |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]
|
-> IO [File a]
|
||||||
readDirectoryContents ff p = do
|
readDirectoryContents ff p = do
|
||||||
files <- getDirsFiles p
|
files <- getDirsFiles p
|
||||||
fcs <- mapM (readFile ff) files
|
mapM (readFile ff) files
|
||||||
return fcs
|
|
||||||
|
|
||||||
|
|
||||||
-- |A variant of `readDirectoryContents` where the second argument
|
-- |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 ----
|
---- ORDERING AND EQUALITY ----
|
||||||
@ -402,11 +369,7 @@ failures = filter failed
|
|||||||
|
|
||||||
-- HELPER: a non-recursive comparison
|
-- HELPER: a non-recursive comparison
|
||||||
comparingConstr :: File FileInfo -> File FileInfo -> Ordering
|
comparingConstr :: File FileInfo -> File FileInfo -> Ordering
|
||||||
comparingConstr (Failed _ _) (DirOrSym _) = LT
|
|
||||||
comparingConstr (Failed _ _) (FileLikeOrSym _) = LT
|
|
||||||
comparingConstr (FileLikeOrSym _) (Failed _ _) = GT
|
|
||||||
comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT
|
comparingConstr (FileLikeOrSym _) (DirOrSym _) = GT
|
||||||
comparingConstr (DirOrSym _) (Failed _ _) = GT
|
|
||||||
comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT
|
comparingConstr (DirOrSym _) (FileLikeOrSym _) = LT
|
||||||
-- else compare on the names of constructors that are the same, without
|
-- else compare on the names of constructors that are the same, without
|
||||||
-- looking at the contents of Dir constructors:
|
-- 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: ----
|
---- SYMLINK HELPERS: ----
|
||||||
@ -522,7 +463,7 @@ rethrowFailed a = do
|
|||||||
--
|
--
|
||||||
-- When called on a non-symlink, returns False.
|
-- When called on a non-symlink, returns False.
|
||||||
isBrokenSymlink :: File FileInfo -> Bool
|
isBrokenSymlink :: File FileInfo -> Bool
|
||||||
isBrokenSymlink (SymLink _ _ Failed{} _) = True
|
isBrokenSymlink (SymLink _ _ Nothing _) = True
|
||||||
isBrokenSymlink _ = False
|
isBrokenSymlink _ = False
|
||||||
|
|
||||||
|
|
||||||
@ -563,7 +504,6 @@ packPermissions dt = fromFreeVar (pStr . fileMode) dt
|
|||||||
CharDev {} -> "c"
|
CharDev {} -> "c"
|
||||||
NamedPipe {} -> "p"
|
NamedPipe {} -> "p"
|
||||||
Socket {} -> "s"
|
Socket {} -> "s"
|
||||||
_ -> "?"
|
|
||||||
ownerModeStr = hasFmStr PF.ownerReadMode "r"
|
ownerModeStr = hasFmStr PF.ownerReadMode "r"
|
||||||
++ hasFmStr PF.ownerWriteMode "w"
|
++ hasFmStr PF.ownerWriteMode "w"
|
||||||
++ hasFmStr PF.ownerExecuteMode "x"
|
++ hasFmStr PF.ownerExecuteMode "x"
|
||||||
@ -588,7 +528,6 @@ packFileType file = case file of
|
|||||||
CharDev {} -> "Char Device"
|
CharDev {} -> "Char Device"
|
||||||
NamedPipe {} -> "Named Pipe"
|
NamedPipe {} -> "Named Pipe"
|
||||||
Socket {} -> "Socket"
|
Socket {} -> "Socket"
|
||||||
_ -> "Unknown"
|
|
||||||
|
|
||||||
|
|
||||||
packLinkDestination :: File a -> Maybe ByteString
|
packLinkDestination :: File a -> Maybe ByteString
|
||||||
@ -621,5 +560,4 @@ getFreeVar (BlockDev _ d) = Just d
|
|||||||
getFreeVar (CharDev _ d) = Just d
|
getFreeVar (CharDev _ d) = Just d
|
||||||
getFreeVar (NamedPipe _ d) = Just d
|
getFreeVar (NamedPipe _ d) = Just d
|
||||||
getFreeVar (Socket _ d) = Just d
|
getFreeVar (Socket _ d) = Just d
|
||||||
getFreeVar _ = Nothing
|
|
||||||
|
|
||||||
|
@ -52,7 +52,7 @@ main = do
|
|||||||
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
|
let mdir = fromMaybe (fromJust $ P.parseAbs "/")
|
||||||
(P.parseAbs . headDef "/" $ args)
|
(P.parseAbs . headDef "/" $ args)
|
||||||
|
|
||||||
file <- catchIOError (rethrowFailed $ readFile getFileInfo mdir) $
|
file <- catchIOError (readFile getFileInfo mdir) $
|
||||||
\_ -> readFile getFileInfo . fromJust $ P.parseAbs "/"
|
\_ -> readFile getFileInfo . fromJust $ P.parseAbs "/"
|
||||||
|
|
||||||
_ <- initGUI
|
_ <- initGUI
|
||||||
|
@ -301,7 +301,7 @@ refreshView :: MyGUI
|
|||||||
-> MyView
|
-> MyView
|
||||||
-> Item
|
-> Item
|
||||||
-> IO ()
|
-> IO ()
|
||||||
refreshView mygui myview SymLink { sdest = d@Dir{} } =
|
refreshView mygui myview SymLink { sdest = Just d@Dir{} } =
|
||||||
refreshView mygui myview d
|
refreshView mygui myview d
|
||||||
refreshView mygui myview item@Dir{} = do
|
refreshView mygui myview item@Dir{} = do
|
||||||
newRawModel <- fileListStore item myview
|
newRawModel <- fileListStore item myview
|
||||||
@ -351,7 +351,6 @@ constructView mygui myview = do
|
|||||||
dirtreePix FileLike{} = filePix
|
dirtreePix FileLike{} = filePix
|
||||||
dirtreePix DirSym{} = folderSymPix
|
dirtreePix DirSym{} = folderSymPix
|
||||||
dirtreePix FileLikeSym{} = fileSymPix
|
dirtreePix FileLikeSym{} = fileSymPix
|
||||||
dirtreePix Failed{} = errorPix
|
|
||||||
dirtreePix BrokenSymlink{} = errorPix
|
dirtreePix BrokenSymlink{} = errorPix
|
||||||
dirtreePix _ = errorPix
|
dirtreePix _ = errorPix
|
||||||
|
|
||||||
|
Loading…
Reference in New Issue
Block a user