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

LIB: refactor FileOperation and related Errors

Browse Source 
* move FileOperation/Copy/Move types to its own UtilTypes module
* remove runFileOp, since it's hard to really do the correct
  thing here for all possible exceptions... instead, let the
  GUI logic handle this
* introduce copyDirRecursiveOverwrite, copyFileOverwrite and
  easyCopyOverwrite
* use our own throwSameFile on functions to distinguish between
  "same file" and "file already exists"
* don't follow destination in copyFile* either
* improve throwSameFile, by examining device and file ids
* add isWritable
* improve documentation
* adjust and fix tests
This commit is contained in:
Julian Ospald
2016-05-08 18:48:17 +02:00
parent d58fd6e6f0
commit 9c6cf51825
26 changed files with 427 additions and 103 deletions
Download Patch File Download Diff File Expand all files Collapse all files

48
src/HSFM/FileSystem/Errors.hs
View File

@@ -52,7 +52,11 @@ import System.IO.Error
)
import qualified System.Posix.Directory.ByteString as PFD
import System.Posix.FilePath
import System.Posix.Files.ByteString
(
fileAccess
, getFileStatus
)
import qualified System.Posix.Files.ByteString as PF
@@ -156,18 +160,28 @@ throwDirDoesNotExist fp =
. P.fromAbs $ fp)
throwSameFile :: Path Abs -- ^ will be canonicalized
-> Path Abs -- ^ will be canonicalized
-- |Uses `isSameFile` and throws `SameFile` if it returns True.
throwSameFile :: Path Abs
-> Path Abs
-> IO ()
throwSameFile fp1 fp2 = do
fp1' <- fmap P.fromAbs $ P.canonicalizePath fp1
-- TODO: clean this up... if canonicalizing fp2 fails we try to
-- canonicalize `dirname fp2`
fp2' <- catchIOError (fmap P.fromAbs $ P.canonicalizePath fp2)
(\_ -> fmap P.fromAbs
$ (\x -> maybe x (\y -> x P.</> y) $ P.basename fp2)
<$> (P.canonicalizePath $ P.dirname fp2))
when (equalFilePath fp1' fp2') (throw $ SameFile fp1' fp2')
throwSameFile fp1 fp2 =
whenM (sameFile fp1 fp2)
(throw $ SameFile (P.fromAbs fp1) (P.fromAbs fp2))
-- |Check if the files are the same by examining device and file id.
-- This follows symbolic links.
sameFile :: Path Abs -> Path Abs -> IO Bool
sameFile fp1 fp2 =
P.withAbsPath fp1 $ \fp1' -> P.withAbsPath fp2 $ \fp2' ->
handleIOError (\_ -> return False) $ do
fs1 <- getFileStatus fp1'
fs2 <- getFileStatus fp2'
if ((PF.deviceID fs1, PF.fileID fs1) ==
(PF.deviceID fs2, PF.fileID fs2))
then return True
else return False
-- |Checks whether the destination directory is contained
@@ -179,14 +193,13 @@ throwDestinationInSource :: Path Abs -- ^ source dir
-- must exist
-> IO ()
throwDestinationInSource source dest = do
source' <- P.canonicalizePath source
dest' <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
<$> (P.canonicalizePath $ P.dirname dest)
dids <- forM (P.getAllParents dest') $ \p -> do
fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
return (PF.deviceID fs, PF.fileID fs)
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
$ PF.getSymbolicLinkStatus (P.fromAbs source')
$ PF.getFileStatus (P.fromAbs source)
when (elem sid dids)
(throw $ DestinationInSource (P.fromAbs dest)
(P.fromAbs source))
@@ -210,6 +223,13 @@ doesDirectoryExist fp =
return $ PF.isDirectory fs
-- |Checks whether a file or folder is writable.
isWritable :: Path Abs -> IO Bool
isWritable fp =
handleIOError (\_ -> return False) $
fileAccess (P.fromAbs fp) False True False
-- |Checks whether the directory at the given path exists and can be
-- opened. This invokes `openDirStream` which follows symlinks.
canOpenDirectory :: Path Abs -> IO Bool

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

@@ -49,8 +49,7 @@ import Control.Exception
)
import Control.Monad
(
forM_
, void
void
, when
)
import Data.ByteString
@@ -89,6 +88,10 @@ import Foreign.Ptr
(
Ptr
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import HPath
(
Path
@@ -97,7 +100,13 @@ import HPath
)
import qualified HPath as P
import HSFM.FileSystem.Errors
import HSFM.Utils.IO
import Prelude hiding (readFile)
import System.IO.Error
(
catchIOError
, ioeGetErrorType
)
import System.Posix.ByteString
(
exclusive
@@ -128,6 +137,7 @@ import System.Posix.Files.ByteString
, readSymbolicLink
, removeLink
, rename
, setFileMode
, unionFileModes
)
import qualified System.Posix.Files.ByteString as PF
@@ -150,33 +160,10 @@ import System.Posix.Types
-- TODO: file operations should be threaded and not block the UI
-- TODO: make sure we do the right thing for BlockDev, CharDev etc...
-- most operations are not implemented for these
-- TODO: say which low-level syscalls are involved
-- |Data type describing an actual file operation that can be
-- carried out via `runFileOp`. Useful to build up a list of operations
-- or delay operations.
data FileOperation = FCopy Copy
| FMove Move
| FDelete [Path Abs]
| FOpen (Path Abs)
| FExecute (Path Abs) [ByteString]
| None
-- |Data type describing partial or complete file copy operation.
-- CC stands for a complete operation and can be used for `runFileOp`.
data Copy = PartialCopy [Path Abs]
| Copy [Path Abs] (Path Abs)
-- |Data type describing partial or complete file move operation.
-- MC stands for a complete operation and can be used for `runFileOp`.
data Move = PartialMove [Path Abs]
| Move [Path Abs] (Path Abs)
data FileType = Directory
@@ -190,33 +177,6 @@ data FileType = Directory
-- |Run a given FileOperation. If the FileOperation is partial, it will
-- be returned. Returns `Nothing` on success.
--
-- Since file operations can be delayed, this is `Path Abs` based, not
-- `File` based. This makes sure we don't have stale
-- file information.
runFileOp :: FileOperation -> IO (Maybe FileOperation)
runFileOp fo' =
case fo' of
(FCopy (Copy froms to)) -> do
forM_ froms $ \x -> do
toname <- P.basename x
easyCopy x (to P.</> toname)
return Nothing
(FCopy fo) -> return $ Just $ FCopy fo
(FMove (Move froms to)) -> do
forM_ froms $ \x -> do
toname <- P.basename x
moveFile x (to P.</> toname)
return Nothing
(FMove fo) -> return $ Just $ FMove fo
(FDelete fps) ->
mapM_ easyDelete fps >> return Nothing
(FOpen fp) -> openFile fp >> return Nothing
(FExecute fp args) -> executeFile fp args >> return Nothing
_ -> return Nothing
--------------------
@@ -244,15 +204,16 @@ runFileOp fo' =
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source directory is wrong type (symlink)
-- - `InvalidArgument` if source directory is wrong type (regular file)
-- - `AlreadyExists` if source and destination are the same directory
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `AlreadyExists` if destination already exists
-- - `DestinationInSource` if destination is contained in source
-- - `DestinationInSource` if destination is contained in source (`FmIOException`)
copyDirRecursive :: Path Abs -- ^ source dir
-> Path Abs -- ^ full destination
-> IO ()
copyDirRecursive fromp destdirp
= do
-- for performance, sanity checks are only done for the top dir
throwSameFile fromp destdirp
throwDestinationInSource fromp destdirp
go fromp destdirp
where
@@ -275,6 +236,51 @@ copyDirRecursive fromp destdirp
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
-- |Like `copyDirRecursive` except it overwrites contents of directories
-- if any.
--
-- Throws:
--
-- - `NoSuchThing` if source directory does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source directory is wrong type (symlink)
-- - `InvalidArgument` if source directory is wrong type (regular file)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `DestinationInSource` if destination is contained in source (`FmIOException`)
copyDirRecursiveOverwrite :: Path Abs -- ^ source dir
-> Path Abs -- ^ full destination
-> IO ()
copyDirRecursiveOverwrite fromp destdirp
= do
-- for performance, sanity checks are only done for the top dir
throwSameFile fromp destdirp
throwDestinationInSource fromp destdirp
go fromp destdirp
where
go :: Path Abs -> Path Abs -> IO ()
go fromp' destdirp' = do
-- order is important here, so we don't get empty directories
-- on failure
contents <- getDirsFiles fromp'
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (P.fromAbs fromp')
catchIOError (createDirectory (P.fromAbs destdirp') fmode') $ \e ->
case ioeGetErrorType e of
AlreadyExists -> setFileMode (P.fromAbs destdirp') fmode'
_ -> ioError e
for_ contents $ \f -> do
ftype <- getFileType f
newdest <- (destdirp' P.</>) <$> P.basename f
case ftype of
SymbolicLink -> whenM (doesFileExist newdest) (deleteFile newdest)
>> recreateSymlink f newdest
Directory -> go f newdest
RegularFile -> copyFileOverwrite f newdest
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
-- |Recreate a symlink.
--
@@ -285,7 +291,7 @@ copyDirRecursive fromp destdirp
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `AlreadyExists` if destination file already exists
-- - `AlreadyExists` if destination and source are the same file
-- - `SameFile` if source and destination are the same file (`FmIOException`)
--
-- Note: calls `symlink`
recreateSymlink :: Path Abs -- ^ the old symlink file
@@ -293,11 +299,12 @@ recreateSymlink :: Path Abs -- ^ the old symlink file
-> IO ()
recreateSymlink symsource newsym
= do
throwSameFile symsource newsym
sympoint <- readSymbolicLink (P.fromAbs symsource)
createSymbolicLink sympoint (P.fromAbs newsym)
-- |Copies the given regular file to the given dir with the given filename.
-- |Copies the given regular file to the given destination.
-- Neither follows symbolic links, nor accepts them.
-- For "copying" symbolic links, use `recreateSymlink` instead.
--
@@ -308,19 +315,29 @@ recreateSymlink symsource newsym
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source file is wrong type (symlink)
-- - `InvalidArgument` if source file is wrong type (directory)
-- - `AlreadyExists` if source and destination are the same file
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `AlreadyExists` if destination already exists
--
-- Note: calls `sendfile`
copyFile :: Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
copyFile from to = _copyFile SPI.defaultFileFlags { exclusive = True } from to
copyFile from to = do
throwSameFile from to
_copyFile [SPDF.oNofollow]
[SPDF.oNofollow, SPDF.oExcl]
from to
-- |Like `copyFile` except it overwrites the destination if it already exists.
-- |Like `copyFile` except it overwrites the destination if it already
-- exists.
-- This also works if source and destination are the same file.
--
-- Safety/reliability concerns:
--
-- * not atomic
-- * falls back to delete-copy method with explicit checks
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
@@ -328,19 +345,35 @@ copyFile from to = _copyFile SPI.defaultFileFlags { exclusive = True } from to
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source file is wrong type (symlink)
-- - `InvalidArgument` if source file is wrong type (directory)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
--
-- Note: calls `sendfile`
copyFileOverwrite :: Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
copyFileOverwrite from to = _copyFile SPI.defaultFileFlags { exclusive = False } from to
copyFileOverwrite from to = do
throwSameFile from to
catchIOError (_copyFile [SPDF.oNofollow]
[SPDF.oNofollow, SPDF.oTrunc]
from to) $ \e ->
case ioeGetErrorType e of
-- if the destination file is not writable, we need to
-- figure out if we can still copy by deleting it first
PermissionDenied -> do
exists <- doesFileExist to
writable <- isWritable (P.dirname to)
if exists && writable
then deleteFile to >> copyFile from to
else ioError e
_ -> ioError e
_copyFile :: SPI.OpenFileFlags
_copyFile :: [SPDF.Flags]
-> [SPDF.Flags]
-> Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
_copyFile off from to
_copyFile sflags dflags from to
=
-- from sendfile(2) manpage:
-- Applications may wish to fall back to read(2)/write(2) in the case
@@ -352,24 +385,26 @@ _copyFile off from to
where
-- this is low-level stuff utilizing sendfile(2) for speed
sendFileCopy source dest =
bracket (SPDT.openFd source SPI.ReadOnly [SPDF.oNofollow] Nothing)
bracket (SPDT.openFd source SPI.ReadOnly sflags Nothing)
SPI.closeFd
$ \sfd -> do
fileM <- System.Posix.Files.ByteString.fileMode
<$> getFdStatus sfd
bracketeer (SPI.openFd dest SPI.WriteOnly (Just fileM) off)
bracketeer (SPDT.openFd dest SPI.WriteOnly
dflags $ Just fileM)
SPI.closeFd
(\fd -> SPI.closeFd fd >> deleteFile to)
$ \dfd -> sendfileFd dfd sfd EntireFile
-- low-level copy operation utilizing read(2)/write(2)
-- in case `sendFileCopy` fails/is unsupported
fallbackCopy source dest =
bracket (SPDT.openFd source SPI.ReadOnly [SPDF.oNofollow] Nothing)
bracket (SPDT.openFd source SPI.ReadOnly sflags Nothing)
SPI.closeFd
$ \sfd -> do
fileM <- System.Posix.Files.ByteString.fileMode
<$> getFdStatus sfd
bracketeer (SPI.openFd dest SPI.WriteOnly (Just fileM) off)
bracketeer (SPDT.openFd dest SPI.WriteOnly
dflags $ Just fileM)
SPI.closeFd
(\fd -> SPI.closeFd fd >> deleteFile to)
$ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf ->
@@ -408,6 +443,23 @@ easyCopy from to = do
"given filetype: " ++ show ftype
-- |Like `easyCopy` except it overwrites the destination if it already exists.
-- For directories, this overwrites contents without pruning them, so the resulting
-- directory may have more files than have been copied.
easyCopyOverwrite :: Path Abs
-> Path Abs
-> IO ()
easyCopyOverwrite from to = do
ftype <- getFileType from
case ftype of
SymbolicLink -> whenM (doesFileExist to) (deleteFile to)
>> recreateSymlink from to
RegularFile -> copyFileOverwrite from to
Directory -> copyDirRecursiveOverwrite from to
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
@@ -576,7 +628,7 @@ createDir dest = createDirectory (P.fromAbs dest) newDirPerms
-- - `UnsupportedOperation` if source and destination are on different devices
-- - `FileDoesExist` if destination file already exists
-- - `DirDoesExist` if destination directory already exists
-- - `SameFile` if destination and source are the same file
-- - `SameFile` if destination and source are the same file (`FmIOException`)
--
-- Note: calls `rename` (but does not allow to rename over existing files)
renameFile :: Path Abs -> Path Abs -> IO ()
@@ -603,13 +655,14 @@ renameFile fromf tof = do
-- - `PermissionDenied` if source directory cannot be opened
-- - `FileDoesExist` if destination file already exists
-- - `DirDoesExist` if destination directory already exists
-- - `SameFile` if destination and source are the same file
-- - `SameFile` if destination and source are the same file (`FmIOException`)
--
-- Note: calls `rename` (but does not allow to rename over existing files)
moveFile :: Path Abs -- ^ file to move
-> Path Abs -- ^ destination
-> IO ()
moveFile from to =
moveFile from to = do
throwSameFile from to
catchErrno [eXDEV] (renameFile from to) $ do
easyCopy from to
easyDelete from

84
src/HSFM/FileSystem/UtilTypes.hs Normal file
View File

@@ -0,0 +1,84 @@
{--
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 #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides high-level IO related file operations like
-- copy, delete, move and so on. It only operates on `Path Abs` which
-- guarantees us well-typed paths which are absolute.
--
-- Some functions are just path-safe wrappers around
-- unix functions, others have stricter exception handling
-- and some implement functionality that doesn't have a unix
-- counterpart (like `copyDirRecursive`).
--
-- Some of these operations are due to their nature not _atomic_, which
-- means they may do multiple syscalls which form one context. Some
-- of them also have to examine the filetypes explicitly before the
-- syscalls, so a reasonable decision can be made. That means
-- the result is undefined if another process changes that context
-- while the non-atomic operation is still happening. However, where
-- possible, as few syscalls as possible are used and the underlying
-- exception handling is kept.
module HSFM.FileSystem.UtilTypes where
import Data.ByteString
(
ByteString
)
import HPath
(
Path
, Abs
, Fn
)
-- |Data type describing file operations.
-- Useful to build up a list of operations or delay operations.
data FileOperation = FCopy Copy
| FMove Move
| FDelete [Path Abs]
| FOpen (Path Abs)
| FExecute (Path Abs) [ByteString]
| None
-- |Data type describing partial or complete file copy operation.
data Copy = PartialCopy [Path Abs] -- source files
| Copy [Path Abs] -- source files
(Path Abs) -- base destination directory
-- |Data type describing partial or complete file move operation.
data Move = PartialMove [Path Abs] -- source files
| Move [Path Abs] -- source files
(Path Abs) -- base destination directory
-- |Collision modes that describe the behavior in case a file collision
-- happens.
data FCollisonMode = Strict -- ^ fail if the target already exists
| Overwrite
| OverwriteAll
| Skip
| Rename (Path Fn)