LIB/GTK: refactor File API and add copyFile

src/Data/DirTree/Zipper.hs

@@ -39,6 +39,8 @@ import qualified Data.List as DL
 -- are the breadcrumbs.
 type DTZipper a b = (DirTree a b, [DirTree a b])
 
+type DTInfoZipper = DTZipper DirTreeInfo DirTreeInfo
+
 
 -- |The base zipper of a tree with empty crumbs element.
 baseZipper :: DirTree a b -> DTZipper a b

src/GUI/Gtk/Gui.hs

@@ -135,14 +135,15 @@ data FMSettings = MkFMSettings {
 -- because we might want to have multiple views.
 data MyView = MkMyView {
   -- |raw model with unsorted data
-    rawModel :: TVar (ListStore (DTZipper DirTreeInfo DirTreeInfo))
+    rawModel :: TVar (ListStore DTInfoZipper)
   -- |sorted proxy model
-  , sortedModel :: TVar (TypedTreeModelSort
+  , sortedModel :: TVar (TypedTreeModelSort DTInfoZipper)
-                          (DTZipper DirTreeInfo DirTreeInfo))
   -- |filtered proxy model
-  , filteredModel :: TVar (TypedTreeModelFilter
+  , filteredModel :: TVar (TypedTreeModelFilter DTInfoZipper)
-                            (DTZipper DirTreeInfo DirTreeInfo))
+  , fsState :: TVar DTInfoZipper
-  , fsState :: TVar (DTZipper DirTreeInfo DirTreeInfo)
+  , operationBuffer :: TVar (Either
+                         (DTInfoZipper -> FileOperation DirTreeInfo DirTreeInfo)
+                         (FileOperation DirTreeInfo DirTreeInfo))
 }
 
 
@@ -169,6 +170,14 @@ setCallbacks mygui myview = do
   _ <- treeView mygui `on` rowActivated $ (\_ _ -> withRow mygui myview open)
   _ <- menubarFileQuit mygui `on` menuItemActivated $ mainQuit
   _ <- urlBar mygui `on` entryActivated $ urlGoTo mygui myview
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "c"       <- fmap glibToString eventKeyName
+    liftIO $ withRow mygui myview copyInit
+  _ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
+    [Control] <- eventModifier
+    "v"       <- fmap glibToString eventKeyName
+    liftIO $ copyFinal mygui myview
   return ()
 
 
@@ -188,7 +197,7 @@ urlGoTo mygui myview = do
 -- |Gets the currently selected row of the treeView, if any.
 getSelectedRow :: MyGUI
                -> MyView
-               -> IO (Maybe (DTZipper DirTreeInfo DirTreeInfo))
+               -> IO (Maybe DTInfoZipper)
 getSelectedRow mygui myview = do
   (tp, _)        <- treeViewGetCursor $ treeView mygui
   rawModel'      <- readTVarIO $ rawModel myview
@@ -206,7 +215,7 @@ getSelectedRow mygui myview = do
 -- If there is no row selected, does nothing.
 withRow :: MyGUI
         -> MyView
-        -> (   DTZipper DirTreeInfo DirTreeInfo
+        -> (   DTInfoZipper
             -> MyGUI
             -> MyView
             -> IO ()) -- ^ action to carry out
@@ -217,32 +226,65 @@ withRow mygui myview io = do
 
 
 -- |Supposed to be used with `withRow`. Opens a file or directory.
-open :: DTZipper DirTreeInfo DirTreeInfo -> MyGUI -> MyView -> IO ()
+open :: DTInfoZipper -> MyGUI -> MyView -> IO ()
 open row mygui myview = case row of
   (Dir {}, _) ->
     refreshTreeView' mygui myview row
   dz@(File {}, _) ->
-    withErrorDialog $ openFile (getFullPath dz)
+    withErrorDialog $ openFile dz
   _ -> return ()
 
 
 -- |Supposed to be used with `withRow`. Deletes a file or directory.
-del :: DTZipper DirTreeInfo DirTreeInfo -> MyGUI -> MyView -> IO ()
+del :: DTInfoZipper -> MyGUI -> MyView -> IO ()
 del row mygui myview = case row of
   dz@(Dir {}, _)   -> do
     let fp   = getFullPath dz
         cmsg = "Really delete directory \"" ++ fp ++ "\"?"
     withConfirmationDialog cmsg
-      $ withErrorDialog (deleteDir fp
+      $ withErrorDialog (deleteDir dz
                           >> refreshTreeView mygui myview Nothing)
   dz@(File {}, _) -> do
     let fp   = getFullPath dz
         cmsg = "Really delete file \"" ++ fp ++ "\"?"
     withConfirmationDialog cmsg
-      $ withErrorDialog (deleteFile fp
+      $ withErrorDialog (deleteFile dz
                           >> refreshTreeView mygui myview Nothing)
 
 
+-- |Supposed to be used with `withRow`. Initializes a file copy operation.
+copyInit :: DTInfoZipper -> MyGUI -> MyView -> IO ()
+copyInit row mygui myview = case row of
+  dz@(File {}, _) -> do
+    print "blah1"
+    writeTVarIO (operationBuffer myview) (Left $ FCopy dz)
+    return ()
+  _ -> return ()
+
+
+-- |Finalizes a file copy operation.
+copyFinal :: MyGUI -> MyView -> IO ()
+copyFinal mygui myview = do
+  mOp <- readTVarIO (operationBuffer myview)
+  op <- case mOp of
+    Left pOp -> do
+      curDir <- readTVarIO (fsState myview)
+      case pOp curDir of
+        op@(FCopy _ _) -> return op
+        _              -> return None
+    Right op@(FCopy _ _) -> return op
+    _ -> return None
+  doCopy op
+  where
+    doCopy op@(FCopy from to) = do
+      let cmsg = "Really copy file \"" ++ getFullPath from
+                 ++ "\"" ++ " to \"" ++ getFullPath to ++ "\"?"
+      withConfirmationDialog cmsg
+        $ withErrorDialog
+          (runFileOp op >> refreshTreeView mygui myview Nothing)
+    doCopy _ = return ()
+
+
 -- |Go up one directory and visualize it in the treeView.
 upDir :: MyGUI -> MyView -> IO ()
 upDir mygui myview = do
@@ -257,9 +299,9 @@ upDir mygui myview = do
 -- into the GTK+ data structures.
 --
 -- This also updates the TVar `fsState` inside the given view.
-fileListStore :: DTZipper DirTreeInfo DirTreeInfo  -- ^ current dir
+fileListStore :: DTInfoZipper  -- ^ current dir
               -> MyView
-              -> IO (ListStore (DTZipper DirTreeInfo DirTreeInfo))
+              -> IO (ListStore DTInfoZipper)
 fileListStore dtz myview = do
   writeTVarIO (fsState myview) dtz
   listStoreNew (goAllDown dtz)
@@ -297,7 +339,7 @@ refreshTreeView mygui myview mfp = do
 -- This also updates the TVar `rawModel`.
 refreshTreeView' :: MyGUI
                  -> MyView
-                 -> DTZipper DirTreeInfo DirTreeInfo
+                 -> DTInfoZipper
                  -> IO ()
 refreshTreeView' mygui myview dtz = do
   newRawModel  <- fileListStore dtz myview
@@ -433,6 +475,8 @@ startMainWindow = do
 
   fsState <- readPath' "/" >>= newTVarIO
 
+  operationBuffer <- newTVarIO (Right None)
+
   builder <- builderNew
   builderAddFromFile builder "data/Gtk/builder.xml"
 

src/IO/Error.hs

@@ -7,17 +7,75 @@ module IO.Error where
 import Control.Exception
 import Control.Monad
   (
-    mzero
+    unless
-  , MonadPlus
+  , void
+  , when
   )
 import Data.Typeable
+import System.Directory
+  (
+    doesDirectoryExist
+  , doesFileExist
+  )
+import System.FilePath
+  (
+    equalFilePath
+  , isAbsolute
+  , takeFileName
+  )
 
 
 data FmIOException = FileDoesNotExist String
                    | PathNotAbsolute String
                    | FileNotExecutable String
+                   | SameFile String String
+                   | NotAFile String
+                   | NotADir String
   deriving (Show, Typeable)
 
 
 instance Exception FmIOException
 
+
+-- Throws an exception if the filepath is not absolute
+-- or the file does not exist.
+fileSanityThrow :: FilePath -> IO ()
+fileSanityThrow fp = do
+  throwNotAbsolute fp
+  throwFileDoesNotExist fp
+
+
+-- Throws an exception if the filepath is not absolute
+-- or the dir does not exist.
+dirSanityThrow :: FilePath -> IO ()
+dirSanityThrow fp = do
+  throwNotAbsolute fp
+  throwDirDoesNotExist fp
+
+
+throwNotAbsolute :: FilePath -> IO ()
+throwNotAbsolute fp = unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
+
+
+throwDirDoesExist :: FilePath -> IO ()
+throwDirDoesExist fp = do
+  exists <- doesDirectoryExist fp
+  when exists (throw $ FileDoesNotExist fp)
+
+
+throwDirDoesNotExist :: FilePath -> IO ()
+throwDirDoesNotExist fp = do
+  exists <- doesDirectoryExist fp
+  unless exists (throw $ FileDoesNotExist fp)
+
+
+throwFileDoesNotExist :: FilePath -> IO ()
+throwFileDoesNotExist fp = do
+  exists <- doesFileExist fp
+  unless exists (throw $ FileDoesNotExist fp)
+
+
+throwSameFile :: FilePath -- ^ should be canonicalized
+              -> FilePath -- ^ should be canonicalized
+              -> IO ()
+throwSameFile fp1 fp2 = when (equalFilePath fp1 fp2) (throw $ SameFile fp1 fp2)

src/IO/File.hs

@@ -11,11 +11,15 @@ import Control.Monad
   (
     unless
   , void
+  , when
   )
+import Data.DirTree
+import Data.DirTree.Zipper
 import IO.Error
 import System.Directory
   (
-    doesDirectoryExist
+    canonicalizePath
+  , doesDirectoryExist
   , doesFileExist
   , executable
   , getPermissions
@@ -24,7 +28,11 @@ import System.Directory
   )
 import System.FilePath
   (
-    isAbsolute
+    equalFilePath
+  , isAbsolute
+  , takeFileName
+  , takeDirectory
+  , (</>)
   )
 import System.Process
   (
@@ -32,12 +40,72 @@ import System.Process
   , ProcessHandle
   )
 
+import qualified System.Directory as SD
 
-data FileOperation = Copy
+
-                   | Move
+-- TODO: modify the DTZipper directly after file operations!?
-                   | Delete
+
-                   | Open
+
-                   | Execute
+-- |Data type describing an actual file operation that can be
+-- carried out via `doFile`. Useful to build up a list of operations
+-- or delay operations.
+data FileOperation a b = FCopy (DTZipper a b) (DTZipper a b)
+                       | FMove FilePath FilePath
+                       | FDelete (DTZipper a b)
+                       | FOpen (DTZipper a b)
+                       | FExecute (DTZipper a b) [String]
+                       | None
+
+
+runFileOp :: FileOperation a b -> IO ()
+runFileOp (FCopy from to)    = copyFileToDir from to
+runFileOp (FDelete fp)       = easyDelete fp
+runFileOp (FOpen fp)         = void $ openFile fp
+runFileOp (FExecute fp args) = void $ executeFile fp args
+runFileOp _                  = return ()
+
+
+-- |Copies the given file.
+--
+-- This will throw an exception if any of the filepaths are not absolute
+-- and an exception if the source file does not exist.
+--
+-- If the destination file already exists, it will be replaced.
+-- TODO: don't permit copying file A to file A
+copyFile :: DTZipper a b  -- ^ source file
+         -> FilePath      -- ^ destination file
+         -> IO ()
+copyFile from@(File name _, _) to = do
+  let fp = getFullPath from
+  fileSanityThrow fp
+  throwNotAbsolute to
+  throwDirDoesExist to
+  toC <- canonicalizePath (takeDirectory to)
+  let to' = toC </> takeFileName to
+  throwSameFile fp to'
+  SD.copyFile fp to'
+
+
+-- |Copies the given file to the given dir with the same filename.
+--
+-- This is just a convenience wrapper around `copyFile`.
+copyFileToDir :: DTZipper a b  -- ^ source file
+              -> DTZipper a b  -- ^ destination
+              -> IO ()
+copyFileToDir from@(File name _, _) to@(Dir {}, _) = do
+  let dp = getFullPath to
+  dirSanityThrow dp
+  copyFile from (dp </> name)
+copyFileToDir from (Dir {}, _) = throw $ NotAFile (getFullPath from)
+copyFileToDir _    to          = throw $ NotADir (getFullPath to)
+
+
+-- |Copies the given file, regardless of whether the destination is
+-- a file or a directory. This is a wrapper around `copyFile` and
+-- `copyFileToDir`.
+easyCopyFile :: DTZipper a b -> Either FilePath (DTZipper a b) -> IO ()
+easyCopyFile from (Left to)  = copyFile from to
+easyCopyFile from (Right to) = copyFileToDir from to
 
 
 -- |Deletes the given file.
@@ -47,10 +115,12 @@ data FileOperation = Copy
 --
 -- It also throws exceptions from `removeFile`.
 -- TODO: threaded, shouldn't block the GUI
-deleteFile :: FilePath -> IO ()
+deleteFile :: DTZipper a b -> IO ()
-deleteFile fp = do
+deleteFile dtz@(File {}, _) = do
+  let fp = getFullPath dtz
   fileSanityThrow fp
   removeFile fp
+deleteFile dtz = throw $ NotAFile (getFullPath dtz)
 
 
 -- |Deletes the given directory.
@@ -60,21 +130,31 @@ deleteFile fp = do
 --
 -- It also throws exceptions from `removeDirectory`.
 -- TODO: threaded, shouldn't block the GUI
-deleteDir :: FilePath -> IO ()
+deleteDir :: DTZipper a b -> IO ()
-deleteDir fp = do
+deleteDir dtz@(Dir {}, _) = do
+  let fp = getFullPath dtz
   dirSanityThrow fp
   removeDirectory fp
+deleteDir dtz = throw $ NotADir (getFullPath dtz)
+
+
+-- |Deletes a file or directory, whatever it may be.
+easyDelete :: DTZipper a b -> IO ()
+easyDelete dtz@(File {}, _) = deleteFile dtz
+easyDelete dtz@(Dir {}, _)  = deleteDir dtz
 
 
 -- |Opens a file appropriately by invoking xdg-open.
 --
 -- This will throw an exception if the filepath is not absolute
 -- or the file does not exist.
-openFile :: FilePath          -- ^ absolute path to file
+openFile :: DTZipper a b
          -> IO ProcessHandle
-openFile fp = do
+openFile dtz@(File {}, _) = do
+  let fp = getFullPath dtz
   fileSanityThrow fp
   spawnProcess "xdg-open" [fp]
+openFile dtz = throw $ NotAFile (getFullPath dtz)
 
 
 -- |Executes a program with the given arguments.
@@ -82,29 +162,14 @@ openFile fp = do
 -- This will throw an exception if the filepath is not absolute
 -- or the file does not exist. It will also throw an exception
 -- if the file is not executable.
-executeFile :: FilePath          -- ^ absolute path to program
+executeFile :: DTZipper a b      -- ^ program
             -> [String]          -- ^ arguments
             -> IO ProcessHandle
-executeFile fp args = do
+executeFile dtz@(File {}, _) args = do
+  let fp = getFullPath dtz
   fileSanityThrow fp
   p <- getPermissions fp
   unless (executable p) (throw $ FileNotExecutable fp)
   spawnProcess fp args
+executeFile dtz  _ = throw $ NotAFile (getFullPath dtz)
 
-
--- Throws an exception if the filepath is not absolute
--- or the file does not exist.
-fileSanityThrow :: FilePath -> IO ()
-fileSanityThrow fp = do
-  unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
-  exists <- doesFileExist fp
-  unless exists (throw $ FileDoesNotExist fp)
-
-
--- Throws an exception if the filepath is not absolute
--- or the dir does not exist.
-dirSanityThrow :: FilePath -> IO ()
-dirSanityThrow fp = do
-  unless (isAbsolute fp) (throw $ PathNotAbsolute fp)
-  exists <- doesDirectoryExist fp
-  unless exists (throw $ FileDoesNotExist fp)