LIB/GTK: refactor HSFM.FileSystem.Error to use Path type

src/HSFM/FileSystem/Errors.hs

@@ -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
+    when
-  , void
-  , when
-  )
-import Data.List
-  (
-    isPrefixOf
   )
 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.
+    --[ Path based functions ]--
-dirSanityThrow :: FilePath -> IO ()
+    ----------------------------
-dirSanityThrow fp = throwNotAbsolute fp >> throwDirDoesNotExist fp
 
 
-throwNotAbsolute :: FilePath -> IO ()
+throwFileDoesExist :: Path Abs -> IO ()
-throwNotAbsolute fp = unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
-
-
-throwFileDoesExist :: FilePath -> 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 ()
+throwFileDoesNotExist :: Path Abs -> IO ()
-throwDirDoesNotExist fp =
-  unlessM (doesDirectoryExist fp) (throw $ DirDoesNotExist fp)
-
-
-throwFileDoesNotExist :: FilePath -> IO ()
 throwFileDoesNotExist fp =
-  unlessM (doesFileExist fp) (throw $ FileDoesNotExist fp)
+  whenM (doesFileExist fp) (throw $ FileDoesExist $ P.fromAbs fp)
 
 
-throwSameFile :: FilePath -- ^ should be canonicalized
+throwDirDoesNotExist :: Path Abs -> IO ()
-              -> FilePath -- ^ should be canonicalized
+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
+throwDestinationInSource :: Path Abs -- ^ will be canonicalized
-                         -> FilePath -- ^ should be canonicalized
+                         -> Path Abs -- ^ will be canonicalized
                          -> IO ()
-throwDestinationInSource source dest =
+throwDestinationInSource source dest = do
-  when (source `isPrefixOf` dest) (throw $ DestinationInSource dest source)
+  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 ()
+-- |Checks if the given file exists and is not a directory. This follows
-throwIsSymlink fp =
+-- symlinks, but will return True if the symlink is broken.
-  whenM (PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp)
+doesFileExist :: Path Abs -> IO Bool
-        (throw $ IsSymlink fp)
+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

src/HSFM/FileSystem/FileOperations.hs

@@ -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
-    throwDestinationInSource fromp' destdirp'
+    throwSameFile 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
+    let from' = fullPath from
-        to'   = fullPathS to
+        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
+    let from' = fullPath from
-        to'   = P.fromAbs (fullPath to P.</> fn)
+        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
+  let fromf = fullPath af
-      tof   = P.fromAbs (anchor af P.</> fn)
+      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
+    delOld fp = do
-      to' <- HSFM.FileSystem.FileType.readFileWithFileInfo to
+      to' <- HSFM.FileSystem.FileType.readFileWithFileInfo fp
       unless (failed . file $ to') (easyDelete to')
 moveFile _ _ _ = throw $ InvalidOperation "wrong input type"
 

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -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
+  forM_ (P.parseAbs fp :: Maybe (Path Abs)) $ \fp' ->
-  exists <- (||) <$> doesDirectoryExist fp <*> doesFileExist fp
+      refreshView mygui myview (Just $ P.fromAbs fp')
-  -- TODO: more explicit error handling?
-  refreshView mygui myview (Just fp)
 
 
 -- |Supposed to be used with 'withRows'. Opens a file or directory.