LIB/GTK: refactor HSFM.FileSystem.Error to use Path type
This commit is contained in:
parent
51abfb1dce
commit
65595fa9c5
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
|
||||
@ -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.
|
||||
|
||||
Loading…
Reference in New Issue
Block a user