hasufell/hsfm
1
1
Fork 0
Code Issues 33 Pull Requests Releases Wiki Activity

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

Browse Source 
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.
This commit is contained in:
Julian Ospald 2016-05-08 20:14:30 +02:00
parent 9c6cf51825
commit 3af8b36940
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
7 changed files with 182 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
hsfm.cabal
View File

@ -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

28
src/HSFM/FileSystem/FileOperations.hs
View File

@ -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

24
src/HSFM/GUI/Gtk/Callbacks.hs
View File

@ -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

120
src/HSFM/GUI/Gtk/Callbacks/Utils.hs Normal file
View File

@ -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

2
src/HSFM/GUI/Gtk/Data.hs
View File

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

76
src/HSFM/GUI/Gtk/Dialogs.hs
View File

@ -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

2
src/HSFM/GUI/Gtk/MyGUI.hs
View File

@ -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
(