LIB/GTK: refactor File API and add copyFile

src/IO/Error.hs

@@ -7,17 +7,75 @@ module IO.Error where
 import Control.Exception
 import Control.Monad
   (
-    mzero
-  , MonadPlus
+    unless
+  , 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
-                   | Delete
-                   | Open
-                   | Execute
+
+-- TODO: modify the DTZipper directly after file operations!?
+
+
+-- |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 fp = do
+deleteFile :: DTZipper a b -> IO ()
+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 fp = do
+deleteDir :: DTZipper a b -> IO ()
+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)