GTK: adjust to new LIB API and refactor file error handling

This restructures large parts of the GUI-wise error handling code
and makes it more fine-grained, so the user can react appropriately
to exceptions.

hsfm.cabal

@@ -67,6 +67,7 @@ executable hsfm-gtk
   other-modules:
                        HSFM.GUI.Glib.GlibString
                        HSFM.GUI.Gtk.Callbacks
+                       HSFM.GUI.Gtk.Callbacks.Utils
                        HSFM.GUI.Gtk.Data
                        HSFM.GUI.Gtk.Dialogs
                        HSFM.GUI.Gtk.Errors

src/HSFM/FileSystem/FileOperations.hs

@@ -18,6 +18,7 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# OPTIONS_HADDOCK ignore-exports #-}
 
 
@@ -668,6 +669,33 @@ moveFile from to = do
     easyDelete from
 
 
+-- |Like `moveFile`, but overwrites the destination if it exists.
+--
+-- Does not follow symbolic links, but renames the symbolic link file.
+--
+-- Safety/reliability concerns:
+--
+--    * copy-delete fallback is inherently non-atomic
+--    * checks for destination file existence explicitly
+--
+-- Throws:
+--
+--     - `NoSuchThing` if source file does not exist
+--     - `PermissionDenied` if output directory cannot be written to
+--     - `PermissionDenied` if source directory cannot be opened
+--     - `SameFile` if destination and source are the same file (`FmIOException`)
+--
+-- Note: calls `rename` (but does not allow to rename over existing files)
+moveFileOverwrite :: Path Abs  -- ^ file to move
+                  -> Path Abs  -- ^ destination
+                  -> IO ()
+moveFileOverwrite from to = do
+  throwSameFile from to
+  exists <- (||) <$> doesFileExist to <*> doesDirectoryExist to
+  writable <- isWritable $ P.dirname to
+  when (exists && writable) (easyDelete to)
+  moveFile from to
+
 
 
 

src/HSFM/GUI/Gtk/Callbacks.hs

@@ -54,6 +54,8 @@ import HPath
 import HSFM.FileSystem.Errors
 import HSFM.FileSystem.FileOperations
 import HSFM.FileSystem.FileType
+import HSFM.FileSystem.UtilTypes
+import HSFM.GUI.Gtk.Callbacks.Utils
 import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.Dialogs
 import HSFM.GUI.Gtk.MyView
@@ -379,19 +381,14 @@ operationFinal mygui myview mitem = withErrorDialog $ do
       let cmsg = "Really move " ++ imsg s
                   ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
                   ++ "\"?"
-      withConfirmationDialog cmsg . withCopyModeDialog
+      withConfirmationDialog cmsg $ doFileOperation (FMove $ Move s cdir)
-      -- TODO: cm ignored
+      popStatusbar mygui
-        $ \cm -> do
+      writeTVarIO (operationBuffer mygui) None
-             void $ runFileOp (FMove $ Move s cdir)
-             popStatusbar mygui
-             writeTVarIO (operationBuffer mygui) None
     FCopy (PartialCopy s) -> do
       let cmsg = "Really copy " ++ imsg s
                  ++ " to \"" ++ P.fpToString (P.fromAbs cdir)
                  ++ "\"?"
-      withConfirmationDialog cmsg . withCopyModeDialog
+      withConfirmationDialog cmsg $ doFileOperation (FCopy $ Copy s cdir)
-      -- TODO: cm ignored
-        $ \cm -> void $ runFileOp (FCopy $ Copy s cdir)
     _ -> return ()
   where
     imsg s = case s of
@@ -495,15 +492,6 @@ upDir mygui myview = withErrorDialog $ do
   goDir mygui myview nv
 
 
--- |Helper that is invoked for any directory change operations.
-goDir :: MyGUI -> MyView -> Item -> IO ()
-goDir mygui myview item = do
-  cdir <- getCurrentDir myview
-  modifyTVarIO (history myview)
-    (\(p, _) -> (path cdir `addHistory` p, []))
-  refreshView' mygui myview item
-
-
 -- |Go "back" in the history.
 goHistoryPrev :: MyGUI -> MyView -> IO ()
 goHistoryPrev mygui myview = do

src/HSFM/GUI/Gtk/Callbacks/Utils.hs

@@ -0,0 +1,120 @@
+{--
+HSFM, a filemanager written in Haskell.
+Copyright (C) 2016 Julian Ospald
+
+This program is free software; you can redistribute it and/or
+modify it under the terms of the GNU General Public License
+version 2 as published by the Free Software Foundation.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301, USA.
+--}
+
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# OPTIONS_HADDOCK ignore-exports #-}
+
+module HSFM.GUI.Gtk.Callbacks.Utils where
+
+
+
+import Control.Monad
+  (
+    forM_
+  )
+import GHC.IO.Exception
+  (
+    IOErrorType(..)
+  )
+import qualified HPath as P
+import HSFM.FileSystem.Errors
+import HSFM.FileSystem.FileOperations
+import HSFM.FileSystem.FileType
+import HSFM.FileSystem.UtilTypes
+import HSFM.GUI.Gtk.Data
+import HSFM.GUI.Gtk.Dialogs
+import HSFM.GUI.Gtk.MyView
+import HSFM.GUI.Gtk.Utils
+import HSFM.Utils.IO
+  (
+    modifyTVarIO
+  )
+import Prelude hiding(readFile)
+import System.IO.Error
+  (
+    ioeGetErrorType
+  )
+import Control.Exception
+  (
+    catches
+  , throwIO
+  , IOException
+  , Handler(..)
+  )
+
+
+-- |Carries out a file operation with the appropriate error handling
+-- allowing the user to react to various exceptions with further input.
+doFileOperation :: FileOperation -> IO ()
+doFileOperation (FCopy (Copy (f':fs') to)) =
+  _doFileOperation (f':fs') to easyCopyOverwrite easyCopy
+    $ doFileOperation (FCopy $ Copy fs' to)
+doFileOperation (FMove (Move (f':fs') to)) =
+  _doFileOperation (f':fs') to moveFileOverwrite moveFile
+    $ doFileOperation (FMove $ Move fs' to)
+  where
+
+doFileOperation _ = return ()
+
+
+_doFileOperation :: [P.Path b1]
+                 -> P.Path P.Abs
+                 -> (P.Path b1 -> P.Path P.Abs -> IO b)
+                 -> (P.Path b1 -> P.Path P.Abs -> IO a)
+                 -> IO ()
+                 -> IO ()
+_doFileOperation [] _ _ _ _ = return ()
+_doFileOperation (f:fs) to mcOverwrite mc rest = do
+  toname <- P.basename f
+  let topath = to P.</> toname
+  catches (mc f topath >> rest)
+          [iohandler topath, fmiohandler topath]
+  where
+    iohandler topath =
+      Handler $ \ (ex :: IOException) ->
+                   if ioeGetErrorType ex == AlreadyExists
+                     then collisionAction fileCollisionDialog topath
+                     else throwIO ex
+    fmiohandler topath =
+      Handler $ \ (ex :: FmIOException) ->
+                   if isFileDoesExist ex || isDirDoesExist ex
+                     then collisionAction fileCollisionDialog topath
+                     else (if isSameFile ex
+                             then collisionAction renameDialog topath
+                             else throwIO ex)
+    collisionAction diag topath = do
+      mcm <- diag . P.fpToString . P.fromAbs $ topath
+      forM_ mcm $ \cm -> case cm of
+        Overwrite    -> mcOverwrite f topath >> rest
+        OverwriteAll -> forM_ (f:fs) $ \x -> do
+                          toname' <- P.basename x
+                          mcOverwrite x (to P.</> toname')
+        Skip         -> rest
+        Rename newn  -> mc f (to P.</> newn) >> rest
+        _            -> return ()
+
+
+-- |Helper that is invoked for any directory change operations.
+goDir :: MyGUI -> MyView -> Item -> IO ()
+goDir mygui myview item = do
+  cdir <- getCurrentDir myview
+  modifyTVarIO (history myview)
+    (\(p, _) -> (path cdir `addHistory` p, []))
+  refreshView' mygui myview item
+

src/HSFM/GUI/Gtk/Data.hs

@@ -35,8 +35,8 @@ import HPath
     Abs
   , Path
   )
-import HSFM.FileSystem.FileOperations
 import HSFM.FileSystem.FileType
+import HSFM.FileSystem.UtilTypes
 import System.INotify
   (
     INotify

src/HSFM/GUI/Gtk/Dialogs.hs

@@ -23,8 +23,7 @@ module HSFM.GUI.Gtk.Dialogs where
 
 import Control.Exception
   (
-    catch
+    displayException
-  , displayException
   , throw
   , IOException
   , catches
@@ -63,6 +62,7 @@ import Graphics.UI.Gtk
 import qualified HPath as P
 import HSFM.FileSystem.Errors
 import HSFM.FileSystem.FileType
+import HSFM.FileSystem.UtilTypes
 import HSFM.GUI.Glib.GlibString()
 import HSFM.GUI.Gtk.Data
 import HSFM.GUI.Gtk.Errors
@@ -73,13 +73,7 @@ import Paths_hsfm
 
 
 
--- |Copy modes.
+
-data CopyMode = Strict  -- ^ fail if the target already exists
-              | Merge   -- ^ overwrite files if necessary, for files, this
-                        --   is the same as Replace
-              | Replace -- ^ remove targets before copying, this is
-                        --   only useful if the target is a directorty
-              | Rename (P.Path P.Fn)
 
 
 
@@ -117,27 +111,27 @@ showConfirmationDialog str = do
     _           -> return False
 
 
--- |Asks the user which directory copy mode he wants via dialog popup
+fileCollisionDialog :: String -> IO (Maybe FCollisonMode)
--- and returns 'DirCopyMode'. Default is always Strict, so this allows
+fileCollisionDialog t = do
--- switching to Merge/Replace/Rename.
-showCopyModeDialog :: IO (Maybe CopyMode)
-showCopyModeDialog = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
-                                    "Target exists, how to proceed?"
+                                    ("Target \"" ++ t ++
-  _ <- dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
+                                     "\" exists, how to proceed?")
-  _ <- dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
+  _ <- dialogAddButton chooserDialog "Cancel"        (ResponseUser 0)
-  _ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2)
+  _ <- dialogAddButton chooserDialog "Overwrite"     (ResponseUser 1)
-  _ <- dialogAddButton chooserDialog "Rename"  (ResponseUser 3)
+  _ <- dialogAddButton chooserDialog "Overwrite all" (ResponseUser 2)
+  _ <- dialogAddButton chooserDialog "Skip"          (ResponseUser 3)
+  _ <- dialogAddButton chooserDialog "Rename"        (ResponseUser 4)
   rID <- dialogRun chooserDialog
   widgetDestroy chooserDialog
   case rID of
     ResponseUser 0 -> return Nothing
-    ResponseUser 1 -> return (Just Merge)
+    ResponseUser 1 -> return (Just Overwrite)
-    ResponseUser 2 -> return (Just Replace)
+    ResponseUser 2 -> return (Just OverwriteAll)
-    ResponseUser 3 -> do
+    ResponseUser 3 -> return (Just Skip)
+    ResponseUser 4 -> do
       mfn   <- textInputDialog "Enter new name"
       forM mfn $ \fn -> do
         pfn <- P.parseFn (P.userStringToFP fn)
@@ -145,22 +139,23 @@ showCopyModeDialog = do
     _              -> throw  UnknownDialogButton
 
 
--- |Stipped version of `showCopyModeDialog` that only allows cancelling
+renameDialog :: String -> IO (Maybe FCollisonMode)
--- or Renaming.
+renameDialog t = do
-showRenameDialog :: IO (Maybe CopyMode)
-showRenameDialog = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
-                                    "Target exists, how to proceed?"
+                                    ("Target \"" ++ t ++
-  _ <- dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
+                                     "\" exists, how to proceed?")
-  _ <- dialogAddButton chooserDialog "Rename"  (ResponseUser 1)
+  _ <- dialogAddButton chooserDialog "Cancel"        (ResponseUser 0)
+  _ <- dialogAddButton chooserDialog "Skip"          (ResponseUser 1)
+  _ <- dialogAddButton chooserDialog "Rename"        (ResponseUser 2)
   rID <- dialogRun chooserDialog
   widgetDestroy chooserDialog
   case rID of
     ResponseUser 0 -> return Nothing
-    ResponseUser 1 -> do
+    ResponseUser 1 -> return (Just Skip)
+    ResponseUser 2 -> do
       mfn   <- textInputDialog "Enter new name"
       forM mfn $ \fn -> do
         pfn <- P.parseFn (P.userStringToFP fn)
@@ -168,27 +163,6 @@ showRenameDialog = do
     _              -> throw  UnknownDialogButton
 
 
--- |Attempts to run the given function with the `Strict` copy mode.
--- If that raises a `FileDoesExist` or `DirDoesExist`, then it prompts
--- the user for action via `showCopyModeDialog` and then carries out
--- the given function again.
-withCopyModeDialog :: (CopyMode -> IO ()) -> IO ()
-withCopyModeDialog fa =
-  catch (fa Strict) $ \e ->
-    case e of
-      FileDoesExist _ -> doIt showCopyModeDialog
-      DirDoesExist  _ -> doIt showCopyModeDialog
-      SameFile _ _    -> doIt showRenameDialog
-      e'              -> throw e'
-  where
-    doIt getCm = do
-      mcm <- getCm
-      case mcm of
-        (Just Strict) -> return () -- don't try again
-        (Just cm)     -> fa cm
-        Nothing       -> return ()
-
-
 -- |Shows the about dialog from the help menu.
 showAboutDialog :: IO ()
 showAboutDialog = do

src/HSFM/GUI/Gtk/MyGUI.hs

@@ -27,7 +27,7 @@ import Control.Concurrent.STM
     newTVarIO
   )
 import Graphics.UI.Gtk
-import HSFM.FileSystem.FileOperations
+import HSFM.FileSystem.UtilTypes
 import HSFM.GUI.Gtk.Data
 import Paths_hsfm
   (