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.