2016-05-09 12:40:30 +00:00
|
|
|
-- |
|
|
|
|
-- Module : HPath.IO
|
|
|
|
-- Copyright : © 2016 Julian Ospald
|
2016-06-03 22:20:41 +00:00
|
|
|
-- License : BSD3
|
2016-05-09 12:40:30 +00:00
|
|
|
--
|
|
|
|
-- Maintainer : Julian Ospald <hasufell@posteo.de>
|
|
|
|
-- Stability : experimental
|
|
|
|
-- Portability : portable
|
|
|
|
--
|
2016-05-09 14:53:31 +00:00
|
|
|
-- This module provides high-level IO related file operations like
|
2018-04-10 22:44:47 +00:00
|
|
|
-- copy, delete, move and so on. It only operates on /Path x/ which
|
|
|
|
-- guarantees us well-typed paths. Passing in /Path Abs/ to any
|
|
|
|
-- of these functions generally increases safety. Passing /Path Rel/
|
|
|
|
-- may trigger looking up the current directory via `getcwd` in some
|
|
|
|
-- cases where it cannot be avoided.
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- 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`).
|
|
|
|
--
|
2016-05-09 15:37:16 +00:00
|
|
|
-- Some of these operations are due to their nature __not atomic__, which
|
2016-05-09 14:53:31 +00:00
|
|
|
-- 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.
|
2016-05-09 15:37:16 +00:00
|
|
|
--
|
|
|
|
-- Note: `BlockDevice`, `CharacterDevice`, `NamedPipe` and `Socket`
|
2016-05-31 14:21:14 +00:00
|
|
|
-- are ignored by some of the more high-level functions (like `easyCopy`).
|
|
|
|
-- For other functions (like `copyFile`), the behavior on these file types is
|
|
|
|
-- unreliable/unsafe. Check the documentation of those functions for details.
|
2016-05-09 12:40:30 +00:00
|
|
|
|
2018-04-11 23:41:32 +00:00
|
|
|
{-# LANGUAGE CPP #-}
|
2016-05-09 14:53:31 +00:00
|
|
|
{-# LANGUAGE PackageImports #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
|
2016-05-09 15:37:16 +00:00
|
|
|
module HPath.IO
|
|
|
|
(
|
|
|
|
-- * Types
|
|
|
|
FileType(..)
|
2016-06-05 14:07:46 +00:00
|
|
|
, RecursiveErrorMode(..)
|
2016-06-05 01:10:28 +00:00
|
|
|
, CopyMode(..)
|
2016-05-09 15:37:16 +00:00
|
|
|
-- * File copying
|
|
|
|
, copyDirRecursive
|
|
|
|
, recreateSymlink
|
|
|
|
, copyFile
|
|
|
|
, easyCopy
|
|
|
|
-- * File deletion
|
|
|
|
, deleteFile
|
|
|
|
, deleteDir
|
|
|
|
, deleteDirRecursive
|
|
|
|
, easyDelete
|
|
|
|
-- * File opening
|
|
|
|
, openFile
|
|
|
|
, executeFile
|
|
|
|
-- * File creation
|
|
|
|
, createRegularFile
|
|
|
|
, createDir
|
2016-06-12 23:28:55 +00:00
|
|
|
, createDirRecursive
|
2016-05-29 15:28:12 +00:00
|
|
|
, createSymlink
|
2016-05-09 15:37:16 +00:00
|
|
|
-- * File renaming/moving
|
|
|
|
, renameFile
|
|
|
|
, moveFile
|
2018-04-06 14:42:40 +00:00
|
|
|
-- * File reading
|
|
|
|
, readFile
|
|
|
|
, readFileEOF
|
2018-04-06 15:22:22 +00:00
|
|
|
-- * File writing
|
|
|
|
, writeFile
|
|
|
|
, appendFile
|
2016-05-09 15:37:16 +00:00
|
|
|
-- * File permissions
|
|
|
|
, newFilePerms
|
|
|
|
, newDirPerms
|
|
|
|
-- * Directory reading
|
|
|
|
, getDirsFiles
|
|
|
|
-- * Filetype operations
|
|
|
|
, getFileType
|
|
|
|
-- * Others
|
|
|
|
, canonicalizePath
|
2018-04-10 22:44:47 +00:00
|
|
|
, toAbs
|
2016-05-09 15:37:16 +00:00
|
|
|
)
|
|
|
|
where
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
2016-05-09 16:14:08 +00:00
|
|
|
import Control.Applicative
|
|
|
|
(
|
|
|
|
(<$>)
|
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import Control.Exception
|
|
|
|
(
|
2016-06-05 01:10:28 +00:00
|
|
|
IOException
|
|
|
|
, bracket
|
2016-05-09 14:53:31 +00:00
|
|
|
, throwIO
|
|
|
|
)
|
|
|
|
import Control.Monad
|
|
|
|
(
|
2016-06-05 01:10:28 +00:00
|
|
|
unless
|
|
|
|
, void
|
2016-05-09 14:53:31 +00:00
|
|
|
, when
|
|
|
|
)
|
2016-06-12 23:38:44 +00:00
|
|
|
import Control.Monad.IfElse
|
|
|
|
(
|
|
|
|
unlessM
|
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import Data.ByteString
|
|
|
|
(
|
|
|
|
ByteString
|
|
|
|
)
|
2018-04-11 23:41:32 +00:00
|
|
|
#if MIN_VERSION_bytestring(0,10,2)
|
2018-04-06 14:42:40 +00:00
|
|
|
import Data.ByteString.Builder
|
2018-04-11 23:41:32 +00:00
|
|
|
#else
|
|
|
|
import Data.ByteString.Lazy.Builder
|
|
|
|
#endif
|
2018-04-06 14:42:40 +00:00
|
|
|
(
|
|
|
|
Builder
|
|
|
|
, byteString
|
|
|
|
, toLazyByteString
|
|
|
|
)
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
|
|
|
import Data.ByteString.Unsafe
|
|
|
|
(
|
|
|
|
unsafePackCStringFinalizer
|
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import Data.Foldable
|
|
|
|
(
|
|
|
|
for_
|
|
|
|
)
|
2016-06-05 01:10:28 +00:00
|
|
|
import Data.IORef
|
|
|
|
(
|
|
|
|
IORef
|
|
|
|
, modifyIORef
|
|
|
|
, newIORef
|
|
|
|
, readIORef
|
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import Data.Maybe
|
|
|
|
(
|
|
|
|
catMaybes
|
|
|
|
)
|
2018-04-06 14:42:40 +00:00
|
|
|
import Data.Monoid
|
|
|
|
(
|
|
|
|
(<>)
|
2018-04-11 20:36:40 +00:00
|
|
|
, mempty
|
2018-04-06 14:42:40 +00:00
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import Data.Word
|
|
|
|
(
|
|
|
|
Word8
|
|
|
|
)
|
|
|
|
import Foreign.C.Error
|
|
|
|
(
|
|
|
|
eEXIST
|
2016-06-12 23:28:55 +00:00
|
|
|
, eNOENT
|
2016-05-09 14:53:31 +00:00
|
|
|
, eNOTEMPTY
|
|
|
|
, eXDEV
|
2016-06-12 23:28:55 +00:00
|
|
|
, getErrno
|
2019-12-30 14:16:59 +00:00
|
|
|
#if __GLASGOW_HASKELL__ < 802
|
|
|
|
, eINVAL
|
|
|
|
, eNOSYS
|
|
|
|
#endif
|
2016-05-09 14:53:31 +00:00
|
|
|
)
|
|
|
|
import Foreign.C.Types
|
|
|
|
(
|
|
|
|
CSize
|
|
|
|
)
|
|
|
|
import Foreign.Marshal.Alloc
|
|
|
|
(
|
|
|
|
allocaBytes
|
|
|
|
)
|
|
|
|
import Foreign.Ptr
|
|
|
|
(
|
|
|
|
Ptr
|
|
|
|
)
|
|
|
|
import GHC.IO.Exception
|
|
|
|
(
|
|
|
|
IOErrorType(..)
|
|
|
|
)
|
|
|
|
import HPath
|
|
|
|
import HPath.Internal
|
|
|
|
import HPath.IO.Errors
|
2018-04-06 15:22:22 +00:00
|
|
|
import Prelude hiding (appendFile, readFile, writeFile)
|
2019-12-30 14:16:59 +00:00
|
|
|
#if __GLASGOW_HASKELL__ >= 802
|
2019-12-29 19:03:28 +00:00
|
|
|
import qualified Streamly.FileSystem.Handle as FH
|
|
|
|
import qualified Streamly.Internal.FileSystem.Handle as IFH
|
|
|
|
import qualified Streamly.Prelude as S
|
|
|
|
import qualified System.IO as SIO
|
2019-12-30 14:16:59 +00:00
|
|
|
#else
|
|
|
|
import System.Linux.Sendfile
|
|
|
|
(
|
|
|
|
sendfileFd
|
|
|
|
, FileRange(..)
|
|
|
|
)
|
|
|
|
#endif
|
2016-05-09 14:53:31 +00:00
|
|
|
import System.IO.Error
|
|
|
|
(
|
|
|
|
catchIOError
|
|
|
|
, ioeGetErrorType
|
|
|
|
)
|
|
|
|
import System.Posix.ByteString
|
|
|
|
(
|
|
|
|
exclusive
|
|
|
|
)
|
|
|
|
import System.Posix.Directory.ByteString
|
|
|
|
(
|
|
|
|
createDirectory
|
2018-04-10 22:44:47 +00:00
|
|
|
, getWorkingDirectory
|
2016-05-09 14:53:31 +00:00
|
|
|
, 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
|
2016-05-18 02:11:40 +00:00
|
|
|
import System.Posix.FD
|
|
|
|
(
|
|
|
|
openFd
|
|
|
|
)
|
2016-05-09 14:53:31 +00:00
|
|
|
import qualified System.Posix.Directory.Traversals as SPDT
|
|
|
|
import qualified System.Posix.Directory.Foreign as SPDF
|
|
|
|
import qualified System.Posix.Process.ByteString as SPP
|
|
|
|
import System.Posix.Types
|
|
|
|
(
|
|
|
|
FileMode
|
|
|
|
, ProcessID
|
|
|
|
, Fd
|
|
|
|
)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2016-05-09 22:36:51 +00:00
|
|
|
-------------
|
|
|
|
--[ Types ]--
|
|
|
|
-------------
|
|
|
|
|
|
|
|
|
2016-05-09 14:53:31 +00:00
|
|
|
data FileType = Directory
|
|
|
|
| RegularFile
|
|
|
|
| SymbolicLink
|
|
|
|
| BlockDevice
|
|
|
|
| CharacterDevice
|
|
|
|
| NamedPipe
|
|
|
|
| Socket
|
|
|
|
deriving (Eq, Show)
|
|
|
|
|
|
|
|
|
|
|
|
|
2016-06-14 17:13:25 +00:00
|
|
|
-- |The error mode for recursive operations.
|
2016-06-05 01:10:28 +00:00
|
|
|
--
|
|
|
|
-- On `FailEarly` the whole operation fails immediately if any of the
|
|
|
|
-- recursive sub-operations fail, which is sort of the default
|
|
|
|
-- for IO operations.
|
|
|
|
--
|
2016-06-05 13:57:41 +00:00
|
|
|
-- On `CollectFailures` skips errors in the recursion and keeps on recursing.
|
|
|
|
-- However all errors are collected in the `RecursiveFailure` error type,
|
2016-06-05 20:04:16 +00:00
|
|
|
-- which is raised finally if there was any error. Also note that
|
|
|
|
-- `RecursiveFailure` does not give any guarantees on the ordering
|
|
|
|
-- of the collected exceptions.
|
2016-06-05 14:07:46 +00:00
|
|
|
data RecursiveErrorMode = FailEarly
|
|
|
|
| CollectFailures
|
2016-06-05 01:10:28 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |The mode for copy and file moves.
|
|
|
|
-- Overwrite mode is usually not very well defined, but is a convenience
|
|
|
|
-- shortcut.
|
|
|
|
data CopyMode = Strict -- ^ fail if any target exists
|
|
|
|
| Overwrite -- ^ overwrite targets
|
|
|
|
|
|
|
|
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
--------------------
|
|
|
|
--[ File Copying ]--
|
|
|
|
--------------------
|
|
|
|
|
|
|
|
|
|
|
|
|
2016-06-05 20:19:30 +00:00
|
|
|
-- |Copies the contents of a directory recursively to the given destination, while preserving permissions.
|
|
|
|
-- Does not follow symbolic links. This behaves more or less like
|
|
|
|
-- the following, without descending into the destination if it
|
|
|
|
-- already exists:
|
2016-06-05 14:31:08 +00:00
|
|
|
--
|
|
|
|
-- @
|
2016-06-05 20:19:30 +00:00
|
|
|
-- cp -a \/source\/dir \/destination\/somedir
|
2016-06-05 14:31:08 +00:00
|
|
|
-- @
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
2016-06-05 13:57:41 +00:00
|
|
|
-- For directory contents, this will ignore any file type that is not
|
|
|
|
-- `RegularFile`, `SymbolicLink` or `Directory`.
|
2016-05-31 14:21:14 +00:00
|
|
|
--
|
2016-06-05 14:38:54 +00:00
|
|
|
-- For `Overwrite` copy mode this does not prune destination directory
|
|
|
|
-- contents, so the destination might contain more files than the source after
|
|
|
|
-- the operation has completed. Permissions of existing directories are
|
|
|
|
-- fixed.
|
2016-06-05 01:10:28 +00:00
|
|
|
--
|
2016-05-09 14:53:31 +00:00
|
|
|
-- 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 source directory can't be opened
|
2016-06-05 13:57:41 +00:00
|
|
|
-- - `SameFile` if source and destination are the same file
|
|
|
|
-- (`HPathIOException`)
|
|
|
|
-- - `DestinationInSource` if destination is contained in source
|
|
|
|
-- (`HPathIOException`)
|
2016-06-05 01:10:28 +00:00
|
|
|
--
|
2016-06-05 14:07:46 +00:00
|
|
|
-- Throws in `FailEarly` RecursiveErrorMode only:
|
2016-06-05 01:10:28 +00:00
|
|
|
--
|
2016-06-05 13:57:41 +00:00
|
|
|
-- - `PermissionDenied` if output directory is not writable
|
|
|
|
-- - `InvalidArgument` if source directory is wrong type (symlink)
|
|
|
|
-- - `InappropriateType` if source directory is wrong type (regular file)
|
2016-06-05 01:10:28 +00:00
|
|
|
--
|
2016-06-05 14:07:46 +00:00
|
|
|
-- Throws in `CollectFailures` RecursiveErrorMode only:
|
2016-06-05 01:10:28 +00:00
|
|
|
--
|
2016-06-05 13:57:41 +00:00
|
|
|
-- - `RecursiveFailure` if any of the recursive operations that are not
|
2016-06-05 14:00:15 +00:00
|
|
|
-- part of the top-directory sanity-checks fail (`HPathIOException`)
|
2016-06-05 13:57:41 +00:00
|
|
|
--
|
|
|
|
-- Throws in `Strict` CopyMode only:
|
|
|
|
--
|
2016-06-05 01:10:28 +00:00
|
|
|
-- - `AlreadyExists` if destination already exists
|
2018-04-12 12:28:37 +00:00
|
|
|
--
|
|
|
|
-- Note: may call `getcwd` (only if destination is a relative path)
|
2018-04-10 22:44:47 +00:00
|
|
|
copyDirRecursive :: Path b1 -- ^ source dir
|
|
|
|
-> Path b2 -- ^ destination (parent dirs
|
|
|
|
-- are not automatically created)
|
2016-06-05 01:10:28 +00:00
|
|
|
-> CopyMode
|
2016-06-05 14:07:46 +00:00
|
|
|
-> RecursiveErrorMode
|
2016-05-09 14:53:31 +00:00
|
|
|
-> IO ()
|
2016-06-05 01:10:28 +00:00
|
|
|
copyDirRecursive fromp destdirp cm rm
|
2016-05-09 14:53:31 +00:00
|
|
|
= do
|
2016-06-05 01:10:28 +00:00
|
|
|
ce <- newIORef []
|
2016-05-09 14:53:31 +00:00
|
|
|
-- for performance, sanity checks are only done for the top dir
|
|
|
|
throwSameFile fromp destdirp
|
|
|
|
throwDestinationInSource fromp destdirp
|
2016-06-05 01:10:28 +00:00
|
|
|
go ce fromp destdirp
|
|
|
|
collectedExceptions <- readIORef ce
|
|
|
|
unless (null collectedExceptions)
|
|
|
|
(throwIO . RecursiveFailure $ collectedExceptions)
|
2016-05-09 14:53:31 +00:00
|
|
|
where
|
2016-06-14 17:13:25 +00:00
|
|
|
go :: IORef [(RecursiveFailureHint, IOException)]
|
2018-04-10 22:44:47 +00:00
|
|
|
-> Path b1 -> Path b2 -> IO ()
|
|
|
|
go ce fromp'@(MkPath fromBS) destdirp'@(MkPath destdirpBS) = do
|
2016-06-05 01:10:28 +00:00
|
|
|
|
2016-06-14 17:13:25 +00:00
|
|
|
-- NOTE: order is important here, so we don't get empty directories
|
2016-05-09 14:53:31 +00:00
|
|
|
-- on failure
|
2016-06-14 17:13:25 +00:00
|
|
|
|
|
|
|
-- get the contents of the source dir
|
2018-04-10 22:44:47 +00:00
|
|
|
contents <- handleIOE (ReadContentsFailed fromBS destdirpBS) ce [] $ do
|
2016-06-05 01:10:28 +00:00
|
|
|
contents <- getDirsFiles fromp'
|
|
|
|
|
2016-06-14 17:13:25 +00:00
|
|
|
-- create the destination dir and
|
|
|
|
-- only return contents if we succeed
|
2018-04-10 22:44:47 +00:00
|
|
|
handleIOE (CreateDirFailed fromBS destdirpBS) ce [] $ do
|
|
|
|
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus fromBS
|
2016-06-14 17:13:25 +00:00
|
|
|
case cm of
|
2018-04-10 22:44:47 +00:00
|
|
|
Strict -> createDirectory destdirpBS fmode'
|
|
|
|
Overwrite -> catchIOError (createDirectory destdirpBS
|
2016-06-14 17:13:25 +00:00
|
|
|
fmode')
|
|
|
|
$ \e ->
|
|
|
|
case ioeGetErrorType e of
|
2018-04-10 22:44:47 +00:00
|
|
|
AlreadyExists -> setFileMode destdirpBS
|
2016-06-14 17:13:25 +00:00
|
|
|
fmode'
|
|
|
|
_ -> ioError e
|
|
|
|
return contents
|
|
|
|
|
|
|
|
-- NOTE: we can't use `easyCopy` here, because we want to call `go`
|
2016-05-31 14:21:14 +00:00
|
|
|
-- recursively to skip the top-level sanity checks
|
2016-06-14 17:13:25 +00:00
|
|
|
|
|
|
|
-- if reading the contents and creating the destination dir worked,
|
|
|
|
-- then copy the contents to the destination too
|
2016-05-09 14:53:31 +00:00
|
|
|
for_ contents $ \f -> do
|
|
|
|
ftype <- getFileType f
|
|
|
|
newdest <- (destdirp' </>) <$> basename f
|
|
|
|
case ftype of
|
2018-04-10 22:44:47 +00:00
|
|
|
SymbolicLink -> handleIOE (RecreateSymlinkFailed (toFilePath f) (toFilePath newdest)) ce ()
|
2016-06-05 01:10:28 +00:00
|
|
|
$ recreateSymlink f newdest cm
|
|
|
|
Directory -> go ce f newdest
|
2018-04-10 22:44:47 +00:00
|
|
|
RegularFile -> handleIOE (CopyFileFailed (toFilePath f) (toFilePath newdest)) ce ()
|
2016-06-14 17:13:25 +00:00
|
|
|
$ copyFile f newdest cm
|
2016-05-09 22:27:46 +00:00
|
|
|
_ -> return ()
|
2016-06-14 17:13:25 +00:00
|
|
|
|
|
|
|
-- helper to handle errors for both RecursiveErrorModes and return a
|
|
|
|
-- default value
|
|
|
|
handleIOE :: RecursiveFailureHint
|
|
|
|
-> IORef [(RecursiveFailureHint, IOException)]
|
|
|
|
-> a -> IO a -> IO a
|
|
|
|
handleIOE hint ce def = case rm of
|
|
|
|
FailEarly -> handleIOError throwIO
|
|
|
|
CollectFailures -> handleIOError (\e -> modifyIORef ce ((hint, e):)
|
2016-06-05 01:10:28 +00:00
|
|
|
>> return def)
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
2016-06-05 01:10:28 +00:00
|
|
|
-- |Recreate a symlink.
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
2016-06-05 14:07:46 +00:00
|
|
|
-- In `Overwrite` copy mode only files and empty directories are deleted.
|
2016-05-31 14:21:14 +00:00
|
|
|
--
|
2016-06-05 01:10:28 +00:00
|
|
|
-- Safety/reliability concerns:
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
2016-06-05 01:10:28 +00:00
|
|
|
-- * `Overwrite` mode is inherently non-atomic
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
2016-05-31 14:21:14 +00:00
|
|
|
-- - `InvalidArgument` if source file is wrong type (not a symlink)
|
2016-05-09 14:53:31 +00:00
|
|
|
-- - `PermissionDenied` if output directory cannot be written to
|
|
|
|
-- - `PermissionDenied` if source directory cannot be opened
|
2016-06-05 13:57:41 +00:00
|
|
|
-- - `SameFile` if source and destination are the same file
|
|
|
|
-- (`HPathIOException`)
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
2016-06-05 01:22:11 +00:00
|
|
|
--
|
|
|
|
-- Throws in `Strict` mode only:
|
|
|
|
--
|
2016-06-14 17:13:25 +00:00
|
|
|
-- - `AlreadyExists` if destination already exists
|
2016-06-05 01:22:11 +00:00
|
|
|
--
|
|
|
|
-- Throws in `Overwrite` mode only:
|
|
|
|
--
|
|
|
|
-- - `UnsatisfiedConstraints` if destination file is non-empty directory
|
|
|
|
--
|
2018-04-12 12:28:37 +00:00
|
|
|
-- Notes:
|
|
|
|
--
|
|
|
|
-- - calls `symlink`
|
|
|
|
-- - calls `getcwd` in Overwrite mode (if destination is a relative path)
|
2018-04-10 22:44:47 +00:00
|
|
|
recreateSymlink :: Path b1 -- ^ the old symlink file
|
|
|
|
-> Path b2 -- ^ destination file
|
2016-06-05 01:10:28 +00:00
|
|
|
-> CopyMode
|
2016-05-09 14:53:31 +00:00
|
|
|
-> IO ()
|
2018-04-10 22:44:47 +00:00
|
|
|
recreateSymlink symsource@(MkPath symsourceBS) newsym@(MkPath newsymBS) cm
|
2016-05-09 14:53:31 +00:00
|
|
|
= do
|
|
|
|
throwSameFile symsource newsym
|
2018-04-10 22:44:47 +00:00
|
|
|
sympoint <- readSymbolicLink symsourceBS
|
2016-06-05 01:10:28 +00:00
|
|
|
case cm of
|
|
|
|
Strict -> return ()
|
|
|
|
Overwrite -> do
|
2018-04-10 22:44:47 +00:00
|
|
|
writable <- toAbs newsym >>= isWritable
|
2016-06-05 01:10:28 +00:00
|
|
|
isfile <- doesFileExist newsym
|
|
|
|
isdir <- doesDirectoryExist newsym
|
|
|
|
when (writable && isfile) (deleteFile newsym)
|
|
|
|
when (writable && isdir) (deleteDir newsym)
|
2018-04-10 22:44:47 +00:00
|
|
|
createSymbolicLink sympoint newsymBS
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |Copies the given regular file to the given destination.
|
|
|
|
-- Neither follows symbolic links, nor accepts them.
|
|
|
|
-- For "copying" symbolic links, use `recreateSymlink` instead.
|
|
|
|
--
|
2016-05-31 14:21:14 +00:00
|
|
|
-- Note that this is still sort of a low-level function and doesn't
|
|
|
|
-- examine file types. For a more high-level version, use `easyCopy`
|
|
|
|
-- instead.
|
|
|
|
--
|
2016-06-05 14:07:46 +00:00
|
|
|
-- In `Overwrite` copy mode only overwrites actual files, not directories.
|
2019-12-29 19:03:28 +00:00
|
|
|
-- In `Strict` mode the destination file must not exist.
|
2016-06-05 01:10:28 +00:00
|
|
|
--
|
2016-05-31 14:21:14 +00:00
|
|
|
-- Safety/reliability concerns:
|
|
|
|
--
|
2016-06-05 01:10:28 +00:00
|
|
|
-- * `Overwrite` mode is not atomic
|
2016-05-31 14:21:14 +00:00
|
|
|
-- * when used on `CharacterDevice`, reads the "contents" and copies
|
|
|
|
-- them to a regular file, which might take indefinitely
|
|
|
|
-- * when used on `BlockDevice`, may either read the "contents"
|
|
|
|
-- and copy them to a regular file (potentially hanging indefinitely)
|
|
|
|
-- or may create a regular empty destination file
|
|
|
|
-- * when used on `NamedPipe`, will hang indefinitely
|
|
|
|
--
|
2016-05-09 14:53:31 +00:00
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `NoSuchThing` if source file does not exist
|
2016-05-31 14:21:14 +00:00
|
|
|
-- - `NoSuchThing` if source file is a a `Socket`
|
2016-05-09 14:53:31 +00:00
|
|
|
-- - `PermissionDenied` if output directory is not writable
|
|
|
|
-- - `PermissionDenied` if source directory can't be opened
|
2016-05-31 14:21:14 +00:00
|
|
|
-- - `InvalidArgument` if source file is wrong type (symlink or directory)
|
2016-06-05 13:57:41 +00:00
|
|
|
-- - `SameFile` if source and destination are the same file
|
|
|
|
-- (`HPathIOException`)
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
2016-06-05 01:22:11 +00:00
|
|
|
-- Throws in `Strict` mode only:
|
|
|
|
--
|
|
|
|
-- - `AlreadyExists` if destination already exists
|
|
|
|
--
|
2018-04-12 12:28:37 +00:00
|
|
|
-- Notes:
|
|
|
|
--
|
2019-12-30 14:16:59 +00:00
|
|
|
-- - on GHC < 8.2: calls `sendfile` and possibly `read`/`write` as fallback
|
|
|
|
-- - on GHC >= 8.2: uses streamly for file copying
|
2018-04-12 12:28:37 +00:00
|
|
|
-- - may call `getcwd` in Overwrite mode (if destination is a relative path)
|
2018-04-10 22:44:47 +00:00
|
|
|
copyFile :: Path b1 -- ^ source file
|
|
|
|
-> Path b2 -- ^ destination file
|
2016-06-05 01:10:28 +00:00
|
|
|
-> CopyMode
|
2016-05-09 14:53:31 +00:00
|
|
|
-> IO ()
|
2019-12-30 14:16:59 +00:00
|
|
|
#if __GLASGOW_HASKELL__ >= 802
|
2019-12-29 19:03:28 +00:00
|
|
|
copyFile fp@(MkPath from) tp@(MkPath to) cm = do
|
|
|
|
throwSameFile fp tp
|
|
|
|
bracket (do
|
|
|
|
fd <- openFd from SPI.ReadOnly [SPDF.oNofollow] Nothing
|
|
|
|
handle <- SPI.fdToHandle fd
|
|
|
|
pure (fd, handle))
|
|
|
|
(\(_, handle) -> SIO.hClose handle)
|
|
|
|
$ \(fromFd, fH) -> do
|
|
|
|
sourceFileMode <- System.Posix.Files.ByteString.fileMode <$> getFdStatus fromFd
|
|
|
|
let dflags = [SPDF.oNofollow, case cm of
|
|
|
|
Strict -> SPDF.oExcl
|
|
|
|
Overwrite -> SPDF.oTrunc]
|
|
|
|
bracketeer (do
|
|
|
|
fd <- openFd to SPI.WriteOnly dflags $ Just sourceFileMode
|
|
|
|
handle <- SPI.fdToHandle fd
|
|
|
|
pure (fd, handle))
|
|
|
|
(\(_, handle) -> SIO.hClose handle)
|
|
|
|
(\(_, handle) -> do
|
|
|
|
SIO.hClose handle
|
|
|
|
case cm of
|
|
|
|
-- if we created the file and copying failed, it's
|
|
|
|
-- safe to clean up
|
|
|
|
Strict -> deleteFile tp
|
|
|
|
Overwrite -> pure ())
|
|
|
|
$ \(_, tH) -> do
|
|
|
|
SIO.hSetBinaryMode fH True
|
|
|
|
SIO.hSetBinaryMode tH True
|
|
|
|
streamlyCopy (fH, tH)
|
2016-05-09 14:53:31 +00:00
|
|
|
where
|
2019-12-29 19:03:28 +00:00
|
|
|
streamlyCopy (fH, tH) = S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256*1024) fH
|
2019-12-30 14:16:59 +00:00
|
|
|
#else
|
|
|
|
copyFile from to cm = do
|
|
|
|
throwSameFile from to
|
|
|
|
|
|
|
|
case cm of
|
|
|
|
Strict -> _copyFile [SPDF.oNofollow]
|
|
|
|
[SPDF.oNofollow, SPDF.oExcl]
|
|
|
|
from to
|
|
|
|
Overwrite ->
|
|
|
|
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 <- toAbs to >>= isWritable
|
|
|
|
if (exists && writable)
|
|
|
|
then deleteFile to >> copyFile from to Strict
|
|
|
|
else ioError e
|
|
|
|
_ -> ioError e
|
|
|
|
|
|
|
|
|
|
|
|
_copyFile :: [SPDF.Flags]
|
|
|
|
-> [SPDF.Flags]
|
|
|
|
-> Path b1 -- ^ source file
|
|
|
|
-> Path b2 -- ^ destination file
|
|
|
|
-> IO ()
|
|
|
|
_copyFile sflags dflags (MkPath fromBS) to@(MkPath toBS)
|
|
|
|
=
|
|
|
|
-- 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.
|
|
|
|
catchErrno [eINVAL, eNOSYS]
|
|
|
|
(sendFileCopy fromBS toBS)
|
|
|
|
(void $ readWriteCopy fromBS toBS)
|
|
|
|
where
|
|
|
|
copyWith copyAction source dest =
|
|
|
|
bracket (openFd source SPI.ReadOnly sflags Nothing)
|
|
|
|
SPI.closeFd
|
|
|
|
$ \sfd -> do
|
|
|
|
fileM <- System.Posix.Files.ByteString.fileMode
|
|
|
|
<$> getFdStatus sfd
|
|
|
|
bracketeer (openFd dest SPI.WriteOnly
|
|
|
|
dflags $ Just fileM)
|
|
|
|
SPI.closeFd
|
|
|
|
(\fd -> SPI.closeFd fd >> deleteFile to)
|
|
|
|
$ \dfd -> copyAction sfd dfd
|
|
|
|
-- this is low-level stuff utilizing sendfile(2) for speed
|
|
|
|
sendFileCopy :: ByteString -> ByteString -> IO ()
|
|
|
|
sendFileCopy = copyWith
|
|
|
|
(\sfd dfd -> sendfileFd dfd sfd EntireFile $ return ())
|
|
|
|
-- low-level copy operation utilizing read(2)/write(2)
|
|
|
|
-- in case `sendFileCopy` fails/is unsupported
|
|
|
|
readWriteCopy :: ByteString -> ByteString -> IO Int
|
|
|
|
readWriteCopy = copyWith
|
|
|
|
(\sfd 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) (ioError $ userError
|
|
|
|
"wrong size!")
|
|
|
|
write' sfd dfd buf (totalsize + fromIntegral size)
|
|
|
|
#endif
|
2016-05-09 14:53:31 +00:00
|
|
|
|
2016-05-31 14:21:14 +00:00
|
|
|
-- |Copies a regular file, directory or symbolic link. In case of a
|
|
|
|
-- symbolic link it is just recreated, even if it points to a directory.
|
|
|
|
-- Any other file type is ignored.
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- Safety/reliability concerns:
|
|
|
|
--
|
|
|
|
-- * examines filetypes explicitly
|
|
|
|
-- * calls `copyDirRecursive` for directories
|
2018-04-12 12:28:37 +00:00
|
|
|
--
|
|
|
|
-- Note: may call `getcwd` in Overwrite mode (if destination is a relative path)
|
2018-04-10 22:44:47 +00:00
|
|
|
easyCopy :: Path b1
|
|
|
|
-> Path b2
|
2016-06-05 01:10:28 +00:00
|
|
|
-> CopyMode
|
2016-06-05 14:07:46 +00:00
|
|
|
-> RecursiveErrorMode
|
2016-05-09 14:53:31 +00:00
|
|
|
-> IO ()
|
2016-06-05 01:10:28 +00:00
|
|
|
easyCopy from to cm rm = do
|
2016-05-09 14:53:31 +00:00
|
|
|
ftype <- getFileType from
|
|
|
|
case ftype of
|
2016-06-05 01:10:28 +00:00
|
|
|
SymbolicLink -> recreateSymlink from to cm
|
|
|
|
RegularFile -> copyFile from to cm
|
|
|
|
Directory -> copyDirRecursive from to cm rm
|
2016-05-09 22:27:46 +00:00
|
|
|
_ -> return ()
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
---------------------
|
|
|
|
--[ File Deletion ]--
|
|
|
|
---------------------
|
|
|
|
|
|
|
|
|
2016-05-22 11:28:20 +00:00
|
|
|
-- |Deletes the given file. Raises `eISDIR`
|
2016-05-09 14:53:31 +00:00
|
|
|
-- 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
|
2018-04-10 22:44:47 +00:00
|
|
|
deleteFile :: Path b -> IO ()
|
|
|
|
deleteFile (MkPath p) = removeLink p
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |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`
|
2018-04-10 22:44:47 +00:00
|
|
|
deleteDir :: Path b -> IO ()
|
|
|
|
deleteDir (MkPath p) = removeDirectory p
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |Deletes the given directory recursively. Does not follow symbolic
|
|
|
|
-- links. Tries `deleteDir` first before attemtping a recursive
|
|
|
|
-- deletion.
|
|
|
|
--
|
2016-05-31 14:21:14 +00:00
|
|
|
-- On directory contents this behaves like `easyDelete`
|
|
|
|
-- and thus will ignore any file type that is not `RegularFile`,
|
|
|
|
-- `SymbolicLink` or `Directory`.
|
|
|
|
--
|
2016-05-09 14:53:31 +00:00
|
|
|
-- 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
|
2018-04-10 22:44:47 +00:00
|
|
|
deleteDirRecursive :: Path b -> IO ()
|
2016-05-09 14:53:31 +00:00
|
|
|
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
|
2016-05-09 22:27:46 +00:00
|
|
|
_ -> return ()
|
2016-05-09 14:53:31 +00:00
|
|
|
removeDirectory . toFilePath $ p
|
|
|
|
|
|
|
|
|
2016-05-31 14:21:14 +00:00
|
|
|
-- |Deletes a file, directory or symlink.
|
2016-05-09 14:53:31 +00:00
|
|
|
-- In case of directory, performs recursive deletion. In case of
|
|
|
|
-- a symlink, the symlink file is deleted.
|
2016-05-31 14:21:14 +00:00
|
|
|
-- Any other file type is ignored.
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- Safety/reliability concerns:
|
|
|
|
--
|
|
|
|
-- * examines filetypes explicitly
|
|
|
|
-- * calls `deleteDirRecursive` for directories
|
2018-04-10 22:44:47 +00:00
|
|
|
easyDelete :: Path b -> IO ()
|
2016-05-09 14:53:31 +00:00
|
|
|
easyDelete p = do
|
|
|
|
ftype <- getFileType p
|
|
|
|
case ftype of
|
|
|
|
SymbolicLink -> deleteFile p
|
|
|
|
Directory -> deleteDirRecursive p
|
|
|
|
RegularFile -> deleteFile p
|
2016-05-09 22:27:46 +00:00
|
|
|
_ -> return ()
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
--------------------
|
|
|
|
--[ File Opening ]--
|
|
|
|
--------------------
|
|
|
|
|
|
|
|
|
|
|
|
-- |Opens a file appropriately by invoking xdg-open. The file type
|
2016-05-09 15:37:16 +00:00
|
|
|
-- is not checked. This forks a process.
|
2018-04-10 22:44:47 +00:00
|
|
|
openFile :: Path b
|
2016-05-09 14:53:31 +00:00
|
|
|
-> IO ProcessID
|
2018-04-10 22:44:47 +00:00
|
|
|
openFile (MkPath fp) =
|
|
|
|
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
2016-05-09 15:37:16 +00:00
|
|
|
-- |Executes a program with the given arguments. This forks a process.
|
2018-04-10 22:44:47 +00:00
|
|
|
executeFile :: Path b -- ^ program
|
2016-05-09 14:53:31 +00:00
|
|
|
-> [ByteString] -- ^ arguments
|
|
|
|
-> IO ProcessID
|
2018-04-10 22:44:47 +00:00
|
|
|
executeFile (MkPath fp) args =
|
|
|
|
SPP.forkProcess $ SPP.executeFile fp True args Nothing
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
---------------------
|
|
|
|
--[ File Creation ]--
|
|
|
|
---------------------
|
|
|
|
|
|
|
|
|
2016-06-05 13:57:41 +00:00
|
|
|
-- |Create an empty regular file at the given directory with the given
|
|
|
|
-- filename.
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `PermissionDenied` if output directory cannot be written to
|
2016-06-14 17:13:25 +00:00
|
|
|
-- - `AlreadyExists` if destination already exists
|
2016-06-05 19:59:31 +00:00
|
|
|
-- - `NoSuchThing` if any of the parent components of the path
|
|
|
|
-- do not exist
|
2018-04-10 22:44:47 +00:00
|
|
|
createRegularFile :: FileMode -> Path b -> IO ()
|
|
|
|
createRegularFile fm (MkPath destBS) =
|
|
|
|
bracket (SPI.openFd destBS SPI.WriteOnly (Just fm)
|
2016-05-09 14:53:31 +00:00
|
|
|
(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
|
2016-06-14 17:13:25 +00:00
|
|
|
-- - `AlreadyExists` if destination already exists
|
2016-06-05 19:59:31 +00:00
|
|
|
-- - `NoSuchThing` if any of the parent components of the path
|
|
|
|
-- do not exist
|
2018-04-10 22:44:47 +00:00
|
|
|
createDir :: FileMode -> Path b -> IO ()
|
|
|
|
createDir fm (MkPath destBS) = createDirectory destBS fm
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
2016-06-12 23:28:55 +00:00
|
|
|
-- |Create an empty directory at the given directory with the given filename.
|
|
|
|
-- All parent directories are created with the same filemode. This
|
|
|
|
-- basically behaves like:
|
|
|
|
--
|
|
|
|
-- @
|
2016-06-12 23:38:44 +00:00
|
|
|
-- mkdir -p \/some\/dir
|
2016-06-12 23:28:55 +00:00
|
|
|
-- @
|
|
|
|
--
|
|
|
|
-- Safety/reliability concerns:
|
|
|
|
--
|
|
|
|
-- * not atomic
|
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `PermissionDenied` if any part of the path components do not
|
|
|
|
-- exist and cannot be written to
|
|
|
|
-- - `AlreadyExists` if destination already exists and
|
|
|
|
-- is not a directory
|
2018-04-12 12:28:37 +00:00
|
|
|
--
|
|
|
|
-- Note: calls `getcwd` if the input path is a relative path
|
2018-04-10 22:44:47 +00:00
|
|
|
createDirRecursive :: FileMode -> Path b -> IO ()
|
|
|
|
createDirRecursive fm p =
|
|
|
|
toAbs p >>= go
|
|
|
|
where
|
|
|
|
go :: Path Abs -> IO ()
|
|
|
|
go dest@(MkPath destBS) = do
|
|
|
|
catchIOError (createDirectory destBS fm) $ \e -> do
|
|
|
|
errno <- getErrno
|
|
|
|
case errno of
|
|
|
|
en | en == eEXIST -> unlessM (doesDirectoryExist dest) (ioError e)
|
|
|
|
| en == eNOENT -> createDirRecursive fm (dirname dest)
|
|
|
|
>> createDirectory destBS fm
|
|
|
|
| otherwise -> ioError e
|
2016-06-12 23:28:55 +00:00
|
|
|
|
|
|
|
|
2016-05-29 15:28:12 +00:00
|
|
|
-- |Create a symlink.
|
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `PermissionDenied` if output directory cannot be written to
|
|
|
|
-- - `AlreadyExists` if destination file already exists
|
2016-06-05 19:59:31 +00:00
|
|
|
-- - `NoSuchThing` if any of the parent components of the path
|
|
|
|
-- do not exist
|
2016-05-29 15:28:12 +00:00
|
|
|
--
|
|
|
|
-- Note: calls `symlink`
|
2018-04-10 22:44:47 +00:00
|
|
|
createSymlink :: Path b -- ^ destination file
|
2016-05-29 15:28:12 +00:00
|
|
|
-> ByteString -- ^ path the symlink points to
|
|
|
|
-> IO ()
|
2018-04-10 22:44:47 +00:00
|
|
|
createSymlink (MkPath destBS) sympoint
|
|
|
|
= createSymbolicLink sympoint destBS
|
2016-05-29 15:28:12 +00:00
|
|
|
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
----------------------------
|
|
|
|
--[ 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
|
2016-06-05 13:57:41 +00:00
|
|
|
-- - `UnsupportedOperation` if source and destination are on different
|
|
|
|
-- devices
|
2016-06-14 17:13:25 +00:00
|
|
|
-- - `AlreadyExists` if destination already exists
|
2016-06-05 13:57:41 +00:00
|
|
|
-- - `SameFile` if destination and source are the same file
|
|
|
|
-- (`HPathIOException`)
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- Note: calls `rename` (but does not allow to rename over existing files)
|
2018-04-10 22:44:47 +00:00
|
|
|
renameFile :: Path b1 -> Path b2 -> IO ()
|
|
|
|
renameFile fromf@(MkPath fromfBS) tof@(MkPath tofBS) = do
|
2016-05-09 14:53:31 +00:00
|
|
|
throwSameFile fromf tof
|
|
|
|
throwFileDoesExist tof
|
|
|
|
throwDirDoesExist tof
|
2018-04-10 22:44:47 +00:00
|
|
|
rename fromfBS tofBS
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |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.
|
|
|
|
--
|
2016-05-31 14:21:14 +00:00
|
|
|
--
|
2016-05-09 14:53:31 +00:00
|
|
|
-- Safety/reliability concerns:
|
|
|
|
--
|
2016-06-05 01:10:28 +00:00
|
|
|
-- * `Overwrite` mode is not atomic
|
2016-05-09 14:53:31 +00:00
|
|
|
-- * copy-delete fallback is inherently non-atomic
|
2016-05-31 14:21:14 +00:00
|
|
|
-- * since this function calls `easyCopy` and `easyDelete` as a fallback
|
|
|
|
-- to `renameFile`, file types that are not `RegularFile`, `SymbolicLink`
|
|
|
|
-- or `Directory` may be ignored
|
2016-06-05 01:10:28 +00:00
|
|
|
-- * for `Overwrite` mode, the destination will be deleted (not recursively)
|
|
|
|
-- before moving
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `NoSuchThing` if source file does not exist
|
|
|
|
-- - `PermissionDenied` if output directory cannot be written to
|
|
|
|
-- - `PermissionDenied` if source directory cannot be opened
|
2016-06-05 13:57:41 +00:00
|
|
|
-- - `SameFile` if destination and source are the same file
|
|
|
|
-- (`HPathIOException`)
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
2016-06-05 01:22:11 +00:00
|
|
|
-- Throws in `Strict` mode only:
|
|
|
|
--
|
2016-06-14 17:13:25 +00:00
|
|
|
-- - `AlreadyExists` if destination already exists
|
2016-06-05 01:22:11 +00:00
|
|
|
--
|
2018-04-12 12:28:37 +00:00
|
|
|
-- Notes:
|
|
|
|
--
|
|
|
|
-- - calls `rename` (but does not allow to rename over existing files)
|
|
|
|
-- - calls `getcwd` in Overwrite mode if destination is a relative path
|
2018-04-10 22:44:47 +00:00
|
|
|
moveFile :: Path b1 -- ^ file to move
|
|
|
|
-> Path b2 -- ^ destination
|
2016-06-05 01:10:28 +00:00
|
|
|
-> CopyMode
|
2016-05-09 14:53:31 +00:00
|
|
|
-> IO ()
|
2016-06-05 01:10:28 +00:00
|
|
|
moveFile from to cm = do
|
2016-05-09 14:53:31 +00:00
|
|
|
throwSameFile from to
|
2016-06-05 01:10:28 +00:00
|
|
|
case cm of
|
|
|
|
Strict -> catchErrno [eXDEV] (renameFile from to) $ do
|
|
|
|
easyCopy from to Strict FailEarly
|
|
|
|
easyDelete from
|
|
|
|
Overwrite -> do
|
|
|
|
ft <- getFileType from
|
2018-04-10 22:44:47 +00:00
|
|
|
writable <- toAbs to >>= isWritable
|
2016-06-05 01:10:28 +00:00
|
|
|
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)
|
|
|
|
_ -> return ()
|
|
|
|
moveFile from to Strict
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2018-04-06 14:42:40 +00:00
|
|
|
--------------------
|
|
|
|
--[ File Reading ]--
|
|
|
|
--------------------
|
|
|
|
|
|
|
|
|
|
|
|
-- |Read the given file at once into memory as a strict ByteString.
|
|
|
|
-- Symbolic links are followed, no sanity checks on file size
|
|
|
|
-- or file type. File must exist.
|
|
|
|
--
|
|
|
|
-- Note: the size of the file is determined in advance, as to only
|
|
|
|
-- have one allocation.
|
|
|
|
--
|
|
|
|
-- Safety/reliability concerns:
|
|
|
|
--
|
|
|
|
-- * since amount of bytes to read is determined in advance,
|
|
|
|
-- the file might be read partially only if something else is
|
|
|
|
-- appending to it while reading
|
|
|
|
-- * the whole file is read into memory!
|
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `InappropriateType` if file is not a regular file or a symlink
|
|
|
|
-- - `PermissionDenied` if we cannot read the file or the directory
|
|
|
|
-- containting it
|
|
|
|
-- - `NoSuchThing` if the file does not exist
|
2018-04-10 22:44:47 +00:00
|
|
|
readFile :: Path b -> IO ByteString
|
|
|
|
readFile (MkPath fp) =
|
2018-04-06 14:42:40 +00:00
|
|
|
bracket (openFd fp SPI.ReadOnly [] Nothing) (SPI.closeFd) $ \fd -> do
|
|
|
|
stat <- PF.getFdStatus fd
|
|
|
|
let fsize = PF.fileSize stat
|
|
|
|
SPB.fdRead fd (fromIntegral fsize)
|
|
|
|
|
|
|
|
|
|
|
|
-- |Read the given file in chunks of size `8192` into memory until
|
|
|
|
-- `fread` returns 0. Returns a lazy ByteString, because it uses
|
|
|
|
-- Builders under the hood.
|
|
|
|
--
|
|
|
|
-- Safety/reliability concerns:
|
|
|
|
--
|
|
|
|
-- * the whole file is read into memory!
|
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `InappropriateType` if file is not a regular file or a symlink
|
|
|
|
-- - `PermissionDenied` if we cannot read the file or the directory
|
|
|
|
-- containting it
|
|
|
|
-- - `NoSuchThing` if the file does not exist
|
2018-04-10 22:44:47 +00:00
|
|
|
readFileEOF :: Path b -> IO L.ByteString
|
|
|
|
readFileEOF (MkPath fp) =
|
2018-04-06 14:42:40 +00:00
|
|
|
bracket (openFd fp SPI.ReadOnly [] Nothing) (SPI.closeFd) $ \fd ->
|
|
|
|
allocaBytes (fromIntegral bufSize) $ \buf -> read' fd buf mempty
|
|
|
|
where
|
|
|
|
bufSize :: CSize
|
|
|
|
bufSize = 8192
|
|
|
|
read' :: Fd -> Ptr Word8 -> Builder -> IO L.ByteString
|
|
|
|
read' fd buf builder = do
|
|
|
|
size <- SPB.fdReadBuf fd buf bufSize
|
|
|
|
if size == 0
|
|
|
|
then return $ toLazyByteString builder
|
|
|
|
else do
|
|
|
|
readBS <- unsafePackCStringFinalizer buf
|
|
|
|
(fromIntegral size)
|
2018-04-11 20:22:03 +00:00
|
|
|
(return ())
|
2018-04-06 14:42:40 +00:00
|
|
|
read' fd buf (builder <> byteString readBS)
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
2018-04-06 15:22:22 +00:00
|
|
|
--------------------
|
|
|
|
--[ File Writing ]--
|
|
|
|
--------------------
|
|
|
|
|
|
|
|
|
|
|
|
-- |Write a given ByteString to a file, truncating the file beforehand.
|
|
|
|
-- The file must exist. Follows symlinks.
|
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `InappropriateType` if file is not a regular file or a symlink
|
|
|
|
-- - `PermissionDenied` if we cannot read the file or the directory
|
|
|
|
-- containting it
|
|
|
|
-- - `NoSuchThing` if the file does not exist
|
2018-04-10 22:44:47 +00:00
|
|
|
writeFile :: Path b -> ByteString -> IO ()
|
|
|
|
writeFile (MkPath fp) bs =
|
2018-04-06 15:22:22 +00:00
|
|
|
bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] Nothing) (SPI.closeFd) $ \fd ->
|
|
|
|
void $ SPB.fdWrite fd bs
|
|
|
|
|
|
|
|
|
|
|
|
-- |Append a given ByteString to a file.
|
|
|
|
-- The file must exist. Follows symlinks.
|
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `InappropriateType` if file is not a regular file or a symlink
|
|
|
|
-- - `PermissionDenied` if we cannot read the file or the directory
|
|
|
|
-- containting it
|
|
|
|
-- - `NoSuchThing` if the file does not exist
|
2018-04-10 22:44:47 +00:00
|
|
|
appendFile :: Path b -> ByteString -> IO ()
|
|
|
|
appendFile (MkPath fp) bs =
|
2018-04-06 15:22:22 +00:00
|
|
|
bracket (openFd fp SPI.WriteOnly [SPDF.oAppend] Nothing)
|
|
|
|
(SPI.closeFd) $ \fd -> void $ SPB.fdWrite fd bs
|
|
|
|
|
|
|
|
|
|
|
|
|
2016-05-09 14:53:31 +00:00
|
|
|
|
|
|
|
-----------------------
|
|
|
|
--[ 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.
|
|
|
|
--
|
2016-06-05 13:57:41 +00:00
|
|
|
-- The contents are not sorted and there is no guarantee on the ordering.
|
|
|
|
--
|
2016-05-09 14:53:31 +00:00
|
|
|
-- 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
|
2018-04-10 22:44:47 +00:00
|
|
|
getDirsFiles :: Path b -- ^ dir to read
|
|
|
|
-> IO [Path b]
|
|
|
|
getDirsFiles p@(MkPath fp) = do
|
|
|
|
fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing
|
|
|
|
return
|
|
|
|
. catMaybes
|
|
|
|
. fmap (\x -> (</>) p <$> (parseMaybe . snd $ x))
|
|
|
|
=<< getDirectoryContents' fd
|
2016-05-09 12:40:30 +00:00
|
|
|
where
|
2016-05-09 14:53:31 +00:00
|
|
|
parseMaybe :: ByteString -> Maybe (Path Fn)
|
|
|
|
parseMaybe = parseFn
|
|
|
|
|
2016-05-09 12:40:30 +00:00
|
|
|
|
|
|
|
|
|
|
|
|
2016-05-09 14:53:31 +00:00
|
|
|
---------------------------
|
|
|
|
--[ FileType operations ]--
|
|
|
|
---------------------------
|
2016-05-09 12:40:30 +00:00
|
|
|
|
|
|
|
|
2016-05-09 14:53:31 +00:00
|
|
|
-- |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
|
2018-04-10 22:44:47 +00:00
|
|
|
getFileType :: Path b -> IO FileType
|
|
|
|
getFileType (MkPath fp) = do
|
|
|
|
fs <- PF.getSymbolicLinkStatus fp
|
2016-05-09 14:53:31 +00:00
|
|
|
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?!"
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
--------------
|
|
|
|
--[ Others ]--
|
|
|
|
--------------
|
|
|
|
|
|
|
|
|
|
|
|
|
2018-04-10 22:44:47 +00:00
|
|
|
-- |Applies `realpath` on the given path.
|
2016-05-09 14:53:31 +00:00
|
|
|
--
|
|
|
|
-- Throws:
|
|
|
|
--
|
|
|
|
-- - `NoSuchThing` if the file at the given path does not exist
|
|
|
|
-- - `NoSuchThing` if the symlink is broken
|
2018-04-10 22:44:47 +00:00
|
|
|
canonicalizePath :: Path b -> IO (Path Abs)
|
2016-05-09 12:40:30 +00:00
|
|
|
canonicalizePath (MkPath l) = do
|
2016-05-09 14:53:31 +00:00
|
|
|
nl <- SPDT.realpath l
|
2016-05-09 12:40:30 +00:00
|
|
|
return $ MkPath nl
|
2018-04-10 22:44:47 +00:00
|
|
|
|
|
|
|
|
|
|
|
-- |Converts any path to an absolute path.
|
|
|
|
-- This is done in the following way:
|
|
|
|
--
|
|
|
|
-- - if the path is already an absolute one, just return it
|
|
|
|
-- - if it's a relative path, prepend the current directory to it
|
|
|
|
toAbs :: Path b -> IO (Path Abs)
|
|
|
|
toAbs (MkPath bs) = do
|
|
|
|
let mabs = parseAbs bs :: Maybe (Path Abs)
|
|
|
|
case mabs of
|
|
|
|
Just a -> return a
|
|
|
|
Nothing -> do
|
|
|
|
cwd <- getWorkingDirectory >>= parseAbs
|
|
|
|
rel <- parseRel bs -- we know it must be relative now
|
|
|
|
return $ cwd </> rel
|