LIB/GTK: use AnchoredFile in IO.File
What's the point of having it anyway if we don't?
This commit is contained in:
parent
06151a3a08
commit
2486d83260
@ -251,14 +251,13 @@ readFileWith :: (FilePath -> IO a)
|
||||
-> FilePath
|
||||
-> IO (AnchoredFile a b)
|
||||
readFileWith fd ff fp = do
|
||||
cfp <- canonicalizePath' fp
|
||||
let fn = topDir cfp
|
||||
bd = baseDir cfp
|
||||
file <- handleDT fn $ do
|
||||
isFile <- doesFileExist cfp
|
||||
let fn = topDir fp
|
||||
bd = baseDir fp
|
||||
file <- handleDT (topDir fp) $ do
|
||||
isFile <- doesFileExist fp
|
||||
if isFile
|
||||
then RegFile fn <$> ff cfp
|
||||
else Dir fn <$> fd cfp
|
||||
then RegFile fn <$> ff fp
|
||||
else Dir fn <$> fd fp
|
||||
return (bd :/ file)
|
||||
|
||||
|
||||
@ -267,19 +266,29 @@ readFile fp = readFileWith getFileInfo getFileInfo =<< canonicalizePath' fp
|
||||
|
||||
|
||||
-- |Build a list of AnchoredFile, given the path to a directory, filling
|
||||
-- the free variables via `getFileInfo`.
|
||||
-- the free variables via `getFileInfo`. This includes the "." and ".."
|
||||
-- directories.
|
||||
readDirectory :: FilePath -> IO [AnchoredFile FileInfo FileInfo]
|
||||
readDirectory fp = readDirectoryWith getFileInfo getFileInfo
|
||||
readDirectory fp = readDirectoryWith getAllDirsFiles getFileInfo getFileInfo
|
||||
=<< canonicalizePath' fp
|
||||
|
||||
|
||||
-- |Build a list of AnchoredFile, given the path to a directory, filling
|
||||
-- the free variables via `getFileInfo`. This excludes the "." and ".."
|
||||
-- directories.
|
||||
readDirectory' :: FilePath -> IO [AnchoredFile FileInfo FileInfo]
|
||||
readDirectory' fp = readDirectoryWith getDirsFiles getFileInfo getFileInfo
|
||||
=<< canonicalizePath' fp
|
||||
|
||||
|
||||
-- | same as readDirectory but allows us to, for example, use
|
||||
-- ByteString.readFile to return a tree of ByteStrings.
|
||||
readDirectoryWith :: (FilePath -> IO a)
|
||||
readDirectoryWith :: (FilePath -> IO [FilePath])
|
||||
-> (FilePath -> IO a)
|
||||
-> (FilePath -> IO b)
|
||||
-> FilePath
|
||||
-> IO [AnchoredFile a b]
|
||||
readDirectoryWith fd ff p = buildWith' buildAtOnce' fd ff
|
||||
readDirectoryWith getfiles fd ff p = buildWith' (buildAtOnce' getfiles) fd ff
|
||||
=<< canonicalizePath' p
|
||||
|
||||
|
||||
@ -314,12 +323,11 @@ buildWith' bf' fd ff p =
|
||||
|
||||
|
||||
-- IO function passed to our builder and finally executed here:
|
||||
buildAtOnce' :: Builder a b
|
||||
buildAtOnce' fd ff p = do
|
||||
cfp <- canonicalizePath' p
|
||||
contents <- getAllDirsFiles cfp
|
||||
buildAtOnce' :: (FilePath -> IO [FilePath]) -> Builder a b
|
||||
buildAtOnce' getfiles fd ff fp = do
|
||||
contents <- getfiles fp
|
||||
for contents $ \n -> handleDT n $ do
|
||||
let subf = cfp </> n
|
||||
let subf = fp </> n
|
||||
do isFile <- doesFileExist subf
|
||||
if isFile
|
||||
then RegFile n <$> ff subf
|
||||
@ -327,7 +335,6 @@ buildAtOnce' fd ff p = do
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------
|
||||
--[ UTILITIES ]--
|
||||
-----------------
|
||||
|
||||
@ -14,6 +14,10 @@ import Control.Concurrent.STM
|
||||
, newTVarIO
|
||||
, readTVarIO
|
||||
)
|
||||
import Control.Monad
|
||||
(
|
||||
void
|
||||
)
|
||||
import Control.Monad.IO.Class
|
||||
(
|
||||
liftIO
|
||||
@ -63,10 +67,10 @@ setCallbacks mygui myview = do
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Control] <- eventModifier
|
||||
"h" <- fmap glibToString eventKeyName
|
||||
mcdir <- liftIO $ getCwdFromFirstRow myview
|
||||
mcdir <- liftIO $ getFirstRow myview
|
||||
liftIO $ modifyTVarIO (settings mygui)
|
||||
(\x -> x { showHidden = not . showHidden $ x})
|
||||
>> refreshTreeView mygui myview (Just mcdir)
|
||||
>> refreshTreeView' mygui myview mcdir
|
||||
_ <- treeView mygui `on` keyPressEvent $ tryEvent $ do
|
||||
[Alt] <- eventModifier
|
||||
"Up" <- fmap glibToString eventKeyName
|
||||
@ -106,45 +110,16 @@ open row mygui myview =
|
||||
r@(_ :/ Dir _ _) -> do
|
||||
nv <- Data.DirTree.readFile $ fullPath r
|
||||
refreshTreeView' mygui myview nv
|
||||
r@(_ :/ RegFile _ _) ->
|
||||
withErrorDialog $ openFile $ fullPath r
|
||||
_ -> return ()
|
||||
r ->
|
||||
withErrorDialog $ openFile r
|
||||
|
||||
|
||||
-- |Supposed to be used with 'withRow'. Deletes a file or directory.
|
||||
del :: Row -> MyGUI -> MyView -> IO ()
|
||||
del row mygui myview =
|
||||
case row of
|
||||
r@(_ :/ Dir { dir = FileInfo { isSymbolicLink = True } }) ->
|
||||
delSym r
|
||||
r@(_ :/ RegFile { regFile = FileInfo { isSymbolicLink = True } }) ->
|
||||
delSym r
|
||||
r@(_ :/ Dir _ _) -> do
|
||||
let fp = fullPath r
|
||||
subADT <- readDirectory fp
|
||||
let cmsg = "Really delete directory \"" ++ fp ++ "\"?"
|
||||
cmsg2 = "Directory \"" ++ fp ++
|
||||
"\" is not empty! Delete all contents?"
|
||||
withConfirmationDialog cmsg $
|
||||
if null subADT
|
||||
then withErrorDialog (deleteDir fp
|
||||
>> refreshTreeView mygui myview Nothing)
|
||||
else withConfirmationDialog cmsg2 $ withErrorDialog
|
||||
(deleteDirRecursive fp
|
||||
>> refreshTreeView mygui myview Nothing)
|
||||
r@(_ :/ RegFile _ _) -> do
|
||||
let fp = fullPath r
|
||||
cmsg = "Really delete file \"" ++ fp ++ "\"?"
|
||||
withConfirmationDialog cmsg
|
||||
$ withErrorDialog (deleteFile fp
|
||||
>> refreshTreeView mygui myview Nothing)
|
||||
where
|
||||
delSym r = do
|
||||
let fp = fullPath r
|
||||
cmsg = "Really delete symlink \"" ++ fp ++ "\"?"
|
||||
withConfirmationDialog cmsg
|
||||
$ withErrorDialog (deleteSymlink fp
|
||||
>> refreshTreeView mygui myview Nothing)
|
||||
del row mygui myview = do
|
||||
let cmsg = "Really delete \"" ++ fullPath row ++ "\"?"
|
||||
withConfirmationDialog cmsg . withErrorDialog
|
||||
$ easyDelete row >> refreshTreeView mygui myview Nothing
|
||||
|
||||
|
||||
-- |Supposed to be used with 'withRow'. Initializes a file copy operation.
|
||||
@ -154,7 +129,7 @@ del row mygui myview =
|
||||
-- * 'operationBuffer' writes
|
||||
copyInit :: Row -> MyGUI -> MyView -> IO ()
|
||||
copyInit row mygui myview =
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ fullPath row)
|
||||
writeTVarIO (operationBuffer myview) (FCopy . CP1 $ row)
|
||||
|
||||
|
||||
-- |Finalizes a file copy operation.
|
||||
@ -165,17 +140,18 @@ copyInit row mygui myview =
|
||||
copyFinal :: MyGUI -> MyView -> IO ()
|
||||
copyFinal mygui myview = do
|
||||
op <- readTVarIO (operationBuffer myview)
|
||||
mcdir <- getCwdFromFirstRow myview
|
||||
mcdir <- getFirstRow myview
|
||||
case op of
|
||||
FCopy (CP1 source) -> do
|
||||
let dest = mcdir
|
||||
isFile <- doesFileExist source
|
||||
let cmsg = "Really copy file \"" ++ source
|
||||
++ "\"" ++ " to \"" ++ dest ++ "\"?"
|
||||
withConfirmationDialog cmsg $ do
|
||||
copyMode <- if isFile then return Strict else showCopyModeChooserDialog
|
||||
withErrorDialog ((runFileOp . FCopy . CC source dest $ copyMode)
|
||||
FCopy (CP1 s) -> do
|
||||
dest <- goUp mcdir
|
||||
print dest
|
||||
print s
|
||||
let cmsg = "Really copy \"" ++ fullPath s
|
||||
++ "\"" ++ " to \"" ++ fullPath dest ++ "\"?"
|
||||
withConfirmationDialog cmsg . withErrorDialog
|
||||
$ (runFileOp (FCopy . CC s dest $ Strict)
|
||||
>> refreshTreeView mygui myview Nothing)
|
||||
return ()
|
||||
_ -> return ()
|
||||
|
||||
|
||||
@ -187,8 +163,8 @@ copyFinal mygui myview = do
|
||||
-- * 'sortedModel' reads
|
||||
upDir :: MyGUI -> MyView -> IO ()
|
||||
upDir mygui myview = do
|
||||
mcdir <- getCwdFromFirstRow myview
|
||||
mcdir <- getFirstRow myview
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
sortedModel' <- readTVarIO $ sortedModel myview
|
||||
nv <- goUp' mcdir
|
||||
nv <- goUp =<< goUp mcdir
|
||||
refreshTreeView' mygui myview nv
|
||||
|
||||
@ -99,13 +99,12 @@ fileListStore dt myview = do
|
||||
-- Interaction with mutable references:
|
||||
--
|
||||
-- * 'rawModel' reads
|
||||
getCwdFromFirstRow :: MyView
|
||||
-> IO FilePath
|
||||
getCwdFromFirstRow myview = do
|
||||
getFirstRow :: MyView
|
||||
-> IO (AnchoredFile FileInfo FileInfo)
|
||||
getFirstRow myview = do
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
iter <- fromJust <$> treeModelGetIterFirst rawModel'
|
||||
af <- treeModelGetRow rawModel' iter
|
||||
return $ anchor af
|
||||
treeModelGetRow rawModel' iter
|
||||
|
||||
|
||||
-- |Re-reads the current directory or the given one and updates the TreeView.
|
||||
@ -123,8 +122,8 @@ refreshTreeView :: MyGUI
|
||||
-> Maybe FilePath
|
||||
-> IO ()
|
||||
refreshTreeView mygui myview mfp = do
|
||||
mcdir <- getCwdFromFirstRow myview
|
||||
let fp = fromMaybe mcdir mfp
|
||||
mcdir <- getFirstRow myview
|
||||
let fp = fromMaybe (anchor mcdir) mfp
|
||||
|
||||
-- TODO catch exceptions
|
||||
dirSanityThrow fp
|
||||
@ -170,10 +169,10 @@ constructTreeView mygui myview = do
|
||||
cMD' = cMD mygui
|
||||
render' = renderTxt mygui
|
||||
|
||||
mcdir <- getCwdFromFirstRow myview
|
||||
mcdir <- getFirstRow myview
|
||||
|
||||
-- update urlBar
|
||||
entrySetText (urlBar mygui) mcdir
|
||||
entrySetText (urlBar mygui) (anchor mcdir)
|
||||
|
||||
rawModel' <- readTVarIO $ rawModel myview
|
||||
|
||||
|
||||
350
src/IO/File.hs
350
src/IO/File.hs
@ -77,23 +77,27 @@ import qualified System.Posix.Files as PF
|
||||
-- or delay operations.
|
||||
data FileOperation = FCopy Copy
|
||||
| FMove Move
|
||||
| FDelete FilePath
|
||||
| FOpen FilePath
|
||||
| FExecute FilePath [String]
|
||||
| FDelete (AnchoredFile FileInfo FileInfo)
|
||||
| FOpen (AnchoredFile FileInfo FileInfo)
|
||||
| FExecute (AnchoredFile FileInfo FileInfo) [String]
|
||||
| None
|
||||
|
||||
|
||||
-- |Data type describing partial or complete file copy operation.
|
||||
-- CC stands for a complete operation and can be used for `runFileOp`.
|
||||
data Copy = CP1 FilePath
|
||||
| CP2 FilePath FilePath
|
||||
| CC FilePath FilePath DirCopyMode
|
||||
data Copy = CP1 (AnchoredFile FileInfo FileInfo)
|
||||
| CP2 (AnchoredFile FileInfo FileInfo)
|
||||
(AnchoredFile FileInfo FileInfo)
|
||||
| CC (AnchoredFile FileInfo FileInfo)
|
||||
(AnchoredFile FileInfo FileInfo)
|
||||
DirCopyMode
|
||||
|
||||
|
||||
-- |Data type describing partial or complete file move operation.
|
||||
-- MC stands for a complete operation and can be used for `runFileOp`.
|
||||
data Move = MP1 FilePath
|
||||
| MC FilePath FilePath
|
||||
data Move = MP1 (AnchoredFile FileInfo FileInfo)
|
||||
| MC (AnchoredFile FileInfo FileInfo)
|
||||
(AnchoredFile FileInfo FileInfo)
|
||||
|
||||
|
||||
-- |Directory copy modes.
|
||||
@ -142,34 +146,36 @@ runFileOp _ = return Nothing
|
||||
-- `removeDirectoryRecursive`, `recreateSymlink`, `copyDir`,
|
||||
-- `copyFileToDir`, `getDirectoryContents` throws
|
||||
copyDir :: DirCopyMode
|
||||
-> FilePath -- ^ source dir
|
||||
-> FilePath -- ^ destination dir
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ source dir
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ destination dir
|
||||
-> IO ()
|
||||
copyDir cm from' to' = do
|
||||
from <- canonicalizePath' from'
|
||||
to <- canonicalizePath' to'
|
||||
onSymlinkOr from (copyFileToDir from to) (go from to)
|
||||
copyDir cm from@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) _
|
||||
= return ()
|
||||
copyDir cm from@(_ :/ Dir fromn _)
|
||||
to@(_ :/ Dir {})
|
||||
= do
|
||||
let fromp = fullPath from
|
||||
top = fullPath to
|
||||
destdirp = fullPath to </> fromn
|
||||
print destdirp
|
||||
throwDestinationInSource fromp destdirp
|
||||
throwSameFile fromp destdirp
|
||||
|
||||
createDestdir destdirp
|
||||
destdir <- Data.DirTree.readFile destdirp
|
||||
|
||||
contents <- readDirectory' (fullPath from)
|
||||
|
||||
for_ contents $ \f ->
|
||||
case f of
|
||||
(_ :/ Dir _ FileInfo { isSymbolicLink = True }) ->
|
||||
recreateSymlink f destdir
|
||||
(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) ->
|
||||
recreateSymlink f destdir
|
||||
(_ :/ Dir {}) -> copyDir cm f destdir
|
||||
(_ :/ RegFile {}) -> copyFileToDir f destdir
|
||||
_ -> return ()
|
||||
where
|
||||
go from to = do
|
||||
let fn = takeFileName from
|
||||
destdir = to </> fn
|
||||
|
||||
dirSanityThrow from
|
||||
dirSanityThrow to
|
||||
throwDestinationInSource from to
|
||||
throwSameFile from destdir
|
||||
|
||||
createDestdir destdir
|
||||
|
||||
contents <- getDirsFiles from
|
||||
|
||||
for_ contents $ \f -> do
|
||||
let ffn = from </> f
|
||||
fs <- PF.getSymbolicLinkStatus ffn
|
||||
case (PF.isSymbolicLink fs, PF.isDirectory fs) of
|
||||
(True, _) -> recreateSymlink' destdir f ffn
|
||||
(_, True) -> copyDir cm ffn destdir
|
||||
(_, _) -> copyFileToDir ffn destdir
|
||||
createDestdir destdir =
|
||||
case cm of
|
||||
Merge ->
|
||||
@ -180,31 +186,38 @@ copyDir cm from' to' = do
|
||||
Replace -> do
|
||||
whenM (doesDirectoryExist destdir) (removeDirectoryRecursive destdir)
|
||||
createDirectory destdir
|
||||
recreateSymlink' destdir n f = do
|
||||
let sympoint = destdir </> n
|
||||
recreateSymlink' f destdir = do
|
||||
let destfilep = fullPath destdir </> (name . file $ f)
|
||||
destfile <- Data.DirTree.readFile destfilep
|
||||
|
||||
_ <- case cm of
|
||||
-- delete old file/dir to be able to create symlink
|
||||
Merge -> easyDelete sympoint
|
||||
Merge -> easyDelete destfile
|
||||
_ -> return ()
|
||||
|
||||
recreateSymlink f sympoint
|
||||
|
||||
recreateSymlink f destdir
|
||||
copyDir _ _ _ = return ()
|
||||
|
||||
|
||||
-- |Recreate a symlink.
|
||||
recreateSymlink :: FilePath -- ^ the old symlink file
|
||||
-> FilePath -- ^ destination of the new symlink file
|
||||
recreateSymlink :: AnchoredFile FileInfo FileInfo -- ^ the old symlink file
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ destination dir of the
|
||||
-- new symlink file
|
||||
-> IO ()
|
||||
recreateSymlink symf' symdest' = do
|
||||
symf <- canonicalizePath' symf'
|
||||
symname <- readSymbolicLink symf
|
||||
symdestd <- canonicalizePath' (baseDir symdest')
|
||||
let symdest = symdestd </> takeFileName symdest'
|
||||
createSymbolicLink symname symdest
|
||||
recreateSymlink symf@(_ :/ RegFile n FileInfo { isSymbolicLink = True })
|
||||
symdest@(_ :/ Dir {})
|
||||
= do
|
||||
symname <- readSymbolicLink (fullPath symf)
|
||||
createSymbolicLink symname (fullPath symdest </> n)
|
||||
recreateSymlink symf@(_ :/ Dir n FileInfo { isSymbolicLink = True })
|
||||
symdest@(_ :/ Dir {})
|
||||
= do
|
||||
symname <- readSymbolicLink (fullPath symf)
|
||||
createSymbolicLink symname (fullPath symdest </> n)
|
||||
recreateSymlink _ _ = return ()
|
||||
|
||||
|
||||
-- |Copies the given file. This can also be called on symlinks.
|
||||
-- |Copies the given file to the given file destination. Not symlinks.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
@ -215,44 +228,57 @@ recreateSymlink symf' symdest' = do
|
||||
-- * `PathNotAbsolute` if either of the filepaths are not absolute
|
||||
-- * `SameFile` if the source and destination files are the same
|
||||
-- * anything that `canonicalizePath` or `System.Directory.copyFile` throws
|
||||
copyFile :: FilePath -- ^ source file
|
||||
-> FilePath -- ^ destination file
|
||||
copyFile :: AnchoredFile FileInfo FileInfo -- ^ source file
|
||||
-> AnchoredFile FileInfo FileInfo -- ^ destination file
|
||||
-> IO ()
|
||||
copyFile from' to' = do
|
||||
from <- canonicalizePath' from'
|
||||
tod <- canonicalizePath' (baseDir to')
|
||||
let to = tod </> takeFileName to'
|
||||
onSymlinkOr from (recreateSymlink from to) $ do
|
||||
fileSanityThrow from
|
||||
throwNotAbsolute to
|
||||
throwDirDoesExist to
|
||||
toC <- canonicalizePath' (takeDirectory to)
|
||||
let to' = toC </> takeFileName to
|
||||
throwSameFile from to'
|
||||
SD.copyFile from to'
|
||||
|
||||
copyFile from@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) _ = return ()
|
||||
copyFile from@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) _ = return ()
|
||||
copyFile from@(_ :/ RegFile {}) to@(_ :/ RegFile {}) = do
|
||||
let from' = fullPath from
|
||||
to' = fullPath to
|
||||
throwSameFile from' to'
|
||||
SD.copyFile from' to'
|
||||
copyFile _ _ = return ()
|
||||
|
||||
|
||||
-- |Copies the given file to the given dir with the same filename.
|
||||
-- This can also be called on symlinks.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
-- * `DirDoesNotExist` if the target directory does not exist
|
||||
-- * `PathNotAbsolute` if the target directory is not absolute
|
||||
-- * anything that `copyFile` throws
|
||||
copyFileToDir :: FilePath -> FilePath -> IO ()
|
||||
copyFileToDir from' to' = do
|
||||
from <- canonicalizePath' from'
|
||||
to <- canonicalizePath' to'
|
||||
let name = takeFileName from
|
||||
dirSanityThrow to
|
||||
copyFile from (to </> name)
|
||||
copyFileToDir :: AnchoredFile FileInfo FileInfo
|
||||
-> AnchoredFile FileInfo FileInfo
|
||||
-> IO ()
|
||||
copyFileToDir from@(_ :/ RegFile _ FileInfo { isSymbolicLink = True }) _
|
||||
= return ()
|
||||
copyFileToDir from@(_ :/ Dir _ FileInfo { isSymbolicLink = True }) _
|
||||
= return ()
|
||||
copyFileToDir from@(_ :/ RegFile fn _)
|
||||
to@(_ :/ Dir {}) =
|
||||
do
|
||||
let from' = fullPath from
|
||||
to' = fullPath to </> fn
|
||||
SD.copyFile from' to'
|
||||
copyFileToDir _ _ = return ()
|
||||
|
||||
|
||||
easyCopy :: DirCopyMode -> FilePath -> FilePath -> IO ()
|
||||
easyCopy cm from to = onDirOrFile from (copyDir cm from to)
|
||||
(copyFileToDir from to)
|
||||
easyCopy :: DirCopyMode
|
||||
-> AnchoredFile FileInfo FileInfo
|
||||
-> AnchoredFile FileInfo FileInfo
|
||||
-> IO ()
|
||||
easyCopy _ from@(_ :/ RegFile _ FileInfo { isSymbolicLink = True })
|
||||
to@(_ :/ Dir {})
|
||||
= recreateSymlink from to
|
||||
easyCopy _ from@(_ :/ Dir _ FileInfo { isSymbolicLink = True })
|
||||
to@(_ :/ Dir {})
|
||||
= recreateSymlink from to
|
||||
easyCopy _ from@(_ :/ RegFile fn _)
|
||||
to@(_ :/ Dir {})
|
||||
= copyFileToDir from to
|
||||
easyCopy _ from@(_ :/ RegFile fn _)
|
||||
to@(_ :/ RegFile {})
|
||||
= copyFile from to
|
||||
easyCopy cm from@(_ :/ Dir fn _)
|
||||
to@(_ :/ Dir {})
|
||||
= copyDir cm from to
|
||||
easyCopy _ _ _ = return ()
|
||||
|
||||
|
||||
|
||||
@ -262,77 +288,57 @@ easyCopy cm from to = onDirOrFile from (copyDir cm from to)
|
||||
|
||||
|
||||
-- |Deletes a symlink, which can either point to a file or directory.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
-- * `dirSanityThrow`
|
||||
-- * `fileSanityThrow`
|
||||
deleteSymlink :: FilePath -> IO ()
|
||||
deleteSymlink fp' = do
|
||||
fp <- canonicalizePath' fp'
|
||||
onDirOrFile fp (dirSanityThrow fp >> removeFile fp)
|
||||
(fileSanityThrow fp >> removeFile fp)
|
||||
deleteSymlink :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
deleteSymlink f@(_ :/ RegFile _ FileInfo { isSymbolicLink = True })
|
||||
= removeFile (fullPath f)
|
||||
deleteSymlink f@(_ :/ Dir _ FileInfo { isSymbolicLink = True })
|
||||
= removeFile (fullPath f)
|
||||
deleteSymlink _
|
||||
= return ()
|
||||
|
||||
|
||||
-- |Deletes the given file.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
-- * `FileDoesNotExist` if the file does not exist
|
||||
-- * `PathNotAbsolute` if the file is not absolute
|
||||
-- * anything that `removeFile` throws
|
||||
deleteFile :: FilePath -> IO ()
|
||||
deleteFile fp' = do
|
||||
fp <- canonicalizePath' fp'
|
||||
fileSanityThrow fp
|
||||
throwIsSymlink fp
|
||||
removeFile fp
|
||||
-- |Deletes the given file, never symlinks.
|
||||
deleteFile :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
deleteFile f@(_ :/ RegFile _ FileInfo { isSymbolicLink = True })
|
||||
= return ()
|
||||
deleteFile f@(_ :/ RegFile {})
|
||||
= removeFile (fullPath f)
|
||||
deleteFile _
|
||||
= return ()
|
||||
|
||||
|
||||
-- |Deletes the given directory.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
-- * `DirDoesNotExist` if the dir does not exist
|
||||
-- * `PathNotAbsolute` if the dir is not absolute
|
||||
-- * anything that `removeDirectory` throws
|
||||
deleteDir :: FilePath -> IO ()
|
||||
deleteDir fp' =
|
||||
onSymlinkOr fp' (deleteFile fp') $ do
|
||||
fp <- canonicalizePath' fp'
|
||||
dirSanityThrow fp
|
||||
throwIsSymlink fp
|
||||
removeDirectory fp
|
||||
-- |Deletes the given directory, never symlinks.
|
||||
deleteDir :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
deleteDir f@(_ :/ Dir _ FileInfo { isSymbolicLink = True })
|
||||
= return ()
|
||||
deleteDir f@(_ :/ Dir {})
|
||||
= removeDirectory (fullPath f)
|
||||
deleteDir _ = return ()
|
||||
|
||||
|
||||
-- |Deletes the given directory recursively.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
-- * `DirDoesNotExist` if the dir does not exist
|
||||
-- * `PathNotAbsolute` if the dir is not absolute
|
||||
-- * anything that `removeDirectoryRecursive` throws
|
||||
deleteDirRecursive :: FilePath -> IO ()
|
||||
deleteDirRecursive fp' =
|
||||
onSymlinkOr fp' (deleteFile fp') $ do
|
||||
fp <- canonicalizePath' fp'
|
||||
dirSanityThrow fp
|
||||
throwIsSymlink fp
|
||||
removeDirectoryRecursive fp
|
||||
-- |Deletes the given directory recursively, never symlinks.
|
||||
deleteDirRecursive :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
deleteDirRecursive f@(_ :/ Dir _ FileInfo { isSymbolicLink = True })
|
||||
= return ()
|
||||
deleteDirRecursive f@(_ :/ Dir {})
|
||||
= removeDirectoryRecursive (fullPath f)
|
||||
deleteDirRecursive _ = return ()
|
||||
|
||||
|
||||
-- |Deletes a file, directory or symlink, whatever it may be.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
-- * `DirDoesNotExist`/`FileDoesNotExist` if the file/dir does not exist
|
||||
-- * `PathNotAbsolute` if the file/dir is not absolute
|
||||
-- * anything that `deleteDir`/`deleteFile` throws
|
||||
easyDelete :: FilePath -> IO ()
|
||||
easyDelete fp' = do
|
||||
fp <- canonicalizePath' fp'
|
||||
onSymlinkOr fp (deleteSymlink fp) $
|
||||
onDirOrFile fp (deleteDir fp) (deleteFile fp)
|
||||
-- In case of directory, performs recursive deletion.
|
||||
easyDelete :: AnchoredFile FileInfo FileInfo -> IO ()
|
||||
easyDelete f@(_ :/ RegFile _ FileInfo { isSymbolicLink = True })
|
||||
= deleteSymlink f
|
||||
easyDelete f@(_ :/ Dir _ FileInfo { isSymbolicLink = True })
|
||||
= deleteSymlink f
|
||||
easyDelete f@(_ :/ RegFile {})
|
||||
= deleteFile f
|
||||
easyDelete f@(_ :/ Dir {})
|
||||
= deleteDirRecursive f
|
||||
easyDelete _
|
||||
= return ()
|
||||
|
||||
|
||||
|
||||
|
||||
@ -347,12 +353,9 @@ easyDelete fp' = do
|
||||
--
|
||||
-- * `FileDoesNotExist` if the file does not exist
|
||||
-- * `PathNotAbsolute` if the file is not absolute
|
||||
openFile :: FilePath
|
||||
openFile :: AnchoredFile a b
|
||||
-> IO ProcessHandle
|
||||
openFile fp' = do
|
||||
fp <- canonicalizePath' fp'
|
||||
fileSanityThrow fp
|
||||
spawnProcess "xdg-open" [fp]
|
||||
openFile f = spawnProcess "xdg-open" [fullPath f]
|
||||
|
||||
|
||||
-- |Executes a program with the given arguments.
|
||||
@ -362,53 +365,10 @@ openFile fp' = do
|
||||
-- * `FileDoesNotExist` if the program does not exist
|
||||
-- * `PathNotAbsolute` if the program is not absolute
|
||||
-- * `FileNotExecutable` if the program is not executable
|
||||
executeFile :: FilePath -- ^ program
|
||||
executeFile :: AnchoredFile FileInfo FileInfo -- ^ program
|
||||
-> [String] -- ^ arguments
|
||||
-> IO ProcessHandle
|
||||
executeFile prog' args = do
|
||||
prog <- canonicalizePath' prog'
|
||||
fileSanityThrow prog
|
||||
unlessM (fileAccess prog False False True) (throw $ FileNotExecutable prog)
|
||||
spawnProcess prog args
|
||||
|
||||
|
||||
|
||||
|
||||
--------------------
|
||||
--[ Utilities ]--
|
||||
--------------------
|
||||
|
||||
|
||||
-- |Carries out the given action if the filepath is a symlink. If not,
|
||||
-- carries out an alternative action.
|
||||
onSymlinkOr :: FilePath
|
||||
-> IO () -- ^ action if symlink
|
||||
-> IO () -- ^ action if not symlink
|
||||
-> IO ()
|
||||
onSymlinkOr fp a1 a2 = do
|
||||
isSymlink <- PF.isSymbolicLink <$> PF.getSymbolicLinkStatus fp
|
||||
if isSymlink then a1 else a2
|
||||
|
||||
|
||||
-- |Executes either a directory or file related IO action, depending on
|
||||
-- the input filepath.
|
||||
--
|
||||
-- The operation may fail with:
|
||||
--
|
||||
-- * `throwFileDoesNotExist` if the filepath is neither a file or directory
|
||||
onDirOrFile :: FilePath
|
||||
-> IO () -- ^ action if directory
|
||||
-> IO () -- ^ action if file
|
||||
-> IO ()
|
||||
onDirOrFile fp' iod iof = do
|
||||
fp <- canonicalizePath' fp'
|
||||
isD <- doesDirectoryExist fp
|
||||
isF <- doesFileExist fp
|
||||
case (isD, isF) of
|
||||
(True, False) -> do
|
||||
dirSanityThrow fp
|
||||
iod
|
||||
(False, True) -> do
|
||||
fileSanityThrow fp
|
||||
iof
|
||||
_ -> throwFileDoesNotExist fp
|
||||
-> IO (Maybe ProcessHandle)
|
||||
executeFile prog@(_ :/ RegFile _ FileInfo { permissions = perms }) args
|
||||
| executable perms = Just <$> spawnProcess (fullPath prog) args
|
||||
| otherwise = return Nothing
|
||||
executeFile _ _ = return Nothing
|
||||
|
||||
Loading…
Reference in New Issue
Block a user