Julian Ospald
47cd43dba6
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.
575 lines
17 KiB
Haskell
575 lines
17 KiB
Haskell
{--
|
|
HSFM, a filemanager written in Haskell.
|
|
Copyright (C) 2016 Julian Ospald
|
|
|
|
This program is free software; you can redistribute it and/or
|
|
modify it under the terms of the GNU General Public License
|
|
version 2 as published by the Free Software Foundation.
|
|
|
|
This program is distributed in the hope that it will be useful,
|
|
but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
GNU General Public License for more details.
|
|
|
|
You should have received a copy of the GNU General Public License
|
|
along with this program; if not, write to the Free Software
|
|
Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
|
|
--}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE PackageImports #-}
|
|
{-# OPTIONS_HADDOCK ignore-exports #-}
|
|
|
|
-- |This module provides high-level IO related file operations like
|
|
-- copy, delete, move and so on. It only operates on `Path Abs` which
|
|
-- guarantees us well-typed path which are absolute.
|
|
module HSFM.FileSystem.FileOperations where
|
|
|
|
|
|
import Control.Exception
|
|
(
|
|
bracket
|
|
, bracketOnError
|
|
, throw
|
|
)
|
|
import Control.Monad
|
|
(
|
|
forM_
|
|
, void
|
|
, when
|
|
)
|
|
import Data.ByteString
|
|
(
|
|
ByteString
|
|
)
|
|
import Data.Foldable
|
|
(
|
|
for_
|
|
)
|
|
import Data.Maybe
|
|
(
|
|
catMaybes
|
|
)
|
|
import Data.Word
|
|
(
|
|
Word8
|
|
)
|
|
import Foreign.C.Error
|
|
(
|
|
eACCES
|
|
, eINVAL
|
|
, eNOSYS
|
|
, eXDEV
|
|
)
|
|
import Foreign.C.Types
|
|
(
|
|
CSize
|
|
)
|
|
import Foreign.Marshal.Alloc
|
|
(
|
|
allocaBytes
|
|
)
|
|
import Foreign.Ptr
|
|
(
|
|
Ptr
|
|
)
|
|
import HPath
|
|
(
|
|
Path
|
|
, Abs
|
|
, Fn
|
|
)
|
|
import qualified HPath as P
|
|
import HSFM.FileSystem.Errors
|
|
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
|
|
, fileMode
|
|
, getFdStatus
|
|
, groupExecuteMode
|
|
, groupReadMode
|
|
, groupWriteMode
|
|
, otherExecuteMode
|
|
, otherReadMode
|
|
, otherWriteMode
|
|
, ownerModes
|
|
, ownerReadMode
|
|
, ownerWriteMode
|
|
, readSymbolicLink
|
|
, removeLink
|
|
, rename
|
|
, unionFileModes
|
|
)
|
|
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
|
|
, FileRange(EntireFile)
|
|
)
|
|
import qualified System.Posix.Process.ByteString as SPP
|
|
import System.Posix.Types
|
|
(
|
|
FileMode
|
|
, ProcessID
|
|
, Fd
|
|
)
|
|
|
|
|
|
|
|
-- TODO: file operations should be threaded and not block the UI
|
|
-- TODO: make sure we do the right thing for BlockDev, CharDev etc...
|
|
-- most operations are not implemented for these
|
|
-- TODO: say which low-level syscalls are involved
|
|
|
|
|
|
-- |Data type describing an actual file operation that can be
|
|
-- carried out via `runFileOp`. Useful to build up a list of operations
|
|
-- or delay operations.
|
|
data FileOperation = FCopy Copy
|
|
| FMove Move
|
|
| FDelete [Path Abs]
|
|
| FOpen (Path Abs)
|
|
| FExecute (Path Abs) [ByteString]
|
|
| None
|
|
|
|
|
|
-- |Data type describing partial or complete file copy operation.
|
|
-- CC stands for a complete operation and can be used for `runFileOp`.
|
|
data Copy = PartialCopy [Path Abs]
|
|
| Copy [Path Abs] (Path Abs)
|
|
|
|
|
|
-- |Data type describing partial or complete file move operation.
|
|
-- MC stands for a complete operation and can be used for `runFileOp`.
|
|
data Move = PartialMove [Path Abs]
|
|
| Move [Path Abs] (Path Abs)
|
|
|
|
|
|
data FileType = Directory
|
|
| RegularFile
|
|
| SymbolicLink
|
|
| BlockDevice
|
|
| CharacterDevice
|
|
| NamedPipe
|
|
| Socket
|
|
deriving (Show)
|
|
|
|
|
|
|
|
-- |Run a given FileOperation. If the FileOperation is partial, it will
|
|
-- be returned. Returns `Nothing` on success.
|
|
--
|
|
-- Since file operations can be delayed, this is `Path Abs` based, not
|
|
-- `File` based. This makes sure we don't have stale
|
|
-- file information.
|
|
runFileOp :: FileOperation -> IO (Maybe FileOperation)
|
|
runFileOp fo' =
|
|
case fo' of
|
|
(FCopy (Copy froms to)) -> do
|
|
forM_ froms $ \x -> do
|
|
toname <- P.basename x
|
|
easyCopy x (to P.</> toname)
|
|
return Nothing
|
|
(FCopy fo) -> return $ Just $ FCopy fo
|
|
(FMove (Move froms to)) -> do
|
|
forM_ froms $ \x -> do
|
|
toname <- P.basename x
|
|
moveFile x (to P.</> toname)
|
|
return Nothing
|
|
(FMove fo) -> return $ Just $ FMove fo
|
|
(FDelete fps) ->
|
|
mapM_ easyDelete fps >> return Nothing
|
|
(FOpen fp) -> openFile fp >> return Nothing
|
|
(FExecute fp args) -> executeFile fp args >> return Nothing
|
|
_ -> return Nothing
|
|
|
|
|
|
|
|
--------------------
|
|
--[ File Copying ]--
|
|
--------------------
|
|
|
|
|
|
|
|
-- |Copies a directory to the given destination with the specified
|
|
-- `DirCopyMode`. Excludes symlinks.
|
|
--
|
|
-- 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
|
|
-- for performance, sanity checks are only done for the top dir
|
|
throwDestinationInSource fromp destdirp
|
|
go fromp destdirp
|
|
where
|
|
go :: Path Abs -> Path Abs -> IO ()
|
|
go fromp' destdirp' = do
|
|
-- order is important here, so we don't get empty directories
|
|
-- on failure
|
|
contents <- getDirsFiles fromp'
|
|
|
|
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus (P.fromAbs fromp')
|
|
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.
|
|
--
|
|
-- Throws: - anything `readSymbolicLink` or `createSymbolicLink` throws
|
|
recreateSymlink :: Path Abs -- ^ the old symlink file
|
|
-> Path Abs -- ^ destination file
|
|
-> IO ()
|
|
recreateSymlink symsource newsym
|
|
= do
|
|
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 :: Path Abs -- ^ source file
|
|
-> Path Abs -- ^ destination file
|
|
-> IO ()
|
|
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 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 =
|
|
bracket (SPDT.openFd source SPI.ReadOnly [SPDF.oNofollow] Nothing)
|
|
SPI.closeFd
|
|
$ \sfd -> do
|
|
fileM <- System.Posix.Files.ByteString.fileMode
|
|
<$> getFdStatus sfd
|
|
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 (SPDT.openFd source SPI.ReadOnly [SPDF.oNofollow] Nothing)
|
|
SPI.closeFd
|
|
$ \sfd -> do
|
|
fileM <- System.Posix.Files.ByteString.fileMode
|
|
<$> getFdStatus sfd
|
|
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
|
|
write' :: Fd -> Fd -> Ptr Word8 -> Int -> IO Int
|
|
write' sfd dfd buf totalsize = do
|
|
size <- SPB.fdReadBuf sfd buf bufSize
|
|
if size == 0
|
|
then return $ fromIntegral totalsize
|
|
else do rsize <- SPB.fdWriteBuf dfd buf size
|
|
when (rsize /= size) (throw . CopyFailed $ "wrong size!")
|
|
write' sfd dfd buf (totalsize + fromIntegral size)
|
|
|
|
|
|
-- |Copies anything. In case of a symlink,
|
|
-- it is just recreated, even if it points to a directory.
|
|
--
|
|
-- 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 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
|
|
|
|
|
|
|
|
|
|
|
|
|
|
---------------------
|
|
--[ File Deletion ]--
|
|
---------------------
|
|
|
|
|
|
-- |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 directory, which must be empty, never symlinks.
|
|
deleteDir :: Path Abs -> IO ()
|
|
deleteDir p = P.withAbsPath p removeDirectory
|
|
|
|
|
|
-- |Deletes the given directory recursively.
|
|
--
|
|
-- 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.
|
|
--
|
|
-- 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
|
|
|
|
|
|
|
|
|
|
--------------------
|
|
--[ File Opening ]--
|
|
--------------------
|
|
|
|
|
|
-- |Opens a file appropriately by invoking xdg-open. The file type
|
|
-- is not checked.
|
|
openFile :: Path Abs
|
|
-> IO ProcessID
|
|
openFile p =
|
|
P.withAbsPath p $ \fp ->
|
|
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
|
|
|
|
|
|
-- |Executes a program with the given arguments.
|
|
executeFile :: Path Abs -- ^ program
|
|
-> [ByteString] -- ^ arguments
|
|
-> IO ProcessID
|
|
executeFile fp args
|
|
= P.withAbsPath fp $ \fpb ->
|
|
SPP.forkProcess
|
|
$ SPP.executeFile fpb True args Nothing
|
|
|
|
|
|
|
|
|
|
---------------------
|
|
--[ File Creation ]--
|
|
---------------------
|
|
|
|
|
|
-- |Create an empty regular file at the given directory with the given filename.
|
|
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.
|
|
-- If the directory already exists, does nothing.
|
|
createDir :: Path Abs -> IO ()
|
|
createDir dest = createDirectory (P.fromAbs dest) newDirPerms
|
|
|
|
|
|
|
|
|
|
----------------------------
|
|
--[ File Renaming/Moving ]--
|
|
----------------------------
|
|
|
|
|
|
-- |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 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 from to =
|
|
catchErrno [eXDEV] (renameFile from to) $ do
|
|
easyCopy from to
|
|
easyDelete from
|
|
|
|
|
|
|
|
|
|
|
|
-----------------------
|
|
--[ File Permissions]--
|
|
-----------------------
|
|
|
|
|
|
-- |Default permissions for a new file.
|
|
newFilePerms :: FileMode
|
|
newFilePerms
|
|
= ownerWriteMode
|
|
`unionFileModes` ownerReadMode
|
|
`unionFileModes` groupWriteMode
|
|
`unionFileModes` groupReadMode
|
|
`unionFileModes` otherWriteMode
|
|
`unionFileModes` otherReadMode
|
|
|
|
|
|
-- |Default permissions for a new directory.
|
|
newDirPerms :: FileMode
|
|
newDirPerms
|
|
= ownerModes
|
|
`unionFileModes` groupExecuteMode
|
|
`unionFileModes` groupReadMode
|
|
`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?!"
|
|
|