LIB: add copy modes
TODO: integrate these more nicely with runFileOp
This commit is contained in:
parent
34c6223c25
commit
ffe8037160
@ -20,14 +20,17 @@ import Data.Foldable
|
|||||||
for_
|
for_
|
||||||
)
|
)
|
||||||
import IO.Error
|
import IO.Error
|
||||||
|
import IO.Utils
|
||||||
import System.Directory
|
import System.Directory
|
||||||
(
|
(
|
||||||
canonicalizePath
|
canonicalizePath
|
||||||
|
, createDirectory
|
||||||
, createDirectoryIfMissing
|
, createDirectoryIfMissing
|
||||||
, doesDirectoryExist
|
, doesDirectoryExist
|
||||||
, doesFileExist
|
, doesFileExist
|
||||||
, executable
|
, executable
|
||||||
, removeDirectory
|
, removeDirectory
|
||||||
|
, removeDirectoryRecursive
|
||||||
, removeFile
|
, removeFile
|
||||||
)
|
)
|
||||||
import System.FilePath
|
import System.FilePath
|
||||||
@ -67,23 +70,30 @@ data FileOperation = FCopy DTInfoZipper DTInfoZipper
|
|||||||
| None
|
| None
|
||||||
|
|
||||||
|
|
||||||
|
data DirCopyMode = Strict
|
||||||
|
| Merge
|
||||||
|
| Replace
|
||||||
|
|
||||||
|
|
||||||
runFileOp :: FileOperation -> IO ()
|
runFileOp :: FileOperation -> IO ()
|
||||||
runFileOp (FCopy from@(File {}, _) to) = copyFileToDir from to
|
runFileOp (FCopy from@(File {}, _) to) = copyFileToDir from to
|
||||||
runFileOp (FCopy from@(Dir {}, _) to) = copyDir from to
|
runFileOp (FCopy from@(Dir {}, _) to) = copyDir Merge from to
|
||||||
runFileOp (FDelete fp) = easyDelete fp
|
runFileOp (FDelete fp) = easyDelete fp
|
||||||
runFileOp (FOpen fp) = void $ openFile fp
|
runFileOp (FOpen fp) = void $ openFile fp
|
||||||
runFileOp (FExecute fp args) = void $ executeFile fp args
|
runFileOp (FExecute fp args) = void $ executeFile fp args
|
||||||
runFileOp _ = return ()
|
runFileOp _ = return ()
|
||||||
|
|
||||||
|
|
||||||
-- TODO: copy modes
|
|
||||||
-- TODO: allow renaming
|
-- TODO: allow renaming
|
||||||
copyDir :: DTInfoZipper -- ^ source dir
|
-- |Copies a directory to the given destination. If the target directory
|
||||||
|
-- already exists, performs a semi-defined merge, overwriting already
|
||||||
|
-- existing files.
|
||||||
|
copyDir :: DirCopyMode
|
||||||
|
-> DTInfoZipper -- ^ source dir
|
||||||
-> DTInfoZipper -- ^ destination dir
|
-> DTInfoZipper -- ^ destination dir
|
||||||
-> IO ()
|
-> IO ()
|
||||||
copyDir from@(Dir fn _ _, _) to@(Dir {}, _) = do
|
copyDir cm from@(Dir fn _ _, _) to@(Dir {}, _) = do
|
||||||
let fromp = getFullPath from
|
let fromp = getFullPath from
|
||||||
top = getFullPath to
|
top = getFullPath to
|
||||||
destdir = getFullPath to </> fn
|
destdir = getFullPath to </> fn
|
||||||
@ -92,7 +102,17 @@ copyDir from@(Dir fn _ _, _) to@(Dir {}, _) = do
|
|||||||
dirSanityThrow top
|
dirSanityThrow top
|
||||||
throwDestinationInSource fromp top
|
throwDestinationInSource fromp top
|
||||||
|
|
||||||
|
-- what to do with target directory
|
||||||
|
case cm of
|
||||||
|
Merge ->
|
||||||
createDirectoryIfMissing False destdir
|
createDirectoryIfMissing False destdir
|
||||||
|
Strict -> do
|
||||||
|
throwDirDoesExist destdir
|
||||||
|
createDirectory destdir
|
||||||
|
Replace -> do
|
||||||
|
whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir)
|
||||||
|
createDirectory destdir
|
||||||
|
|
||||||
newDest <- zipLazy mkDirInfo mkFileInfo destdir
|
newDest <- zipLazy mkDirInfo mkFileInfo destdir
|
||||||
|
|
||||||
for_ (goAllDown from) $ \f ->
|
for_ (goAllDown from) $ \f ->
|
||||||
@ -101,17 +121,23 @@ copyDir from@(Dir fn _ _, _) to@(Dir {}, _) = do
|
|||||||
-- recreate symlink
|
-- recreate symlink
|
||||||
sz@(Dir { name = n, dir = (DirInfo { sym = True }) }, _) -> do
|
sz@(Dir { name = n, dir = (DirInfo { sym = True }) }, _) -> do
|
||||||
let sympoint = getFullPath newDest </> n
|
let sympoint = getFullPath newDest </> n
|
||||||
|
|
||||||
-- delete old file/dir to be able to create symlink
|
-- delete old file/dir to be able to create symlink
|
||||||
|
case cm of
|
||||||
|
Merge ->
|
||||||
for_ (goDown n newDest) $ \odtz ->
|
for_ (goDown n newDest) $ \odtz ->
|
||||||
easyDelete odtz
|
easyDelete odtz
|
||||||
|
_ -> return ()
|
||||||
|
|
||||||
symname <- readSymbolicLink (getFullPath sz)
|
symname <- readSymbolicLink (getFullPath sz)
|
||||||
createSymbolicLink symname sympoint
|
createSymbolicLink symname sympoint
|
||||||
sz@(Dir {}, _) ->
|
sz@(Dir {}, _) ->
|
||||||
copyDir sz newDest
|
copyDir cm sz newDest
|
||||||
sz@(File {}, _) ->
|
sz@(File {}, _) ->
|
||||||
copyFileToDir sz newDest
|
copyFileToDir sz newDest
|
||||||
copyDir from@(File _ _, _) _ = throw $ NotADir (getFullPath from)
|
|
||||||
copyDir _ to@(File _ _, _) = throw $ NotADir (getFullPath to)
|
copyDir _ from@(File _ _, _) _ = throw $ NotADir (getFullPath from)
|
||||||
|
copyDir _ _ to@(File _ _, _) = throw $ NotADir (getFullPath to)
|
||||||
|
|
||||||
|
|
||||||
-- |Copies the given file.
|
-- |Copies the given file.
|
||||||
@ -189,6 +215,20 @@ deleteDir dtz@(Dir {}, _) = do
|
|||||||
deleteDir dtz = throw $ NotADir (getFullPath dtz)
|
deleteDir dtz = throw $ NotADir (getFullPath dtz)
|
||||||
|
|
||||||
|
|
||||||
|
-- |Deletes the given directory recursively. Does not work on symlinks.
|
||||||
|
--
|
||||||
|
-- This will throw an exception if the filepath is not absolute
|
||||||
|
-- or the directory does not exist.
|
||||||
|
--
|
||||||
|
-- It also throws exceptions from `removeDirectoryRecursive`.
|
||||||
|
deleteDirRecursive :: DTInfoZipper -> IO ()
|
||||||
|
deleteDirRecursive dtz@(Dir {}, _) = do
|
||||||
|
let fp = getFullPath dtz
|
||||||
|
dirSanityThrow fp
|
||||||
|
removeDirectoryRecursive fp
|
||||||
|
deleteDirRecursive dtz = throw $ NotADir (getFullPath dtz)
|
||||||
|
|
||||||
|
|
||||||
-- |Deletes a file or directory, whatever it may be.
|
-- |Deletes a file or directory, whatever it may be.
|
||||||
easyDelete :: DTInfoZipper -> IO ()
|
easyDelete :: DTInfoZipper -> IO ()
|
||||||
easyDelete dtz@(File {}, _) = deleteFile dtz
|
easyDelete dtz@(File {}, _) = deleteFile dtz
|
||||||
|
@ -13,6 +13,10 @@ import Control.Concurrent.STM.TVar
|
|||||||
, modifyTVar
|
, modifyTVar
|
||||||
, TVar
|
, TVar
|
||||||
)
|
)
|
||||||
|
import Control.Monad
|
||||||
|
(
|
||||||
|
when
|
||||||
|
)
|
||||||
|
|
||||||
|
|
||||||
writeTVarIO :: TVar a -> a -> IO ()
|
writeTVarIO :: TVar a -> a -> IO ()
|
||||||
@ -21,3 +25,7 @@ writeTVarIO tvar val = atomically $ writeTVar tvar val
|
|||||||
|
|
||||||
modifyTVarIO :: TVar a -> (a -> a) -> IO ()
|
modifyTVarIO :: TVar a -> (a -> a) -> IO ()
|
||||||
modifyTVarIO tvar f = atomically $ modifyTVar tvar f
|
modifyTVarIO tvar f = atomically $ modifyTVar tvar f
|
||||||
|
|
||||||
|
|
||||||
|
whenM :: Monad m => m Bool -> m () -> m ()
|
||||||
|
whenM mb a = mb >>= (`when` a)
|
||||||
|
Loading…
Reference in New Issue
Block a user