diff --git a/hsfm.cabal b/hsfm.cabal index b35e73b..e081d71 100644 --- a/hsfm.cabal +++ b/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 diff --git a/src/HSFM/FileSystem/FileOperations.hs b/src/HSFM/FileSystem/FileOperations.hs index 07c2de5..691e742 100644 --- a/src/HSFM/FileSystem/FileOperations.hs +++ b/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 + diff --git a/src/HSFM/GUI/Gtk/Callbacks.hs b/src/HSFM/GUI/Gtk/Callbacks.hs index e94151c..f83605a 100644 --- a/src/HSFM/GUI/Gtk/Callbacks.hs +++ b/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 - -- TODO: cm ignored - $ \cm -> do - void $ runFileOp (FMove $ Move s cdir) - popStatusbar mygui - writeTVarIO (operationBuffer mygui) None + withConfirmationDialog cmsg $ doFileOperation (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 - -- TODO: cm ignored - $ \cm -> void $ runFileOp (FCopy $ Copy s cdir) + withConfirmationDialog cmsg $ doFileOperation (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 diff --git a/src/HSFM/GUI/Gtk/Callbacks/Utils.hs b/src/HSFM/GUI/Gtk/Callbacks/Utils.hs new file mode 100644 index 0000000..7d1bfef --- /dev/null +++ b/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 + diff --git a/src/HSFM/GUI/Gtk/Data.hs b/src/HSFM/GUI/Gtk/Data.hs index 3d165f9..8607961 100644 --- a/src/HSFM/GUI/Gtk/Data.hs +++ b/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 diff --git a/src/HSFM/GUI/Gtk/Dialogs.hs b/src/HSFM/GUI/Gtk/Dialogs.hs index 48cce36..3849689 100644 --- a/src/HSFM/GUI/Gtk/Dialogs.hs +++ b/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 --- and returns 'DirCopyMode'. Default is always Strict, so this allows --- switching to Merge/Replace/Rename. -showCopyModeDialog :: IO (Maybe CopyMode) -showCopyModeDialog = do +fileCollisionDialog :: String -> IO (Maybe FCollisonMode) +fileCollisionDialog t = do chooserDialog <- messageDialogNew Nothing [DialogDestroyWithParent] MessageQuestion ButtonsNone - "Target exists, how to proceed?" - _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0) - _ <- dialogAddButton chooserDialog "Merge" (ResponseUser 1) - _ <- dialogAddButton chooserDialog "Replace" (ResponseUser 2) - _ <- dialogAddButton chooserDialog "Rename" (ResponseUser 3) + ("Target \"" ++ t ++ + "\" exists, how to proceed?") + _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0) + _ <- dialogAddButton chooserDialog "Overwrite" (ResponseUser 1) + _ <- 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 2 -> return (Just Replace) - ResponseUser 3 -> do + ResponseUser 1 -> return (Just Overwrite) + ResponseUser 2 -> return (Just OverwriteAll) + 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 --- or Renaming. -showRenameDialog :: IO (Maybe CopyMode) -showRenameDialog = do +renameDialog :: String -> IO (Maybe FCollisonMode) +renameDialog t = do chooserDialog <- messageDialogNew Nothing [DialogDestroyWithParent] MessageQuestion ButtonsNone - "Target exists, how to proceed?" - _ <- dialogAddButton chooserDialog "Cancel" (ResponseUser 0) - _ <- dialogAddButton chooserDialog "Rename" (ResponseUser 1) + ("Target \"" ++ t ++ + "\" exists, how to proceed?") + _ <- 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 diff --git a/src/HSFM/GUI/Gtk/MyGUI.hs b/src/HSFM/GUI/Gtk/MyGUI.hs index 5dbb044..ae330ff 100644 --- a/src/HSFM/GUI/Gtk/MyGUI.hs +++ b/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 (