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

Adjust to new HPath API

Browse Source
This commit is contained in:
Julian Ospald
2016-05-09 16:37:02 +02:00
parent 5fc77f6b24
commit 41e2ae6131
134 changed files with 14 additions and 2914 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@@ -1,343 +0,0 @@
{--
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 DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK ignore-exports #-}
-- |Provides error handling.
module HSFM.FileSystem.Errors where
import Control.Exception
import Control.Monad
(
forM
, when
)
import Data.ByteString
(
ByteString
)
import Data.Data
(
Data(..)
)
import Data.Typeable
import Foreign.C.Error
(
getErrno
, Errno
)
import GHC.IO.Exception
(
IOErrorType
)
import qualified HPath as P
import HPath
(
Abs
, Path
)
import HPath.IO
(
canonicalizePath
)
import HSFM.Utils.IO
import System.IO.Error
(
catchIOError
, ioeGetErrorType
)
import qualified System.Posix.Directory.ByteString as PFD
import System.Posix.Files.ByteString
(
fileAccess
, getFileStatus
)
import qualified System.Posix.Files.ByteString as PF
data FmIOException = FileDoesNotExist ByteString
| DirDoesNotExist ByteString
| PathNotAbsolute ByteString
| FileNotExecutable ByteString
| SameFile ByteString ByteString
| NotAFile ByteString
| NotADir ByteString
| DestinationInSource ByteString ByteString
| FileDoesExist ByteString
| DirDoesExist ByteString
| IsSymlink ByteString
| InvalidOperation String
| InvalidFileName
| Can'tOpenDirectory ByteString
| CopyFailed String
| MoveFailed String
deriving (Typeable, Eq, Data)
instance Show FmIOException where
show (FileDoesNotExist fp) = "File does not exist:" ++ P.fpToString fp
show (DirDoesNotExist fp) = "Directory does not exist: "
++ P.fpToString fp
show (PathNotAbsolute fp) = "Path not absolute: " ++ P.fpToString fp
show (FileNotExecutable fp) = "File not executable: "
++ P.fpToString fp
show (SameFile fp1 fp2) = P.fpToString fp1
++ " and " ++ P.fpToString fp2
++ " are the same file!"
show (NotAFile fp) = "Not a file: " ++ P.fpToString fp
show (NotADir fp) = "Not a directory: " ++ P.fpToString fp
show (DestinationInSource fp1 fp2) = P.fpToString fp1
++ " is contained in "
++ P.fpToString fp2
show (FileDoesExist fp) = "File does exist: " ++ P.fpToString fp
show (DirDoesExist fp) = "Directory does exist: " ++ P.fpToString fp
show (IsSymlink fp) = "Is a symlink: " ++ P.fpToString fp
show (InvalidOperation str) = "Invalid operation: " ++ str
show InvalidFileName = "Invalid file name!"
show (Can'tOpenDirectory fp) = "Can't open directory: "
++ P.fpToString fp
show (CopyFailed str) = "Copying failed: " ++ str
show (MoveFailed str) = "Moving failed: " ++ str
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 ]--
----------------------------
throwFileDoesExist :: Path Abs -> IO ()
throwFileDoesExist fp =
whenM (doesFileExist fp) (throwIO . FileDoesExist
. P.fromAbs $ fp)
throwDirDoesExist :: Path Abs -> IO ()
throwDirDoesExist fp =
whenM (doesDirectoryExist fp) (throwIO . DirDoesExist
. P.fromAbs $ fp)
throwFileDoesNotExist :: Path Abs -> IO ()
throwFileDoesNotExist fp =
unlessM (doesFileExist fp) (throwIO . FileDoesNotExist
. P.fromAbs $ fp)
throwDirDoesNotExist :: Path Abs -> IO ()
throwDirDoesNotExist fp =
unlessM (doesDirectoryExist fp) (throwIO . DirDoesNotExist
. P.fromAbs $ fp)
-- |Uses `isSameFile` and throws `SameFile` if it returns True.
throwSameFile :: Path Abs
-> Path Abs
-> IO ()
throwSameFile fp1 fp2 =
whenM (sameFile fp1 fp2)
(throwIO $ SameFile (P.fromAbs fp1) (P.fromAbs fp2))
-- |Check if the files are the same by examining device and file id.
-- This follows symbolic links.
sameFile :: Path Abs -> Path Abs -> IO Bool
sameFile fp1 fp2 =
P.withAbsPath fp1 $ \fp1' -> P.withAbsPath fp2 $ \fp2' ->
handleIOError (\_ -> return False) $ do
fs1 <- getFileStatus fp1'
fs2 <- getFileStatus fp2'
if ((PF.deviceID fs1, PF.fileID fs1) ==
(PF.deviceID fs2, PF.fileID fs2))
then return True
else return False
-- |Checks whether the destination directory is contained
-- within the source directory by comparing the device+file ID of the
-- source directory with all device+file IDs of the parent directories
-- of the destination.
throwDestinationInSource :: Path Abs -- ^ source dir
-> Path Abs -- ^ full destination, `dirname dest`
-- must exist
-> IO ()
throwDestinationInSource source dest = do
dest' <- (\x -> maybe x (\y -> x P.</> y) $ P.basename dest)
<$> (canonicalizePath $ P.dirname dest)
dids <- forM (P.getAllParents dest') $ \p -> do
fs <- PF.getSymbolicLinkStatus (P.fromAbs p)
return (PF.deviceID fs, PF.fileID fs)
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
$ PF.getFileStatus (P.fromAbs source)
when (elem sid dids)
(throwIO $ DestinationInSource (P.fromAbs dest)
(P.fromAbs source))
-- |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
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
return $ not . PF.isDirectory $ fs
-- |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
fs <- PF.getSymbolicLinkStatus (P.fromAbs fp)
return $ PF.isDirectory fs
-- |Checks whether a file or folder is writable.
isWritable :: Path Abs -> IO Bool
isWritable fp =
handleIOError (\_ -> return False) $
fileAccess (P.fromAbs fp) False True False
-- |Checks whether the directory at the given path exists and can be
-- opened. This invokes `openDirStream` which follows symlinks.
canOpenDirectory :: Path Abs -> IO Bool
canOpenDirectory fp =
handleIOError (\_ -> return False) $ do
bracket (PFD.openDirStream . P.fromAbs $ fp)
PFD.closeDirStream
(\_ -> return ())
return True
-- |Throws a `Can'tOpenDirectory` FmIOException if the directory at the given
-- path cannot be opened.
throwCantOpenDirectory :: Path Abs -> IO ()
throwCantOpenDirectory fp =
unlessM (canOpenDirectory fp)
(throwIO . Can'tOpenDirectory . P.fromAbs $ fp)
--------------------------------
--[ Error handling functions ]--
--------------------------------
-- |Carries out an action, then checks if there is an IOException and
-- a specific errno. If so, then it carries out another action, otherwise
-- it rethrows the error.
catchErrno :: [Errno] -- ^ errno to catch
-> IO a -- ^ action to try, which can raise an IOException
-> IO a -- ^ action to carry out in case of an IOException and
-- if errno matches
-> IO a
catchErrno en a1 a2 =
catchIOError a1 $ \e -> do
errno <- getErrno
if errno `elem` en
then a2
else ioError e
-- |Execute the given action and retrow IO exceptions as a new Exception
-- that have the given errno. If errno does not match the exception is rethrown
-- as is.
rethrowErrnoAs :: Exception e
=> [Errno] -- ^ errno to catch
-> e -- ^ rethrow as if errno matches
-> IO a -- ^ action to try
-> IO a
rethrowErrnoAs en fmex action = catchErrno en action (throwIO fmex)
-- |Like `catchIOError`, with arguments swapped.
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
reactOnError :: IO a
-> [(IOErrorType, IO a)] -- ^ reaction on IO errors
-> [(FmIOException, IO a)] -- ^ reaction on FmIOException
-> IO a
reactOnError a ios fmios =
a `catches` [iohandler, fmiohandler]
where
iohandler = Handler $
\(ex :: IOException) ->
foldr (\(t, a') y -> if ioeGetErrorType ex == t
then a'
else y)
(throwIO ex)
ios
fmiohandler = Handler $
\(ex :: FmIOException) ->
foldr (\(t, a') y -> if toConstr ex == toConstr t
then a'
else y)
(throwIO ex)
fmios

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

@@ -1,799 +0,0 @@
{--
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 #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# 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 paths which are absolute.
--
-- Some functions are just path-safe wrappers around
-- unix functions, others have stricter exception handling
-- and some implement functionality that doesn't have a unix
-- counterpart (like `copyDirRecursive`).
--
-- Some of these operations are due to their nature not _atomic_, which
-- means they may do multiple syscalls which form one context. Some
-- of them also have to examine the filetypes explicitly before the
-- syscalls, so a reasonable decision can be made. That means
-- the result is undefined if another process changes that context
-- while the non-atomic operation is still happening. However, where
-- possible, as few syscalls as possible are used and the underlying
-- exception handling is kept.
module HSFM.FileSystem.FileOperations where
import Control.Exception
(
bracket
, bracketOnError
, throwIO
)
import Control.Monad
(
void
, when
)
import Data.ByteString
(
ByteString
)
import Data.Foldable
(
for_
)
import Data.Maybe
(
catMaybes
)
import Data.Word
(
Word8
)
import Foreign.C.Error
(
eEXIST
, eINVAL
, eNOSYS
, eNOTEMPTY
, eXDEV
)
import Foreign.C.Types
(
CSize
)
import Foreign.Marshal.Alloc
(
allocaBytes
)
import Foreign.Ptr
(
Ptr
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import HPath
(
Path
, Abs
, Fn
)
import qualified HPath as P
import HSFM.FileSystem.Errors
import HSFM.Utils.IO
import Prelude hiding (readFile)
import System.IO.Error
(
catchIOError
, ioeGetErrorType
)
import System.Posix.ByteString
(
exclusive
)
import System.Posix.Directory.ByteString
(
createDirectory
, removeDirectory
)
import System.Posix.Directory.Traversals
(
getDirectoryContents'
)
import System.Posix.Files.ByteString
(
createSymbolicLink
, fileMode
, getFdStatus
, groupExecuteMode
, groupReadMode
, groupWriteMode
, otherExecuteMode
, otherReadMode
, otherWriteMode
, ownerModes
, ownerReadMode
, ownerWriteMode
, readSymbolicLink
, removeLink
, rename
, setFileMode
, 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: make sure we do the right thing for BlockDev, CharDev etc...
-- most operations are not implemented for these
data FileType = Directory
| RegularFile
| SymbolicLink
| BlockDevice
| CharacterDevice
| NamedPipe
| Socket
deriving (Eq, Show)
--------------------
--[ File Copying ]--
--------------------
-- |Copies a directory recursively to the given destination.
-- Does not follow symbolic links.
--
-- Safety/reliability concerns:
--
-- * not atomic
-- * examines filetypes explicitly
-- * 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)
--
-- Throws:
--
-- - `NoSuchThing` if source directory does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source directory is wrong type (symlink)
-- - `InvalidArgument` if source directory is wrong type (regular file)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `AlreadyExists` if destination already exists
-- - `DestinationInSource` if destination is contained in source (`FmIOException`)
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
throwSameFile fromp destdirp
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
-- |Like `copyDirRecursive` except it overwrites contents of directories
-- if any.
--
-- Throws:
--
-- - `NoSuchThing` if source directory does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source directory is wrong type (symlink)
-- - `InvalidArgument` if source directory is wrong type (regular file)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `DestinationInSource` if destination is contained in source (`FmIOException`)
copyDirRecursiveOverwrite :: Path Abs -- ^ source dir
-> Path Abs -- ^ full destination
-> IO ()
copyDirRecursiveOverwrite fromp destdirp
= do
-- for performance, sanity checks are only done for the top dir
throwSameFile fromp destdirp
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')
catchIOError (createDirectory (P.fromAbs destdirp') fmode') $ \e ->
case ioeGetErrorType e of
AlreadyExists -> setFileMode (P.fromAbs destdirp') fmode'
_ -> ioError e
for_ contents $ \f -> do
ftype <- getFileType f
newdest <- (destdirp' P.</>) <$> P.basename f
case ftype of
SymbolicLink -> whenM (doesFileExist newdest) (deleteFile newdest)
>> recreateSymlink f newdest
Directory -> go f newdest
RegularFile -> copyFileOverwrite f newdest
_ -> ioError $ userError $ "No idea what to do with the" ++
"given filetype: " ++ show ftype
-- |Recreate a symlink.
--
-- Throws:
--
-- - `InvalidArgument` if symlink file is wrong type (file)
-- - `InvalidArgument` if symlink file is wrong type (directory)
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `AlreadyExists` if destination file already exists
-- - `SameFile` if source and destination are the same file (`FmIOException`)
--
-- Note: calls `symlink`
recreateSymlink :: Path Abs -- ^ the old symlink file
-> Path Abs -- ^ destination file
-> IO ()
recreateSymlink symsource newsym
= do
throwSameFile symsource newsym
sympoint <- readSymbolicLink (P.fromAbs symsource)
createSymbolicLink sympoint (P.fromAbs newsym)
-- |Copies the given regular file to the given destination.
-- Neither follows symbolic links, nor accepts them.
-- For "copying" symbolic links, use `recreateSymlink` instead.
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source file is wrong type (symlink)
-- - `InvalidArgument` if source file is wrong type (directory)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
-- - `AlreadyExists` if destination already exists
--
-- Note: calls `sendfile`
copyFile :: Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
copyFile from to = do
throwSameFile from to
_copyFile [SPDF.oNofollow]
[SPDF.oNofollow, SPDF.oExcl]
from to
-- |Like `copyFile` except it overwrites the destination if it already
-- exists.
-- This also works if source and destination are the same file.
--
-- Safety/reliability concerns:
--
-- * not atomic
-- * falls back to delete-copy method with explicit checks
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory is not writable
-- - `PermissionDenied` if source directory can't be opened
-- - `InvalidArgument` if source file is wrong type (symlink)
-- - `InvalidArgument` if source file is wrong type (directory)
-- - `SameFile` if source and destination are the same file (`FmIOException`)
--
-- Note: calls `sendfile`
copyFileOverwrite :: Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
copyFileOverwrite from to = do
throwSameFile from to
catchIOError (_copyFile [SPDF.oNofollow]
[SPDF.oNofollow, SPDF.oTrunc]
from to) $ \e ->
case ioeGetErrorType e of
-- if the destination file is not writable, we need to
-- figure out if we can still copy by deleting it first
PermissionDenied -> do
exists <- doesFileExist to
writable <- isWritable (P.dirname to)
if exists && writable
then deleteFile to >> copyFile from to
else ioError e
_ -> ioError e
_copyFile :: [SPDF.Flags]
-> [SPDF.Flags]
-> Path Abs -- ^ source file
-> Path Abs -- ^ destination file
-> IO ()
_copyFile sflags dflags 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 sflags Nothing)
SPI.closeFd
$ \sfd -> do
fileM <- System.Posix.Files.ByteString.fileMode
<$> getFdStatus sfd
bracketeer (SPDT.openFd dest SPI.WriteOnly
dflags $ Just fileM)
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 sflags Nothing)
SPI.closeFd
$ \sfd -> do
fileM <- System.Posix.Files.ByteString.fileMode
<$> getFdStatus sfd
bracketeer (SPDT.openFd dest SPI.WriteOnly
dflags $ Just fileM)
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
-- TODO: switch to IOError?
when (rsize /= size) (throwIO . 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.
--
-- Safety/reliability concerns:
--
-- * examines filetypes explicitly
-- * 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
-- |Like `easyCopy` except it overwrites the destination if it already exists.
-- For directories, this overwrites contents without pruning them, so the resulting
-- directory may have more files than have been copied.
easyCopyOverwrite :: Path Abs
-> Path Abs
-> IO ()
easyCopyOverwrite from to = do
ftype <- getFileType from
case ftype of
SymbolicLink -> whenM (doesFileExist to) (deleteFile to)
>> recreateSymlink from to
RegularFile -> copyFileOverwrite from to
Directory -> copyDirRecursiveOverwrite 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. Does not follow symbolic links.
--
-- Throws:
--
-- - `InappropriateType` for wrong file type (directory)
-- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if the directory cannot be read
deleteFile :: Path Abs -> IO ()
deleteFile p = P.withAbsPath p removeLink
-- |Deletes the given directory, which must be empty, never symlinks.
--
-- Throws:
--
-- - `InappropriateType` for wrong file type (symlink to directory)
-- - `InappropriateType` for wrong file type (regular file)
-- - `NoSuchThing` if directory does not exist
-- - `UnsatisfiedConstraints` if directory is not empty
-- - `PermissionDenied` if we can't open or write to parent directory
--
-- Notes: calls `rmdir`
deleteDir :: Path Abs -> IO ()
deleteDir p = P.withAbsPath p removeDirectory
-- |Deletes the given directory recursively. Does not follow symbolic
-- links. Tries `deleteDir` first before attemtping a recursive
-- deletion.
--
-- Safety/reliability concerns:
--
-- * not atomic
-- * examines filetypes explicitly
--
-- Throws:
--
-- - `InappropriateType` for wrong file type (symlink to directory)
-- - `InappropriateType` for wrong file type (regular file)
-- - `NoSuchThing` if directory does not exist
-- - `PermissionDenied` if we can't open or write to parent directory
deleteDirRecursive :: Path Abs -> IO ()
deleteDirRecursive p =
catchErrno [eNOTEMPTY, eEXIST]
(deleteDir 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.
--
-- Safety/reliability concerns:
--
-- * examines filetypes explicitly
-- * 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.
--
-- Throws:
--
-- - `PermissionDenied` if output directory cannot be written to
-- - `AlreadyExists` if destination file already exists
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.
--
-- Throws:
--
-- - `PermissionDenied` if output directory cannot be written to
-- - `AlreadyExists` if destination directory already exists
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.
--
-- Does not follow symbolic links, but renames the symbolic link file.
--
-- Safety/reliability concerns:
--
-- * has a separate set of exception handling, apart from the syscall
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `UnsupportedOperation` if source and destination are on different devices
-- - `FileDoesExist` if destination file already exists
-- - `DirDoesExist` if destination directory already exists
-- - `SameFile` if destination and source are the same file (`FmIOException`)
--
-- Note: 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.
--
-- Does not follow symbolic links, but renames the symbolic link file.
--
-- Safety/reliability concerns:
--
-- * copy-delete fallback is inherently non-atomic
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `FileDoesExist` if destination file already exists
-- - `DirDoesExist` if destination directory already exists
-- - `SameFile` if destination and source are the same file (`FmIOException`)
--
-- Note: calls `rename` (but does not allow to rename over existing files)
moveFile :: Path Abs -- ^ file to move
-> Path Abs -- ^ destination
-> IO ()
moveFile from to = do
throwSameFile from to
catchErrno [eXDEV] (renameFile from to) $ do
easyCopy from to
easyDelete from
-- |Like `moveFile`, but overwrites the destination if it exists.
--
-- Does not follow symbolic links, but renames the symbolic link file.
--
-- Safety/reliability concerns:
--
-- * copy-delete fallback is inherently non-atomic
-- * checks for file types and destination file existence explicitly
--
-- Throws:
--
-- - `NoSuchThing` if source file does not exist
-- - `PermissionDenied` if output directory cannot be written to
-- - `PermissionDenied` if source directory cannot be opened
-- - `SameFile` if destination and source are the same file (`FmIOException`)
--
-- Note: calls `rename` (but does not allow to rename over existing files)
moveFileOverwrite :: Path Abs -- ^ file to move
-> Path Abs -- ^ destination
-> IO ()
moveFileOverwrite from to = do
throwSameFile from to
ft <- getFileType from
writable <- isWritable $ P.dirname to
case ft of
RegularFile -> do
exists <- doesFileExist to
when (exists && writable) (deleteFile to)
SymbolicLink -> do
exists <- doesFileExist to
when (exists && writable) (deleteFile to)
Directory -> do
exists <- doesDirectoryExist to
when (exists && writable) (deleteDir to)
_ -> ioError $ userError $ "Don't know how to handle filetype " ++
show ft
moveFile from to
-----------------------
--[ 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 "..".
-- This version does not follow symbolic links.
--
-- Throws:
--
-- - `NoSuchThing` if directory does not exist
-- - `InappropriateType` if file type is wrong (file)
-- - `InappropriateType` if file type is wrong (symlink to file)
-- - `InappropriateType` if file type is wrong (symlink to dir)
-- - `PermissionDenied` if directory cannot be opened
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 ]--
---------------------------
-- |Get the file type of the file located at the given path. Does
-- not follow symbolic links.
--
-- Throws:
--
-- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if any part of the path is not accessible
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?!"

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

@@ -51,11 +51,8 @@ import HPath
, Path
)
import qualified HPath as P
import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
(
getDirsFiles
)
import HPath.IO hiding (FileType(..))
import HPath.IO.Errors
import HSFM.Utils.MyPrelude
import Prelude hiding(readFile)
import System.IO.Error

9
src/HSFM/GUI/Gtk/Callbacks.hs
View File

@@ -55,8 +55,9 @@ import HPath
Abs
, Path
)
import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
import HPath.IO
import HPath.IO.Errors
import HPath.IO.Utils
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Callbacks.Utils
@@ -431,8 +432,8 @@ renameF [item] _ _ = withErrorDialog $ do
++ P.fpToString (P.fromAbs $ (P.dirname . path $ item)
P.</> fn) ++ "\"?"
withConfirmationDialog cmsg $
HSFM.FileSystem.FileOperations.renameFile (path item)
((P.dirname $ path item) P.</> fn)
HPath.IO.renameFile (path item)
((P.dirname $ path item) P.</> fn)
renameF _ _ _ = withErrorDialog
. throwIO $ InvalidOperation
"Operation not supported on multiple files"

4
src/HSFM/GUI/Gtk/Callbacks/Utils.hs
View File

@@ -33,8 +33,8 @@ import GHC.IO.Exception
IOErrorType(..)
)
import qualified HPath as P
import HSFM.FileSystem.Errors
import HSFM.FileSystem.FileOperations
import HPath.IO
import HPath.IO.Errors
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Gtk.Data

4
src/HSFM/GUI/Gtk/Dialogs.hs
View File

@@ -68,7 +68,7 @@ import Distribution.Verbosity
)
import Graphics.UI.Gtk
import qualified HPath as P
import HSFM.FileSystem.Errors
import HPath.IO.Errors
import HSFM.FileSystem.FileType
import HSFM.FileSystem.UtilTypes
import HSFM.GUI.Glib.GlibString()
@@ -222,7 +222,7 @@ withErrorDialog io =
[ Handler (\e -> showErrorDialog
$ displayException (e :: IOException))
, Handler (\e -> showErrorDialog
$ displayException (e :: FmIOException))
$ displayException (e :: HPathIOException))
]

2
src/HSFM/GUI/Gtk/MyView.hs
View File

@@ -47,7 +47,7 @@ import Data.Maybe
catMaybes
, fromJust
)
import HSFM.FileSystem.Errors
import HPath.IO.Errors
(
canOpenDirectory
)

16
src/HSFM/Utils/IO.hs
View File

@@ -33,11 +33,6 @@ import Control.Concurrent.STM.TVar
, modifyTVar
, TVar
)
import Control.Monad
(
when
, unless
)
-- |Atomically write a TVar.
@@ -49,14 +44,3 @@ writeTVarIO tvar val = atomically $ writeTVar tvar val
modifyTVarIO :: TVar a -> (a -> a) -> IO ()
modifyTVarIO tvar f = atomically $ modifyTVar tvar f
-- |If the value of the first argument is True, then execute the action
-- provided in the second argument, otherwise do nothing.
whenM :: Monad m => m Bool -> m () -> m ()
whenM mb a = mb >>= (`when` a)
-- |If the value of the first argument is False, then execute the action
-- provided in the second argument, otherwise do nothing.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM mb a = mb >>= (`unless` a)