LIB/GTK: generalize DirCopyMode to CopyMode and improve user confirmation

src/GUI/Gtk/Callbacks.hs

@@ -277,15 +277,14 @@ operationFinal mygui myview = withErrorDialog $ do
     FMove (MP1 s) -> do
       let cmsg = "Really move \"" ++ fullPath s
                   ++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
-      withConfirmationDialog cmsg
+      withConfirmationDialog cmsg . withCopyModeDialog
-        $ void $ runFileOp (FMove . MC s $ cdir)
+        $ \cm -> void $ runFileOp (FMove . MC s cdir $ cm)
       return ()
     FCopy (CP1 s) -> do
       let cmsg = "Really copy \"" ++ fullPath s
                  ++ "\"" ++ " to \"" ++ fullPath cdir ++ "\"?"
-      cm <- showCopyModeChooserDialog
+      withConfirmationDialog cmsg . withCopyModeDialog
-      withConfirmationDialog cmsg
+        $ \cm -> void $ runFileOp (FCopy . CC s cdir $ cm)
-        $ void $ runFileOp (FCopy . CC s cdir $ cm)
       return ()
     _ -> return ()
 

src/GUI/Gtk/Dialogs.hs

@@ -27,7 +27,8 @@ import Control.Applicative
   )
 import Control.Exception
   (
-    try
+    catch
+  , try
   , SomeException
   )
 import Control.Monad
@@ -59,6 +60,7 @@ import Distribution.Verbosity
   )
 import Graphics.UI.Gtk
 import GUI.Gtk.Data
+import IO.Error
 import IO.File
 
 
@@ -100,14 +102,14 @@ showConfirmationDialog str = do
 
 -- |Asks the user which directory copy mode he wants via dialog popup
 -- and returns 'DirCopyMode'.
-showCopyModeChooserDialog :: IO DirCopyMode
+showCopyModeDialog :: IO CopyMode
-showCopyModeChooserDialog = do
+showCopyModeDialog = do
   chooserDialog <- messageDialogNew Nothing
                                     [DialogDestroyWithParent]
                                     MessageQuestion
                                     ButtonsNone
-                                    "Choose the copy mode"
+                                    "Target exists, how to proceed?"
-  dialogAddButton chooserDialog "Strict"  (ResponseUser 0)
+  dialogAddButton chooserDialog "Cancel"  (ResponseUser 0)
   dialogAddButton chooserDialog "Merge"   (ResponseUser 1)
   dialogAddButton chooserDialog "Replace" (ResponseUser 2)
   rID <- dialogRun chooserDialog
@@ -118,6 +120,23 @@ showCopyModeChooserDialog = do
     ResponseUser 2 -> return Replace
 
 
+-- |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
+      DirDoesExist  _ -> doIt
+  where
+    doIt = do cm <- showCopyModeDialog
+              case cm of
+                Strict -> return () -- don't try again
+                _      -> fa cm
+
+
 -- |Shows the about dialog from the help menu.
 showAboutDialog :: IO ()
 showAboutDialog = do

src/IO/File.hs

@@ -37,6 +37,10 @@ import Control.Exception
   (
     throw
   )
+import Control.Monad
+  (
+    unless
+  )
 import Data.DirTree
 import Data.Foldable
   (
@@ -118,7 +122,7 @@ data Copy = CP1 (AnchoredFile FileInfo)
                 (AnchoredFile FileInfo)
           | CC  (AnchoredFile FileInfo)
                 (AnchoredFile FileInfo)
-                DirCopyMode
+                CopyMode
 
 
 -- |Data type describing partial or complete file move operation.
@@ -126,12 +130,15 @@ data Copy = CP1 (AnchoredFile FileInfo)
 data Move = MP1 (AnchoredFile FileInfo)
           | MC  (AnchoredFile FileInfo)
                 (AnchoredFile FileInfo)
+                CopyMode
 
 
--- |Directory copy modes.
+-- |Copy modes.
-data DirCopyMode = Strict  -- ^ fail if the target directory already exists
+data CopyMode = Strict  -- ^ fail if the target already exists
-                 | Merge   -- ^ overwrite files if necessary
+              | Merge   -- ^ overwrite files if necessary, for files, this
-                 | Replace -- ^ remove target directory before copying
+                        --   is the same as Replace
+              | Replace -- ^ remove targets before copying, this is
+                        --   only useful if the target is a directorty
 
 
 -- |Run a given FileOperation. If the FileOperation is partial, it will
@@ -139,7 +146,7 @@ data DirCopyMode = Strict  -- ^ fail if the target directory already exists
 runFileOp :: FileOperation -> IO (Maybe FileOperation)
 runFileOp (FCopy (CC from to cm)) = easyCopy cm from to >> return Nothing
 runFileOp (FCopy fo)              = return              $ Just $ FCopy fo
-runFileOp (FMove (MC from to))    = moveFile from to    >> return Nothing
+runFileOp (FMove (MC from to cm)) = moveFile cm from to >> return Nothing
 runFileOp (FMove fo)              = return              $ Just $ FMove fo
 runFileOp (FDelete fp)            = easyDelete fp       >> return Nothing
 runFileOp (FOpen fp)              = openFile fp         >> return Nothing
@@ -155,7 +162,7 @@ runFileOp (FExecute fp args)      = executeFile fp args >> return Nothing
 -- TODO: allow renaming
 -- |Copies a directory to the given destination with the specified
 -- `DirCopyMode`. Excludes symlinks.
-copyDir :: DirCopyMode
+copyDir :: CopyMode
         -> AnchoredFile FileInfo  -- ^ source dir
         -> AnchoredFile FileInfo  -- ^ destination dir
         -> IO ()
@@ -177,9 +184,9 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
 
     for_ contents $ \f ->
       case f of
-        (_ :/ SymLink {})  -> recreateSymlink f destdir
+        (_ :/ SymLink {})  -> recreateSymlink cm f destdir
         (_ :/ Dir {})      -> copyDir cm f destdir
-        (_ :/ RegFile {})  -> copyFileToDir f destdir
+        (_ :/ RegFile {})  -> copyFileToDir Replace f destdir
         _                  -> return ()
   where
     createDestdir destdir fmode =
@@ -194,37 +201,38 @@ copyDir cm from@(_ :/ Dir fromn (FileInfo { fileMode = fmode }))
           whenM (doesDirectoryExist destdir)
                 (deleteDirRecursive =<< Data.DirTree.readFile destdir)
           createDirectory destdir fmode
-    recreateSymlink' f destdir = do
-      let destfilep = fullPath destdir </> (name . file $ f)
-      destfile <- Data.DirTree.readFile destfilep
-
-      _ <- case cm of
-        -- delete old file/dir to be able to create symlink
-        Merge -> easyDelete destfile
-        _     -> return ()
-
-      recreateSymlink f destdir
 copyDir _ _ _ = throw $ InvalidOperation "wrong input type"
 
 
 -- |Recreate a symlink.
-recreateSymlink :: AnchoredFile FileInfo  -- ^ the old symlink file
+recreateSymlink :: CopyMode
+                -> AnchoredFile FileInfo  -- ^ the old symlink file
                 -> AnchoredFile FileInfo  -- ^ destination dir of the
                                           --   new symlink file
                 -> IO ()
-recreateSymlink AFileInvFN _ = throw InvalidFileName
+recreateSymlink _ AFileInvFN _ = throw InvalidFileName
-recreateSymlink _ AFileInvFN = throw InvalidFileName
+recreateSymlink _ _ AFileInvFN = throw InvalidFileName
-recreateSymlink symf@(_ :/ SymLink {})
+recreateSymlink cm    symf@(_ :/ SymLink {})
                    symdest@(_ :/ Dir {})
   = do
-    symname <- readSymbolicLink (fullPath symf)
+    sympoint <- readSymbolicLink (fullPath symf)
-    createSymbolicLink symname (fullPath symdest </> (name . file $ symf))
+    let symname = fullPath symdest </> (name . file $ symf)
-recreateSymlink _ _ = throw $ InvalidOperation "wrong input type"
+    case cm of
+      Merge   -> delOld symname
+      Replace -> delOld symname
+      _       -> return ()
+    createSymbolicLink sympoint symname
+  where
+    delOld symname = do
+      f <- Data.DirTree.readFile symname
+      unless (failed . file $ f)
+             (easyDelete f)
+recreateSymlink _ _ _ = throw $ InvalidOperation "wrong input type"
 
 
 -- |TODO: handle EAGAIN exception for non-blocking IO
 -- |Low-level function to copy a given file to the given path. The fileMode
--- is preserved.
+-- is preserved. The file is always overwritten if accessible.
 copyFile' :: FilePath -> FilePath -> IO ()
 copyFile' from to = do
   fromFstatus <- getSymbolicLinkStatus from
@@ -235,52 +243,55 @@ copyFile' from to = do
   BS.writeFile to fromContent
 
 
--- |Copies the given file to the given file destination.
+-- |Copies the given file to the given file destination, overwriting it.
 -- Excludes symlinks.
-copyFile :: AnchoredFile FileInfo  -- ^ source file
+overwriteFile :: AnchoredFile FileInfo  -- ^ source file
               -> AnchoredFile FileInfo  -- ^ destination file
               -> IO ()
-copyFile AFileInvFN _ = throw InvalidFileName
+overwriteFile AFileInvFN _ = throw InvalidFileName
-copyFile _ AFileInvFN = throw InvalidFileName
+overwriteFile _ AFileInvFN = throw InvalidFileName
-copyFile (_ :/ SymLink {}) _ = return ()
+overwriteFile from@(_ :/ RegFile {})
-copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do
+                to@(_ :/ RegFile {})
+  = do
     let from' = fullPath from
         to'   = fullPath to
     throwSameFile from' to'
     copyFile' from' to'
-copyFile _ _ = throw $ InvalidOperation "wrong input type"
+overwriteFile _ _ = throw $ InvalidOperation "wrong input type"
 
 
 -- |Copies the given file to the given dir with the same filename.
 -- Excludes symlinks.
-copyFileToDir :: AnchoredFile FileInfo
+copyFileToDir :: CopyMode
+              -> AnchoredFile FileInfo
               -> AnchoredFile FileInfo
               -> IO ()
-copyFileToDir AFileInvFN _ = throw InvalidFileName
+copyFileToDir _ AFileInvFN _ = throw InvalidFileName
-copyFileToDir _ AFileInvFN = throw InvalidFileName
+copyFileToDir _ _ AFileInvFN = throw InvalidFileName
-copyFileToDir (_ :/ SymLink {}) _ = return ()
+copyFileToDir cm from@(_ :/ RegFile fn _)
-copyFileToDir from@(_ :/ RegFile fn _)
+                   to@(_ :/ Dir {})
-                to@(_ :/ Dir {}) =
+  = do
-  do
     let from' = fullPath from
         to'   = fullPath to </> fn
+    case cm of
+      Strict -> throwFileDoesExist to'
+      _      -> return ()
     copyFile' from' to'
-copyFileToDir _ _ = throw $ InvalidOperation "wrong input type"
+copyFileToDir _ _ _ = throw $ InvalidOperation "wrong input type"
 
 
 -- |Copies a file, directory or symlink. In case of a symlink, it is just
 -- recreated, even if it points to a directory.
-easyCopy :: DirCopyMode
+easyCopy :: CopyMode
          -> AnchoredFile FileInfo
          -> AnchoredFile FileInfo
          -> IO ()
-easyCopy _ from@(_ :/ SymLink {}) to@(_ :/ Dir {}) = recreateSymlink from to
+easyCopy cm from@(_ :/ SymLink {})
-easyCopy _ from@(_ :/ RegFile fn _)
               to@(_ :/ Dir {})
-  = copyFileToDir from to
+  = recreateSymlink cm from to
-easyCopy _ from@(_ :/ RegFile fn _)
+easyCopy cm from@(_ :/ RegFile fn _)
-             to@(_ :/ RegFile {})
+              to@(_ :/ Dir {})
-  = copyFile from to
+  = copyFileToDir cm from to
 easyCopy cm from@(_ :/ Dir fn _)
               to@(_ :/ Dir {})
   = copyDir cm from to
@@ -306,7 +317,6 @@ deleteSymlink _ = throw $ InvalidOperation "wrong input type"
 -- |Deletes the given file, never symlinks.
 deleteFile :: AnchoredFile FileInfo -> IO ()
 deleteFile AFileInvFN = throw InvalidFileName
-deleteFile   (_ :/ SymLink {}) = return ()
 deleteFile f@(_ :/ RegFile {})
   = removeLink (fullPath f)
 deleteFile _ = throw $ InvalidOperation "wrong input type"
@@ -315,7 +325,6 @@ deleteFile _ = throw $ InvalidOperation "wrong input type"
 -- |Deletes the given directory, never symlinks.
 deleteDir :: AnchoredFile FileInfo -> IO ()
 deleteDir AFileInvFN = throw InvalidFileName
-deleteDir   (_ :/ SymLink {}) = return ()
 deleteDir f@(_ :/ Dir {})
   = removeDirectory (fullPath f)
 deleteDir _ = throw $ InvalidOperation "wrong input type"
@@ -411,7 +420,6 @@ createDir _ _ = throw $ InvalidOperation "wrong input type"
 renameFile :: AnchoredFile FileInfo -> FileName -> IO ()
 renameFile AFileInvFN _ = throw InvalidFileName
 renameFile _ InvFN      = throw InvalidFileName
-renameFile (_ :/ Failed {}) _ = return ()
 renameFile af (ValFN fn) = do
   let fromf = fullPath af
       tof   = anchor af </> fn
@@ -422,20 +430,28 @@ renameFile _ _ = throw $ InvalidOperation "wrong input type"
 
 
 -- |Move a given file to the given target directory.
-moveFile :: AnchoredFile FileInfo -- ^ file to move
+moveFile :: CopyMode
+         -> AnchoredFile FileInfo -- ^ file to move
          -> AnchoredFile FileInfo -- ^ base target directory
          -> IO ()
-moveFile AFileInvFN _ = throw InvalidFileName
+moveFile _ AFileInvFN _ = throw InvalidFileName
-moveFile _ AFileInvFN = throw InvalidFileName
+moveFile _ _ AFileInvFN = throw InvalidFileName
-moveFile from to@(_ :/ Dir {}) = do
+moveFile cm from to@(_ :/ Dir {}) = do
   let from' = fullPath from
       to'   = fullPath to </> (name . file $ from)
-  throwFileDoesExist to'
+  case cm of
+    Strict  -> throwFileDoesExist to'
+    Merge   -> delOld to'
+    Replace -> delOld to'
   throwSameFile from' to'
   catchErrno eXDEV (rename from' to') $ do
     easyCopy Strict from to
     easyDelete from
-moveFile _ _ = throw $ InvalidOperation "wrong input type"
+  where
+    delOld to = do
+      to' <- Data.DirTree.readFile to
+      unless (failed . file $ to') (easyDelete to')
+moveFile _ _ _ = throw $ InvalidOperation "wrong input type"