From 47cd43dba6b455e66c4eb1a30b29b00f859a17de Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 2 May 2016 19:06:53 +0200 Subject: [PATCH] LIB: refactor large parts of the API This makes the FileOperations module more low-level, since we now handle everything via 'Path Abs' and only leave 'File a' for e.g. GUI purposes. Also fixes various bugs in the Errors module. This depends on custom changes in posix-paths. --- src/HSFM/FileSystem/Errors.hs | 63 ++- src/HSFM/FileSystem/FileOperations.hs | 561 ++++++++++++-------------- src/HSFM/FileSystem/FileType.hs | 51 +-- 3 files changed, 332 insertions(+), 343 deletions(-) diff --git a/src/HSFM/FileSystem/Errors.hs b/src/HSFM/FileSystem/Errors.hs index c2919bc..ed48bd0 100644 --- a/src/HSFM/FileSystem/Errors.hs +++ b/src/HSFM/FileSystem/Errors.hs @@ -72,7 +72,7 @@ data FmIOException = FileDoesNotExist ByteString | Can'tOpenDirectory ByteString | CopyFailed String | MoveFailed String - deriving (Typeable) + deriving (Typeable, Eq) instance Show FmIOException where @@ -106,6 +106,26 @@ instance Exception FmIOException +isDestinationInSource :: FmIOException -> Bool +isDestinationInSource (DestinationInSource _ _) = True +isDestinationInSource _ = False + + +isSameFile :: FmIOException -> Bool +isSameFile (SameFile _ _) = True +isSameFile _ = False + + +isFileDoesExist :: FmIOException -> Bool +isFileDoesExist (FileDoesExist _) = True +isFileDoesExist _ = False + + +isDirDoesExist :: FmIOException -> Bool +isDirDoesExist (DirDoesExist _) = True +isDirDoesExist _ = False + + ---------------------------- --[ Path based functions ]-- @@ -126,14 +146,14 @@ throwDirDoesExist fp = throwFileDoesNotExist :: Path Abs -> IO () throwFileDoesNotExist fp = - whenM (doesFileExist fp) (throw . FileDoesExist - . P.fromAbs $ fp) + unlessM (doesFileExist fp) (throw . FileDoesNotExist + . P.fromAbs $ fp) throwDirDoesNotExist :: Path Abs -> IO () throwDirDoesNotExist fp = - whenM (doesDirectoryExist fp) (throw . DirDoesExist - . P.fromAbs $ fp) + unlessM (doesDirectoryExist fp) (throw . DirDoesNotExist + . P.fromAbs $ fp) throwSameFile :: Path Abs -- ^ will be canonicalized @@ -172,28 +192,26 @@ throwDestinationInSource source dest = do (P.fromAbs source)) --- |Checks if the given file exists and is not a directory. This follows --- symlinks, but will return True if the symlink is broken. +-- |Checks if the given file exists and is not a directory. +-- Does not follow symlinks. doesFileExist :: Path Abs -> IO Bool doesFileExist fp = handleIOError (\_ -> return False) $ do - fp' <- fmap P.fromAbs $ P.canonicalizePath fp - fs <- PF.getFileStatus fp' + fs <- PF.getSymbolicLinkStatus (P.fromAbs fp) return $ not . PF.isDirectory $ fs --- |Checks if the given file exists and is a directory. This follows --- symlinks, but will return False if the symlink is broken. +-- |Checks if the given file exists and is a directory. +-- Does not follow symlinks. doesDirectoryExist :: Path Abs -> IO Bool doesDirectoryExist fp = handleIOError (\_ -> return False) $ do - fp' <- fmap P.fromAbs $ P.canonicalizePath fp - fs <- PF.getFileStatus fp' + fs <- PF.getSymbolicLinkStatus (P.fromAbs fp) return $ PF.isDirectory fs -- |Checks whether the directory at the given path exists and can be --- opened. This invokes `openDirStream`. +-- opened. This invokes `openDirStream` which follows symlinks. canOpenDirectory :: Path Abs -> IO Bool canOpenDirectory fp = handleIOError (\_ -> return False) $ do @@ -249,3 +267,20 @@ rethrowErrnoAs en fmex action = catchErrno en action (throw fmex) handleIOError :: (IOError -> IO a) -> IO a -> IO a handleIOError = flip catchIOError + +-- |Like `bracket`, but allows to have different clean-up +-- actions depending on whether the in-between computation +-- has raised an exception or not. +bracketeer :: IO a -- ^ computation to run first + -> (a -> IO b) -- ^ computation to run last, when + -- no exception was raised + -> (a -> IO b) -- ^ computation to run last, + -- when an exception was raised + -> (a -> IO c) -- ^ computation to run in-between + -> IO c +bracketeer before after afterEx thing = + mask $ \restore -> do + a <- before + r <- restore (thing a) `onException` afterEx a + _ <- after a + return r diff --git a/src/HSFM/FileSystem/FileOperations.hs b/src/HSFM/FileSystem/FileOperations.hs index ae62393..f2d3643 100644 --- a/src/HSFM/FileSystem/FileOperations.hs +++ b/src/HSFM/FileSystem/FileOperations.hs @@ -20,24 +20,21 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. {-# LANGUAGE PackageImports #-} {-# OPTIONS_HADDOCK ignore-exports #-} --- |This module provides all the atomic IO related file operations like --- copy, delete, move and so on. It operates primarily on `AnchoredFile`, which --- is guaranteed to be well-formed. --- --- It would be nicer to pass states around, but the filesystem state changes --- too quickly and cannot be relied upon. Lazy implementations of filesystem --- trees have been tried as well, but they can introduce subtle bugs. +-- |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 path which are absolute. module HSFM.FileSystem.FileOperations where import Control.Exception ( bracket + , bracketOnError , throw ) import Control.Monad ( - unless + forM_ , void , when ) @@ -49,15 +46,20 @@ import Data.Foldable ( for_ ) +import Data.Maybe + ( + catMaybes + ) import Data.Word ( Word8 ) import Foreign.C.Error ( - eXDEV + eACCES , eINVAL , eNOSYS + , eXDEV ) import Foreign.C.Types ( @@ -79,14 +81,25 @@ import HPath ) import qualified HPath as P import HSFM.FileSystem.Errors -import HSFM.FileSystem.FileType import HSFM.Utils.IO + ( + unlessM + ) import Prelude hiding (readFile) +import System.Posix.ByteString + ( + exclusive + ) import System.Posix.Directory.ByteString ( createDirectory , removeDirectory ) +import System.Posix.Directory.Traversals + ( + getDirectoryContents + , getDirectoryContents' + ) import System.Posix.Files.ByteString ( createSymbolicLink @@ -109,6 +122,8 @@ import System.Posix.Files.ByteString import qualified System.Posix.Files.ByteString as PF import qualified "unix" System.Posix.IO.ByteString as SPI import qualified "unix-bytestring" System.Posix.IO.ByteString as SPB +import qualified System.Posix.Directory.Traversals as SPDT +import qualified System.Posix.Directory.Foreign as SPDF import System.Posix.IO.Sendfile.ByteString ( sendfileFd @@ -127,10 +142,11 @@ 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 `doFile`. Useful to build up a list of operations +-- carried out via `runFileOp`. Useful to build up a list of operations -- or delay operations. data FileOperation = FCopy Copy | FMove Move @@ -142,29 +158,25 @@ data FileOperation = FCopy Copy -- |Data type describing partial or complete file copy operation. -- CC stands for a complete operation and can be used for `runFileOp`. -data Copy = CP1 [Path Abs] - | CP2 [Path Abs] - (Path Abs) - | CC [Path Abs] - (Path Abs) - CopyMode +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 = MP1 [Path Abs] - | MC [Path Abs] - (Path Abs) - CopyMode +data Move = PartialMove [Path Abs] + | Move [Path Abs] (Path Abs) --- |Copy modes. -data CopyMode = Strict -- ^ fail if the target already exists - | Merge -- ^ overwrite files if necessary, for files, this - -- is the same as Replace - | Replace -- ^ remove targets before copying, this is - -- only useful if the target is a directorty - | Rename (Path Fn) +data FileType = Directory + | RegularFile + | SymbolicLink + | BlockDevice + | CharacterDevice + | NamedPipe + | Socket + deriving (Show) + -- |Run a given FileOperation. If the FileOperation is partial, it will @@ -176,32 +188,23 @@ data CopyMode = Strict -- ^ fail if the target already exists runFileOp :: FileOperation -> IO (Maybe FileOperation) runFileOp fo' = case fo' of - (FCopy (CC froms to cm)) -> do - froms' <- mapM toAfile froms - to' <- toAfile to - when (anyFailed froms') - (throw . CopyFailed $ "File in copy buffer does not exist anymore!") - mapM_ (\x -> easyCopy cm x to') froms' - >> return Nothing + (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 (MC froms to cm)) -> do - froms' <- mapM toAfile froms - to' <- toAfile to - when (anyFailed froms') - (throw . MoveFailed $ "File in move buffer does not exist anymore!") - mapM_ (\x -> easyMove cm x to') froms' - >> return Nothing + (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) -> do - fps' <- mapM toAfile fps - mapM_ easyDelete fps' >> return Nothing - (FOpen fp) -> - toAfile fp >>= openFile >> return Nothing - (FExecute fp args) -> - toAfile fp >>= flip executeFile args >> return Nothing + (FDelete fps) -> + mapM_ easyDelete fps >> return Nothing + (FOpen fp) -> openFile fp >> return Nothing + (FExecute fp args) -> executeFile fp args >> return Nothing _ -> return Nothing - where - toAfile = readFile (\_ -> return undefined) @@ -210,172 +213,110 @@ runFileOp fo' = -------------------- + -- |Copies a directory to the given destination with the specified -- `DirCopyMode`. Excludes symlinks. -copyDir :: CopyMode - -> File a -- ^ source dir - -> File a -- ^ destination dir - -> Path Fn -- ^ destination dir name - -> IO () -copyDir (Rename fn) - from@Dir{} - to@Dir{} - _ - = copyDir Strict from to fn --- this branch must never get `Rename` as CopyMode -copyDir cm from@Dir{ path = fromp } - to@Dir{ path = top } - fn +-- +-- This operation may not be safe on directories that are written to +-- while this operation happens. There are several reasons: +-- * multiple syscalls are required, so this is not an atomic +-- operation and a lot of stuff can happen in-between those syscalls +-- to the filesystem +-- * filetypes must be figured out explicitly for the contents of a directory +-- to make a useful decision of what to do next... this means when the +-- syscall is triggered, there is a slight chance that the filetype might +-- already be a different one, resulting in an unexpected codepath +-- * an explicit check `throwDestinationInSource` is carried out for the top +-- directory for basic sanity, because otherwise we might end up with an +-- infinite copy loop... however, this operation is not carried out +-- recursively (because it's slow) +-- * does not check whether the destination already exists or is empty +-- +-- Throws: - `throwDestinationInSource` +-- - anything `copyDir`, `recreateSymlink` or `copyFile` throws +-- - `userError` for unhandled file types +copyDirRecursive :: Path Abs -- ^ source dir + -> Path Abs -- ^ full destination + -> IO () +copyDirRecursive fromp destdirp = do - let destdirp = top P. fn -- for performance, sanity checks are only done for the top dir throwDestinationInSource fromp destdirp - throwSameFile fromp destdirp - throwCantOpenDirectory fromp - throwCantOpenDirectory top - go cm from to fn + go fromp destdirp where - go :: CopyMode -> File a -> File a -> Path Fn -> IO () - go cm' Dir{ path = fromp' } - Dir{ path = top' } - fn' = do - fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus - (P.fromAbs fromp') - createDestdir (top' P. fn') fmode' - destdir <- readFile (\_ -> return undefined) - (top' P. fn') - contents <- readDirectoryContents - (\_ -> return undefined) fromp' + 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' - for_ contents $ \f -> - case f of - SymLink{ path = fp' } -> recreateSymlink cm' f destdir - =<< (P.basename fp') - Dir{ path = fp' } -> go cm' f destdir - =<< (P.basename fp') - RegFile{ path = fp' } -> unsafeCopyFile Replace f destdir - =<< (P.basename fp') - _ -> return () - where - createDestdir destdir fmode' = - let destdir' = P.toFilePath destdir - in case cm' of - Merge -> - unlessM (doesDirectoryExist destdir) - (createDirectory destdir' fmode') - Strict -> do - throwDirDoesExist destdir - createDirectory destdir' fmode' - Replace -> do - whenM (doesDirectoryExist destdir) - (deleteDirRecursive =<< - readFile - (\_ -> return undefined) destdir) - createDirectory destdir' fmode' - _ -> throw $ InvalidOperation "Internal error, wrong CopyMode!" - go _ _ _ _ = throw $ InvalidOperation "wrong input type" -copyDir _ _ _ _ = throw $ InvalidOperation "wrong input type" + fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (P.fromAbs fromp') + createDirectory (P.fromAbs destdirp') fmode' + + for_ contents $ \f -> do + ftype <- getFileType f + newdest <- (destdirp' P.) <$> P.basename f + case ftype of + SymbolicLink -> recreateSymlink f newdest + Directory -> go f newdest + RegularFile -> copyFile f newdest + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype -- |Recreate a symlink. -recreateSymlink :: CopyMode - -> File a -- ^ the old symlink file - -> File a -- ^ destination dir of the - -- new symlink file - -> Path Fn -- ^ destination file name +-- +-- Throws: - anything `readSymbolicLink` or `createSymbolicLink` throws +recreateSymlink :: Path Abs -- ^ the old symlink file + -> Path Abs -- ^ destination file -> IO () -recreateSymlink (Rename pn) symf@SymLink{} symdest@Dir{} _ - = recreateSymlink Strict symf symdest pn -recreateSymlink cm SymLink{ path = sfp } Dir{ path = sdp } fn +recreateSymlink symsource newsym = do - throwCantOpenDirectory sdp - sympoint <- readSymbolicLink (P.fromAbs sfp) - let symname = sdp P. fn - case cm of - Merge -> delOld symname - Replace -> delOld symname - _ -> return () - createSymbolicLink sympoint (P.fromAbs symname) - where - delOld symname = do - f <- readFile (\_ -> return undefined) symname - unless (failed f) - (easyDelete f) -recreateSymlink _ _ _ _ = throw $ InvalidOperation "wrong input type" + sympoint <- readSymbolicLink (P.fromAbs symsource) + createSymbolicLink sympoint (P.fromAbs newsym) -- |Copies the given regular file to the given dir with the given filename. -- Excludes symlinks. -copyFile :: CopyMode - -> File a -- ^ source file - -> File a -- ^ destination dir - -> Path Fn -- ^ destination file name +copyFile :: Path Abs -- ^ source file + -> Path Abs -- ^ destination file -> IO () -copyFile (Rename pn) from@RegFile{} to@Dir{} _ - = copyFile Strict from to pn -copyFile cm from@RegFile{ path = fromp } - tod@Dir{ path = todp } fn - = do - throwCantOpenDirectory todp - throwCantOpenDirectory . P.dirname $ fromp - throwSameFile fromp (todp P. fn) - unsafeCopyFile cm from tod fn -copyFile _ _ _ _ = throw $ InvalidOperation "wrong input type" - - --- |Unsafe version of `copyFile` without initial sanity checks. This --- holds the actual copy logic though and is called by `copyFile` in the end. --- It's also used for cases where we don't need/want sanity checks --- and need the extra bit of performance. -unsafeCopyFile :: CopyMode - -> File a -- ^ source file - -> File a -- ^ destination dir - -> Path Fn -- ^ destination file name - -> IO () -unsafeCopyFile (Rename pn) from@RegFile{} to@Dir{} _ - = copyFile Strict from to pn -unsafeCopyFile cm RegFile{ path = fromp } - Dir{ path = todp } fn - = do - let to = todp P. fn - case cm of - Strict -> throwFileDoesExist to - _ -> return () - +copyFile from to + = -- from sendfile(2) manpage: -- Applications may wish to fall back to read(2)/write(2) in the case -- where sendfile() fails with EINVAL or ENOSYS. - P.withAbsPath to $ \to' -> P.withAbsPath fromp $ \from' -> + P.withAbsPath to $ \to' -> P.withAbsPath from $ \from' -> catchErrno [eINVAL, eNOSYS] (sendFileCopy from' to') (void $ fallbackCopy from' to') where -- this is low-level stuff utilizing sendfile(2) for speed sendFileCopy source dest = - -- NOTE: we are not blocking IO here, O_NONBLOCK is false - -- for `defaultFileFlags` - bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags) + bracket (SPDT.openFd source SPI.ReadOnly [SPDF.oNofollow] Nothing) SPI.closeFd $ \sfd -> do fileM <- System.Posix.Files.ByteString.fileMode <$> getFdStatus sfd - bracket (SPI.openFd dest SPI.WriteOnly (Just fileM) - SPI.defaultFileFlags) - SPI.closeFd - $ \dfd -> sendfileFd dfd sfd EntireFile + bracketeer (SPI.openFd dest SPI.WriteOnly (Just fileM) + SPI.defaultFileFlags { exclusive = True }) + 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 (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags) + bracket (SPDT.openFd source SPI.ReadOnly [SPDF.oNofollow] Nothing) SPI.closeFd $ \sfd -> do fileM <- System.Posix.Files.ByteString.fileMode <$> getFdStatus sfd - bracket (SPI.openFd dest SPI.WriteOnly (Just fileM) - SPI.defaultFileFlags) - SPI.closeFd - $ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf -> - write' sfd dfd buf 0 + bracketeer (SPI.openFd dest SPI.WriteOnly (Just fileM) + SPI.defaultFileFlags { exclusive = True }) + SPI.closeFd + (\fd -> SPI.closeFd fd >> deleteFile to) + $ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf -> + write' sfd dfd buf 0 where bufSize :: CSize bufSize = 8192 @@ -387,25 +328,29 @@ unsafeCopyFile cm RegFile{ path = fromp } else do rsize <- SPB.fdWriteBuf dfd buf size when (rsize /= size) (throw . CopyFailed $ "wrong size!") write' sfd dfd buf (totalsize + fromIntegral size) -unsafeCopyFile _ _ _ _ = throw $ InvalidOperation "wrong input type" --- |Copies a regular file, directory or symlink. In case of a symlink, +-- |Copies anything. In case of a symlink, -- it is just recreated, even if it points to a directory. -easyCopy :: CopyMode - -> File a - -> File a +-- +-- This may not be particularly safe, because: +-- * filetypes must be figured out explicitly for the input argument +-- to make a useful decision of what to do next... this means when the +-- syscall is triggered, there is a slight chance that the filetype might +-- already be a different one, resulting in an unexpected codepath +-- * calls `copyDirRecursive` for directories +easyCopy :: Path Abs + -> Path Abs -> IO () -easyCopy cm from@SymLink{} - to@Dir{} - = recreateSymlink cm from to =<< (P.basename . path $ from) -easyCopy cm from@RegFile{} - to@Dir{} - = copyFile cm from to =<< (P.basename . path $ from) -easyCopy cm from@Dir{} - to@Dir{} - = copyDir cm from to =<< (P.basename . path $ from) -easyCopy _ _ _ = throw $ InvalidOperation "wrong input type" +easyCopy from to = do + ftype <- getFileType from + case ftype of + SymbolicLink -> recreateSymlink from to + RegularFile -> copyFile from to + Directory -> copyDirRecursive from to + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype + @@ -416,60 +361,60 @@ easyCopy _ _ _ = throw $ InvalidOperation "wrong input type" --------------------- --- |Deletes a symlink, which can either point to a file or directory. -deleteSymlink :: File a -> IO () -deleteSymlink SymLink{ path = fp } - = P.withAbsPath fp removeLink -deleteSymlink _ = throw $ InvalidOperation "wrong input type" +-- |Deletes the given file, does not follow symlinks. Raises `eISDIR` +-- if run on a directory. +deleteFile :: Path Abs -> IO () +deleteFile p = P.withAbsPath p removeLink --- |Deletes the given regular file, never symlinks. -deleteFile :: File a -> IO () -deleteFile RegFile{ path = fp } - = P.withAbsPath fp removeLink -deleteFile _ = throw $ InvalidOperation "wrong input type" - - --- |Deletes the given directory, never symlinks. -deleteDir :: File a -> IO () -deleteDir Dir{ path = fp } - = P.withAbsPath fp removeDirectory -deleteDir _ = throw $ InvalidOperation "wrong input type" +-- |Deletes the given directory, which must be empty, never symlinks. +deleteDir :: Path Abs -> IO () +deleteDir p = P.withAbsPath p removeDirectory -- |Deletes the given directory recursively. -deleteDirRecursive :: File a -> IO () -deleteDirRecursive f'@Dir{ path = fp' } = do - throwCantOpenDirectory fp' - go f' - where - go :: File a -> IO () - go Dir{ path = fp } = do - files <- readDirectoryContents - (\_ -> return undefined) fp - for_ files $ \file -> - case file of - SymLink{} -> deleteSymlink file - Dir{} -> go file - RegFile{ path = rfp } - -> P.withAbsPath rfp removeLink - _ -> throw $ FileDoesExist - (P.toFilePath . path $ file) - removeDirectory . P.toFilePath $ fp - go _ = throw $ InvalidOperation "wrong input type" -deleteDirRecursive _ = throw $ InvalidOperation "wrong input type" +-- +-- This function may not be particularly safe, because: +-- * multiple syscalls are required, so this is not an atomic +-- operation and a lot of stuff can happen in-between those syscalls +-- to the filesystem +-- * filetypes must be figured out explicitly for the contents of a directory +-- to make a useful decision of what to do next... this means when the +-- syscall is triggered, there is a slight chance that the filetype might +-- already be a different one, resulting in an unexpected codepath +deleteDirRecursive :: Path Abs -> IO () +deleteDirRecursive p = do + files <- getDirsFiles p + for_ files $ \file -> do + ftype <- getFileType file + case ftype of + SymbolicLink -> deleteFile file + Directory -> deleteDirRecursive file + RegularFile -> deleteFile file + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype + removeDirectory . P.toFilePath $ p -- |Deletes a file, directory or symlink, whatever it may be. -- In case of directory, performs recursive deletion. In case of -- a symlink, the symlink file is deleted. -easyDelete :: File a -> IO () -easyDelete f@SymLink{} = deleteSymlink f -easyDelete f@RegFile{} - = deleteFile f -easyDelete f@Dir{} - = deleteDirRecursive f -easyDelete _ = throw $ InvalidOperation "wrong input type" +-- +-- This function may not be particularly safe, because: +-- * filetypes must be figured out explicitly for the input argument +-- to make a useful decision of what to do next... this means when the +-- syscall is triggered, there is a slight chance that the filetype might +-- already be a different one, resulting in an unexpected codepath +-- * it calls `deleteDirRecursive` for directories +easyDelete :: Path Abs -> IO () +easyDelete p = do + ftype <- getFileType p + case ftype of + SymbolicLink -> deleteFile p + Directory -> deleteDirRecursive p + RegularFile -> deleteFile p + _ -> ioError $ userError $ "No idea what to do with the" ++ + "given filetype: " ++ show ftype @@ -481,26 +426,21 @@ easyDelete _ = throw $ InvalidOperation "wrong input type" -- |Opens a file appropriately by invoking xdg-open. The file type -- is not checked. -openFile :: File a +openFile :: Path Abs -> IO ProcessID -openFile f = - P.withAbsPath (path f) $ \fp -> +openFile p = + P.withAbsPath p $ \fp -> SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing -- |Executes a program with the given arguments. -executeFile :: File a -- ^ program +executeFile :: Path Abs -- ^ program -> [ByteString] -- ^ arguments -> IO ProcessID -executeFile RegFile{ path = fp } args +executeFile fp args = P.withAbsPath fp $ \fpb -> SPP.forkProcess $ SPP.executeFile fpb True args Nothing -executeFile SymLink{ path = fp, sdest = RegFile{} } args - = P.withAbsPath fp $ \fpb -> - SPP.forkProcess - $ SPP.executeFile fpb True args Nothing -executeFile _ _ = throw $ InvalidOperation "wrong input type" @@ -511,22 +451,18 @@ executeFile _ _ = throw $ InvalidOperation "wrong input type" -- |Create an empty regular file at the given directory with the given filename. -createFile :: File FileInfo -> Path Fn -> IO () -createFile (DirOrSym td) fn = do - let fullp = path td P. fn - throwFileDoesExist fullp - fd <- SPI.createFile (P.fromAbs fullp) newFilePerms - SPI.closeFd fd -createFile _ _ = throw $ InvalidOperation "wrong input type" +createRegularFile :: Path Abs -> IO () +createRegularFile dest = + bracket (SPI.openFd (P.fromAbs dest) SPI.WriteOnly (Just newFilePerms) + (SPI.defaultFileFlags { exclusive = True })) + SPI.closeFd + (\_ -> return ()) -- |Create an empty directory at the given directory with the given filename. -createDir :: File FileInfo -> Path Fn -> IO () -createDir (DirOrSym td) fn = do - let fullp = path td P. fn - throwDirDoesExist fullp - createDirectory (P.fromAbs fullp) newFilePerms -createDir _ _ = throw $ InvalidOperation "wrong input type" +-- If the directory already exists, does nothing. +createDir :: Path Abs -> IO () +createDir dest = createDirectory (P.fromAbs dest) newDirPerms @@ -536,51 +472,32 @@ createDir _ _ = throw $ InvalidOperation "wrong input type" ---------------------------- --- |Rename a given file with the provided filename. -renameFile :: File a -> Path Fn -> IO () -renameFile af fn = do - let fromf = path af - tof = (P.dirname . path $ af) P. fn - throwFileDoesExist tof +-- |Rename a given file with the provided filename. Destination and source +-- must be on the same device, otherwise `eXDEV` will be raised. +-- +-- Calls `rename`, but does not allow to rename over existing files. +renameFile :: Path Abs -> Path Abs -> IO () +renameFile fromf tof = do throwSameFile fromf tof + throwFileDoesExist tof + throwDirDoesExist tof rename (P.fromAbs fromf) (P.fromAbs tof) --- |Move a given file to the given target directory. -moveFile :: CopyMode - -> File a -- ^ file to move - -> File a -- ^ base target directory - -> Path Fn -- ^ target file name +-- |Move a file. This also works across devices by copy-delete fallback. +-- And also works on directories. +-- +-- Note that this operation is not particularly safe or reliable, since +-- the fallback of copy-delete is not atomic. +moveFile :: Path Abs -- ^ file to move + -> Path Abs -- ^ destination -> IO () -moveFile (Rename pn) from to@Dir{} _ = - moveFile Strict from to pn -moveFile cm from to@Dir{} fn = do - let from' = path from - froms' = P.fromAbs from' - to' = path to P. fn - tos' = P.fromAbs to' - case cm of - Strict -> throwFileDoesExist to' - Merge -> delOld to' - Replace -> delOld to' - Rename _ -> throw $ InvalidOperation "Internal error! Wrong CopyMode!" - throwSameFile from' to' - catchErrno [eXDEV] (rename froms' tos') $ do - easyCopy Strict from to +moveFile from to = + catchErrno [eXDEV] (renameFile from to) $ do + easyCopy from to easyDelete from - where - delOld fp = do - to' <- readFile (\_ -> return undefined) fp - unless (failed to') (easyDelete to') -moveFile _ _ _ _ = throw $ InvalidOperation "wrong input type" --- |Like `moveFile` except it uses the filename of the source as target. -easyMove :: CopyMode - -> File a -- ^ file to move - -> File a -- ^ base target directory - -> IO () -easyMove cm from to = moveFile cm from to =<< (P.basename . path $ from) @@ -609,3 +526,49 @@ newDirPerms `unionFileModes` otherExecuteMode `unionFileModes` otherReadMode + + + ------------------------- + --[ Directory reading ]-- + ------------------------- + + +-- |Gets all filenames of the given directory. This excludes "." and "..". +getDirsFiles :: Path Abs -- ^ dir to read + -> IO [Path Abs] +getDirsFiles p = + P.withAbsPath p $ \fp -> + bracketOnError (SPDT.openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing) + SPI.closeFd + $ \fd -> + return + . catMaybes + . fmap (\x -> (P.) p <$> (parseMaybe . snd $ x)) + =<< getDirectoryContents' fd + where + parseMaybe :: ByteString -> Maybe (Path Fn) + parseMaybe = P.parseFn + + + + + --------------------------- + --[ FileType operations ]-- + --------------------------- + + +getFileType :: Path Abs -> IO FileType +getFileType p = do + fs <- PF.getSymbolicLinkStatus (P.fromAbs p) + decide fs + where + decide fs + | PF.isDirectory fs = return Directory + | PF.isRegularFile fs = return RegularFile + | PF.isSymbolicLink fs = return SymbolicLink + | PF.isBlockDevice fs = return BlockDevice + | PF.isCharacterDevice fs = return CharacterDevice + | PF.isNamedPipe fs = return NamedPipe + | PF.isSocket fs = return Socket + | otherwise = ioError $ userError "No filetype?!" + diff --git a/src/HSFM/FileSystem/FileType.hs b/src/HSFM/FileSystem/FileType.hs index 18f0795..ac9a840 100644 --- a/src/HSFM/FileSystem/FileType.hs +++ b/src/HSFM/FileSystem/FileType.hs @@ -18,39 +18,44 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. {-# OPTIONS_HADDOCK ignore-exports #-} --- |This module provides data types for representing directories/files --- and related operations on it, mostly internal stuff. + +-- |This module provides a data type for representing directories/files +-- in a well-typed and convenient way. This is useful to gather and +-- save information about a file, so the information can be easily +-- processed in e.g. a GUI. -- --- It doesn't allow to represent the whole filesystem, since that's only --- possible through IO laziness, which introduces too much internal state. +-- However, it's not meant to be used to interact with low-level +-- functions that copy files etc, since there's no guarantee that +-- the in-memory representation of the type still matches what is +-- happening on filesystem level. +-- +-- If you interact with low-level libraries, you must not pattern +-- match on the `File a` type. Instead, you should only use the saved +-- `path` and make no assumptions about the file the path might or +-- might not point to. module HSFM.FileSystem.FileType where import Data.ByteString(ByteString) import Data.Default -import Data.Maybe - ( - catMaybes - ) import Data.Time.Clock.POSIX ( POSIXTime , posixSecondsToUTCTime ) import Data.Time() -import Foreign.C.Error - ( - eACCES - ) import HPath ( Abs , Path - , Fn ) import qualified HPath as P import HSFM.FileSystem.Errors +import HSFM.FileSystem.FileOperations + ( + getDirsFiles + ) import HSFM.Utils.MyPrelude import Prelude hiding(readFile) import System.IO.Error @@ -64,8 +69,7 @@ import System.Posix.FilePath ) import System.Posix.Directory.Traversals ( - getDirectoryContents - , realpath + realpath ) import qualified System.Posix.Files.ByteString as PF import System.Posix.Types @@ -93,8 +97,7 @@ import System.Posix.Types -- |The String in the path field is always a full path. -- The free type variable is used in the File/Dir constructor and can hold -- Handles, Strings representing a file's contents or anything else you can --- think of. We catch any IO errors in the Failed constructor. an Exception --- can be converted to a String with 'show'. +-- think of. We catch any IO errors in the Failed constructor. data File a = Failed { path :: !(Path Abs) @@ -461,19 +464,7 @@ isSocketC _ = False ---- IO HELPERS: ---- --- |Gets all filenames of the given directory. This excludes "." and "..". -getDirsFiles :: Path Abs -- ^ dir to read - -> IO [Path Abs] -getDirsFiles p = - P.withAbsPath p $ \fp -> - rethrowErrnoAs [eACCES] (Can'tOpenDirectory fp) - $ return - . catMaybes - . fmap (\x -> (P.) p <$> (parseMaybe . snd $ x)) - =<< getDirectoryContents fp - where - parseMaybe :: ByteString -> Maybe (Path Fn) - parseMaybe = P.parseFn + -- |Gets all file information.