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

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.
This commit is contained in:
Julian Ospald 2016-05-02 19:06:53 +02:00
parent 1be9ecb44e
commit 47cd43dba6
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
3 changed files with 332 additions and 343 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -72,7 +72,7 @@ data FmIOException = FileDoesNotExist ByteString
| Can'tOpenDirectory ByteString | Can'tOpenDirectory ByteString
| CopyFailed String | CopyFailed String
| MoveFailed String | MoveFailed String
deriving (Typeable) deriving (Typeable, Eq)
instance Show FmIOException where 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 ]-- --[ Path based functions ]--
@ -126,14 +146,14 @@ throwDirDoesExist fp =
throwFileDoesNotExist :: Path Abs -> IO () throwFileDoesNotExist :: Path Abs -> IO ()
throwFileDoesNotExist fp = throwFileDoesNotExist fp =
whenM (doesFileExist fp) (throw . FileDoesExist unlessM (doesFileExist fp) (throw . FileDoesNotExist
. P.fromAbs $ fp) . P.fromAbs $ fp)
throwDirDoesNotExist :: Path Abs -> IO () throwDirDoesNotExist :: Path Abs -> IO ()
throwDirDoesNotExist fp = throwDirDoesNotExist fp =
whenM (doesDirectoryExist fp) (throw . DirDoesExist unlessM (doesDirectoryExist fp) (throw . DirDoesNotExist
. P.fromAbs $ fp) . P.fromAbs $ fp)
throwSameFile :: Path Abs -- ^ will be canonicalized throwSameFile :: Path Abs -- ^ will be canonicalized
@ -172,28 +192,26 @@ throwDestinationInSource source dest = do
(P.fromAbs source)) (P.fromAbs source))
-- |Checks if the given file exists and is not a directory. This follows -- |Checks if the given file exists and is not a directory.
-- symlinks, but will return True if the symlink is broken. -- Does not follow symlinks.
doesFileExist :: Path Abs -> IO Bool doesFileExist :: Path Abs -> IO Bool
doesFileExist fp = doesFileExist fp =
handleIOError (\_ -> return False) $ do handleIOError (\_ -> return False) $ do
fp' <- fmap P.fromAbs $ P.canonicalizePath fp fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
fs <- PF.getFileStatus fp'
return $ not . PF.isDirectory $ fs return $ not . PF.isDirectory $ fs
-- |Checks if the given file exists and is a directory. This follows -- |Checks if the given file exists and is a directory.
-- symlinks, but will return False if the symlink is broken. -- Does not follow symlinks.
doesDirectoryExist :: Path Abs -> IO Bool doesDirectoryExist :: Path Abs -> IO Bool
doesDirectoryExist fp = doesDirectoryExist fp =
handleIOError (\_ -> return False) $ do handleIOError (\_ -> return False) $ do
fp' <- fmap P.fromAbs $ P.canonicalizePath fp fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
fs <- PF.getFileStatus fp'
return $ PF.isDirectory fs return $ PF.isDirectory fs
-- |Checks whether the directory at the given path exists and can be -- |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 :: Path Abs -> IO Bool
canOpenDirectory fp = canOpenDirectory fp =
handleIOError (\_ -> return False) $ do 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 :: (IOError -> IO a) -> IO a -> IO a
handleIOError = flip catchIOError 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

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

@ -20,24 +20,21 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# OPTIONS_HADDOCK ignore-exports #-} {-# OPTIONS_HADDOCK ignore-exports #-}
-- |This module provides all the atomic IO related file operations like -- |This module provides high-level IO related file operations like
-- copy, delete, move and so on. It operates primarily on `AnchoredFile`, which -- copy, delete, move and so on. It only operates on `Path Abs` which
-- is guaranteed to be well-formed. -- guarantees us well-typed path which are absolute.
--
-- 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.
module HSFM.FileSystem.FileOperations where module HSFM.FileSystem.FileOperations where
import Control.Exception import Control.Exception
( (
bracket bracket
, bracketOnError
, throw , throw
) )
import Control.Monad import Control.Monad
( (
unless forM_
, void , void
, when , when
) )
@ -49,15 +46,20 @@ import Data.Foldable
( (
for_ for_
) )
import Data.Maybe
(
catMaybes
)
import Data.Word import Data.Word
( (
Word8 Word8
) )
import Foreign.C.Error import Foreign.C.Error
( (
eXDEV eACCES
, eINVAL , eINVAL
, eNOSYS , eNOSYS
, eXDEV
) )
import Foreign.C.Types import Foreign.C.Types
( (
@ -79,14 +81,25 @@ import HPath
) )
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.Errors import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileType
import HSFM.Utils.IO import HSFM.Utils.IO
(
unlessM
)
import Prelude hiding (readFile) import Prelude hiding (readFile)
import System.Posix.ByteString
(
exclusive
)
import System.Posix.Directory.ByteString import System.Posix.Directory.ByteString
( (
createDirectory createDirectory
, removeDirectory , removeDirectory
) )
import System.Posix.Directory.Traversals
(
getDirectoryContents
, getDirectoryContents'
)
import System.Posix.Files.ByteString import System.Posix.Files.ByteString
( (
createSymbolicLink createSymbolicLink
@ -109,6 +122,8 @@ import System.Posix.Files.ByteString
import qualified System.Posix.Files.ByteString as PF import qualified System.Posix.Files.ByteString as PF
import qualified "unix" System.Posix.IO.ByteString as SPI import qualified "unix" System.Posix.IO.ByteString as SPI
import qualified "unix-bytestring" System.Posix.IO.ByteString as SPB 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 import System.Posix.IO.Sendfile.ByteString
( (
sendfileFd sendfileFd
@ -127,10 +142,11 @@ import System.Posix.Types
-- TODO: file operations should be threaded and not block the UI -- TODO: file operations should be threaded and not block the UI
-- TODO: make sure we do the right thing for BlockDev, CharDev etc... -- TODO: make sure we do the right thing for BlockDev, CharDev etc...
-- most operations are not implemented for these -- 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 -- |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. -- or delay operations.
data FileOperation = FCopy Copy data FileOperation = FCopy Copy
| FMove Move | FMove Move
@ -142,29 +158,25 @@ data FileOperation = FCopy Copy
-- |Data type describing partial or complete file copy operation. -- |Data type describing partial or complete file copy operation.
-- CC stands for a complete operation and can be used for `runFileOp`. -- CC stands for a complete operation and can be used for `runFileOp`.
data Copy = CP1 [Path Abs] data Copy = PartialCopy [Path Abs]
| CP2 [Path Abs] | Copy [Path Abs] (Path Abs)
(Path Abs)
| CC [Path Abs]
(Path Abs)
CopyMode
-- |Data type describing partial or complete file move operation. -- |Data type describing partial or complete file move operation.
-- MC stands for a complete operation and can be used for `runFileOp`. -- MC stands for a complete operation and can be used for `runFileOp`.
data Move = MP1 [Path Abs] data Move = PartialMove [Path Abs]
| MC [Path Abs] | Move [Path Abs] (Path Abs)
(Path Abs)
CopyMode
-- |Copy modes. data FileType = Directory
data CopyMode = Strict -- ^ fail if the target already exists | RegularFile
| Merge -- ^ overwrite files if necessary, for files, this | SymbolicLink
-- is the same as Replace | BlockDevice
| Replace -- ^ remove targets before copying, this is | CharacterDevice
-- only useful if the target is a directorty | NamedPipe
| Rename (Path Fn) | Socket
deriving (Show)
-- |Run a given FileOperation. If the FileOperation is partial, it will -- |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 :: FileOperation -> IO (Maybe FileOperation)
runFileOp fo' = runFileOp fo' =
case fo' of case fo' of
(FCopy (CC froms to cm)) -> do (FCopy (Copy froms to)) -> do
froms' <- mapM toAfile froms forM_ froms $ \x -> do
to' <- toAfile to toname <- P.basename x
when (anyFailed froms') easyCopy x (to P.</> toname)
(throw . CopyFailed $ "File in copy buffer does not exist anymore!") return Nothing
mapM_ (\x -> easyCopy cm x to') froms'
>> return Nothing
(FCopy fo) -> return $ Just $ FCopy fo (FCopy fo) -> return $ Just $ FCopy fo
(FMove (MC froms to cm)) -> do (FMove (Move froms to)) -> do
froms' <- mapM toAfile froms forM_ froms $ \x -> do
to' <- toAfile to toname <- P.basename x
when (anyFailed froms') moveFile x (to P.</> toname)
(throw . MoveFailed $ "File in move buffer does not exist anymore!") return Nothing
mapM_ (\x -> easyMove cm x to') froms'
>> return Nothing
(FMove fo) -> return $ Just $ FMove fo (FMove fo) -> return $ Just $ FMove fo
(FDelete fps) -> do (FDelete fps) ->
fps' <- mapM toAfile fps mapM_ easyDelete fps >> return Nothing
mapM_ easyDelete fps' >> return Nothing (FOpen fp) -> openFile fp >> return Nothing
(FOpen fp) -> (FExecute fp args) -> executeFile fp args >> return Nothing
toAfile fp >>= openFile >> return Nothing
(FExecute fp args) ->
toAfile fp >>= flip executeFile args >> return Nothing
_ -> 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 -- |Copies a directory to the given destination with the specified
-- `DirCopyMode`. Excludes symlinks. -- `DirCopyMode`. Excludes symlinks.
copyDir :: CopyMode --
-> File a -- ^ source dir -- This operation may not be safe on directories that are written to
-> File a -- ^ destination dir -- while this operation happens. There are several reasons:
-> Path Fn -- ^ destination dir name -- * multiple syscalls are required, so this is not an atomic
-> IO () -- operation and a lot of stuff can happen in-between those syscalls
copyDir (Rename fn) -- to the filesystem
from@Dir{} -- * filetypes must be figured out explicitly for the contents of a directory
to@Dir{} -- 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
= copyDir Strict from to fn -- already be a different one, resulting in an unexpected codepath
-- this branch must never get `Rename` as CopyMode -- * an explicit check `throwDestinationInSource` is carried out for the top
copyDir cm from@Dir{ path = fromp } -- directory for basic sanity, because otherwise we might end up with an
to@Dir{ path = top } -- infinite copy loop... however, this operation is not carried out
fn -- 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 = do
let destdirp = top P.</> fn
-- for performance, sanity checks are only done for the top dir -- for performance, sanity checks are only done for the top dir
throwDestinationInSource fromp destdirp throwDestinationInSource fromp destdirp
throwSameFile fromp destdirp go fromp destdirp
throwCantOpenDirectory fromp
throwCantOpenDirectory top
go cm from to fn
where where
go :: CopyMode -> File a -> File a -> Path Fn -> IO () go :: Path Abs -> Path Abs -> IO ()
go cm' Dir{ path = fromp' } go fromp' destdirp' = do
Dir{ path = top' } -- order is important here, so we don't get empty directories
fn' = do -- on failure
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus contents <- getDirsFiles fromp'
(P.fromAbs fromp')
createDestdir (top' P.</> fn') fmode'
destdir <- readFile (\_ -> return undefined)
(top' P.</> fn')
contents <- readDirectoryContents
(\_ -> return undefined) fromp'
for_ contents $ \f -> fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (P.fromAbs fromp')
case f of createDirectory (P.fromAbs destdirp') fmode'
SymLink{ path = fp' } -> recreateSymlink cm' f destdir
=<< (P.basename fp') for_ contents $ \f -> do
Dir{ path = fp' } -> go cm' f destdir ftype <- getFileType f
=<< (P.basename fp') newdest <- (destdirp' P.</>) <$> P.basename f
RegFile{ path = fp' } -> unsafeCopyFile Replace f destdir case ftype of
=<< (P.basename fp') SymbolicLink -> recreateSymlink f newdest
_ -> return () Directory -> go f newdest
where RegularFile -> copyFile f newdest
createDestdir destdir fmode' = _ -> ioError $ userError $ "No idea what to do with the" ++
let destdir' = P.toFilePath destdir "given filetype: " ++ show ftype
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"
-- |Recreate a symlink. -- |Recreate a symlink.
recreateSymlink :: CopyMode --
-> File a -- ^ the old symlink file -- Throws: - anything `readSymbolicLink` or `createSymbolicLink` throws
-> File a -- ^ destination dir of the recreateSymlink :: Path Abs -- ^ the old symlink file
-- new symlink file -> Path Abs -- ^ destination file
-> Path Fn -- ^ destination file name
-> IO () -> IO ()
recreateSymlink (Rename pn) symf@SymLink{} symdest@Dir{} _ recreateSymlink symsource newsym
= recreateSymlink Strict symf symdest pn
recreateSymlink cm SymLink{ path = sfp } Dir{ path = sdp } fn
= do = do
throwCantOpenDirectory sdp sympoint <- readSymbolicLink (P.fromAbs symsource)
sympoint <- readSymbolicLink (P.fromAbs sfp) createSymbolicLink sympoint (P.fromAbs newsym)
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"
-- |Copies the given regular file to the given dir with the given filename. -- |Copies the given regular file to the given dir with the given filename.
-- Excludes symlinks. -- Excludes symlinks.
copyFile :: CopyMode copyFile :: Path Abs -- ^ source file
-> File a -- ^ source file -> Path Abs -- ^ destination file
-> File a -- ^ destination dir
-> Path Fn -- ^ destination file name
-> IO () -> IO ()
copyFile (Rename pn) from@RegFile{} to@Dir{} _ copyFile from to
= 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 ()
-- from sendfile(2) manpage: -- from sendfile(2) manpage:
-- Applications may wish to fall back to read(2)/write(2) in the case -- Applications may wish to fall back to read(2)/write(2) in the case
-- where sendfile() fails with EINVAL or ENOSYS. -- 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] catchErrno [eINVAL, eNOSYS]
(sendFileCopy from' to') (sendFileCopy from' to')
(void $ fallbackCopy from' to') (void $ fallbackCopy from' to')
where where
-- this is low-level stuff utilizing sendfile(2) for speed -- this is low-level stuff utilizing sendfile(2) for speed
sendFileCopy source dest = sendFileCopy source dest =
-- NOTE: we are not blocking IO here, O_NONBLOCK is false bracket (SPDT.openFd source SPI.ReadOnly [SPDF.oNofollow] Nothing)
-- for `defaultFileFlags`
bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags)
SPI.closeFd SPI.closeFd
$ \sfd -> do $ \sfd -> do
fileM <- System.Posix.Files.ByteString.fileMode fileM <- System.Posix.Files.ByteString.fileMode
<$> getFdStatus sfd <$> getFdStatus sfd
bracket (SPI.openFd dest SPI.WriteOnly (Just fileM) bracketeer (SPI.openFd dest SPI.WriteOnly (Just fileM)
SPI.defaultFileFlags) SPI.defaultFileFlags { exclusive = True })
SPI.closeFd SPI.closeFd
$ \dfd -> sendfileFd dfd sfd EntireFile (\fd -> SPI.closeFd fd >> deleteFile to)
$ \dfd -> sendfileFd dfd sfd EntireFile
-- low-level copy operation utilizing read(2)/write(2) -- low-level copy operation utilizing read(2)/write(2)
-- in case `sendFileCopy` fails/is unsupported -- in case `sendFileCopy` fails/is unsupported
fallbackCopy source dest = fallbackCopy source dest =
bracket (SPI.openFd source SPI.ReadOnly Nothing SPI.defaultFileFlags) bracket (SPDT.openFd source SPI.ReadOnly [SPDF.oNofollow] Nothing)
SPI.closeFd SPI.closeFd
$ \sfd -> do $ \sfd -> do
fileM <- System.Posix.Files.ByteString.fileMode fileM <- System.Posix.Files.ByteString.fileMode
<$> getFdStatus sfd <$> getFdStatus sfd
bracket (SPI.openFd dest SPI.WriteOnly (Just fileM) bracketeer (SPI.openFd dest SPI.WriteOnly (Just fileM)
SPI.defaultFileFlags) SPI.defaultFileFlags { exclusive = True })
SPI.closeFd SPI.closeFd
$ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf -> (\fd -> SPI.closeFd fd >> deleteFile to)
write' sfd dfd buf 0 $ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf ->
write' sfd dfd buf 0
where where
bufSize :: CSize bufSize :: CSize
bufSize = 8192 bufSize = 8192
@ -387,25 +328,29 @@ unsafeCopyFile cm RegFile{ path = fromp }
else do rsize <- SPB.fdWriteBuf dfd buf size else do rsize <- SPB.fdWriteBuf dfd buf size
when (rsize /= size) (throw . CopyFailed $ "wrong size!") when (rsize /= size) (throw . CopyFailed $ "wrong size!")
write' sfd dfd buf (totalsize + fromIntegral 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. -- it is just recreated, even if it points to a directory.
easyCopy :: CopyMode --
-> File a -- This may not be particularly safe, because:
-> File a -- * 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 () -> IO ()
easyCopy cm from@SymLink{} easyCopy from to = do
to@Dir{} ftype <- getFileType from
= recreateSymlink cm from to =<< (P.basename . path $ from) case ftype of
easyCopy cm from@RegFile{} SymbolicLink -> recreateSymlink from to
to@Dir{} RegularFile -> copyFile from to
= copyFile cm from to =<< (P.basename . path $ from) Directory -> copyDirRecursive from to
easyCopy cm from@Dir{} _ -> ioError $ userError $ "No idea what to do with the" ++
to@Dir{} "given filetype: " ++ show ftype
= copyDir cm from to =<< (P.basename . path $ from)
easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
@ -416,60 +361,60 @@ easyCopy _ _ _ = throw $ InvalidOperation "wrong input type"
--------------------- ---------------------
-- |Deletes a symlink, which can either point to a file or directory. -- |Deletes the given file, does not follow symlinks. Raises `eISDIR`
deleteSymlink :: File a -> IO () -- if run on a directory.
deleteSymlink SymLink{ path = fp } deleteFile :: Path Abs -> IO ()
= P.withAbsPath fp removeLink deleteFile p = P.withAbsPath p removeLink
deleteSymlink _ = throw $ InvalidOperation "wrong input type"
-- |Deletes the given regular file, never symlinks. -- |Deletes the given directory, which must be empty, never symlinks.
deleteFile :: File a -> IO () deleteDir :: Path Abs -> IO ()
deleteFile RegFile{ path = fp } deleteDir p = P.withAbsPath p removeDirectory
= 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 recursively. -- |Deletes the given directory recursively.
deleteDirRecursive :: File a -> IO () --
deleteDirRecursive f'@Dir{ path = fp' } = do -- This function may not be particularly safe, because:
throwCantOpenDirectory fp' -- * multiple syscalls are required, so this is not an atomic
go f' -- operation and a lot of stuff can happen in-between those syscalls
where -- to the filesystem
go :: File a -> IO () -- * filetypes must be figured out explicitly for the contents of a directory
go Dir{ path = fp } = do -- to make a useful decision of what to do next... this means when the
files <- readDirectoryContents -- syscall is triggered, there is a slight chance that the filetype might
(\_ -> return undefined) fp -- already be a different one, resulting in an unexpected codepath
for_ files $ \file -> deleteDirRecursive :: Path Abs -> IO ()
case file of deleteDirRecursive p = do
SymLink{} -> deleteSymlink file files <- getDirsFiles p
Dir{} -> go file for_ files $ \file -> do
RegFile{ path = rfp } ftype <- getFileType file
-> P.withAbsPath rfp removeLink case ftype of
_ -> throw $ FileDoesExist SymbolicLink -> deleteFile file
(P.toFilePath . path $ file) Directory -> deleteDirRecursive file
removeDirectory . P.toFilePath $ fp RegularFile -> deleteFile file
go _ = throw $ InvalidOperation "wrong input type" _ -> ioError $ userError $ "No idea what to do with the" ++
deleteDirRecursive _ = throw $ InvalidOperation "wrong input type" "given filetype: " ++ show ftype
removeDirectory . P.toFilePath $ p
-- |Deletes a file, directory or symlink, whatever it may be. -- |Deletes a file, directory or symlink, whatever it may be.
-- In case of directory, performs recursive deletion. In case of -- In case of directory, performs recursive deletion. In case of
-- a symlink, the symlink file is deleted. -- a symlink, the symlink file is deleted.
easyDelete :: File a -> IO () --
easyDelete f@SymLink{} = deleteSymlink f -- This function may not be particularly safe, because:
easyDelete f@RegFile{} -- * filetypes must be figured out explicitly for the input argument
= deleteFile f -- to make a useful decision of what to do next... this means when the
easyDelete f@Dir{} -- syscall is triggered, there is a slight chance that the filetype might
= deleteDirRecursive f -- already be a different one, resulting in an unexpected codepath
easyDelete _ = throw $ InvalidOperation "wrong input type" -- * 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 -- |Opens a file appropriately by invoking xdg-open. The file type
-- is not checked. -- is not checked.
openFile :: File a openFile :: Path Abs
-> IO ProcessID -> IO ProcessID
openFile f = openFile p =
P.withAbsPath (path f) $ \fp -> P.withAbsPath p $ \fp ->
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
-- |Executes a program with the given arguments. -- |Executes a program with the given arguments.
executeFile :: File a -- ^ program executeFile :: Path Abs -- ^ program
-> [ByteString] -- ^ arguments -> [ByteString] -- ^ arguments
-> IO ProcessID -> IO ProcessID
executeFile RegFile{ path = fp } args executeFile fp args
= P.withAbsPath fp $ \fpb -> = P.withAbsPath fp $ \fpb ->
SPP.forkProcess SPP.forkProcess
$ SPP.executeFile fpb True args Nothing $ 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. -- |Create an empty regular file at the given directory with the given filename.
createFile :: File FileInfo -> Path Fn -> IO () createRegularFile :: Path Abs -> IO ()
createFile (DirOrSym td) fn = do createRegularFile dest =
let fullp = path td P.</> fn bracket (SPI.openFd (P.fromAbs dest) SPI.WriteOnly (Just newFilePerms)
throwFileDoesExist fullp (SPI.defaultFileFlags { exclusive = True }))
fd <- SPI.createFile (P.fromAbs fullp) newFilePerms SPI.closeFd
SPI.closeFd fd (\_ -> return ())
createFile _ _ = throw $ InvalidOperation "wrong input type"
-- |Create an empty directory at the given directory with the given filename. -- |Create an empty directory at the given directory with the given filename.
createDir :: File FileInfo -> Path Fn -> IO () -- If the directory already exists, does nothing.
createDir (DirOrSym td) fn = do createDir :: Path Abs -> IO ()
let fullp = path td P.</> fn createDir dest = createDirectory (P.fromAbs dest) newDirPerms
throwDirDoesExist fullp
createDirectory (P.fromAbs fullp) newFilePerms
createDir _ _ = throw $ InvalidOperation "wrong input type"
@ -536,51 +472,32 @@ createDir _ _ = throw $ InvalidOperation "wrong input type"
---------------------------- ----------------------------
-- |Rename a given file with the provided filename. -- |Rename a given file with the provided filename. Destination and source
renameFile :: File a -> Path Fn -> IO () -- must be on the same device, otherwise `eXDEV` will be raised.
renameFile af fn = do --
let fromf = path af -- Calls `rename`, but does not allow to rename over existing files.
tof = (P.dirname . path $ af) P.</> fn renameFile :: Path Abs -> Path Abs -> IO ()
throwFileDoesExist tof renameFile fromf tof = do
throwSameFile fromf tof throwSameFile fromf tof
throwFileDoesExist tof
throwDirDoesExist tof
rename (P.fromAbs fromf) (P.fromAbs tof) rename (P.fromAbs fromf) (P.fromAbs tof)
-- |Move a given file to the given target directory. -- |Move a file. This also works across devices by copy-delete fallback.
moveFile :: CopyMode -- And also works on directories.
-> File a -- ^ file to move --
-> File a -- ^ base target directory -- Note that this operation is not particularly safe or reliable, since
-> Path Fn -- ^ target file name -- the fallback of copy-delete is not atomic.
moveFile :: Path Abs -- ^ file to move
-> Path Abs -- ^ destination
-> IO () -> IO ()
moveFile (Rename pn) from to@Dir{} _ = moveFile from to =
moveFile Strict from to pn catchErrno [eXDEV] (renameFile from to) $ do
moveFile cm from to@Dir{} fn = do easyCopy from to
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
easyDelete from 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` otherExecuteMode
`unionFileModes` otherReadMode `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?!"

51
src/HSFM/FileSystem/FileType.hs
View File

@ -18,39 +18,44 @@ Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
{-# OPTIONS_HADDOCK ignore-exports #-} {-# 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 -- However, it's not meant to be used to interact with low-level
-- possible through IO laziness, which introduces too much internal state. -- 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 module HSFM.FileSystem.FileType where
import Data.ByteString(ByteString) import Data.ByteString(ByteString)
import Data.Default import Data.Default
import Data.Maybe
(
catMaybes
)
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
( (
POSIXTime POSIXTime
, posixSecondsToUTCTime , posixSecondsToUTCTime
) )
import Data.Time() import Data.Time()
import Foreign.C.Error
(
eACCES
)
import HPath import HPath
( (
Abs Abs
, Path , Path
, Fn
) )
import qualified HPath as P import qualified HPath as P
import HSFM.FileSystem.Errors import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
(
getDirsFiles
)
import HSFM.Utils.MyPrelude import HSFM.Utils.MyPrelude
import Prelude hiding(readFile) import Prelude hiding(readFile)
import System.IO.Error import System.IO.Error
@ -64,8 +69,7 @@ import System.Posix.FilePath
) )
import System.Posix.Directory.Traversals import System.Posix.Directory.Traversals
( (
getDirectoryContents realpath
, realpath
) )
import qualified System.Posix.Files.ByteString as PF import qualified System.Posix.Files.ByteString as PF
import System.Posix.Types import System.Posix.Types
@ -93,8 +97,7 @@ import System.Posix.Types
-- |The String in the path field is always a full path. -- |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 -- 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 -- 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 -- think of. We catch any IO errors in the Failed constructor.
-- can be converted to a String with 'show'.
data File a = data File a =
Failed { Failed {
path :: !(Path Abs) path :: !(Path Abs)
@ -461,19 +464,7 @@ isSocketC _ = False
---- IO HELPERS: ---- ---- 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. -- |Gets all file information.