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
| 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

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 #-}
{-# 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?!"

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 #-}
-- |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.