Make hpath-io use hpath-directory

This commit is contained in:
Julian Ospald 2020-01-26 21:49:34 +01:00
parent d4402a25bb
commit 1d00ae469d
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
38 changed files with 57 additions and 4392 deletions

View File

@ -1,7 +0,0 @@
#include "dirutils.h"
unsigned int
__posixdir_d_type(struct dirent* d)
{
return(d -> d_type);
}

View File

@ -1,13 +0,0 @@
#ifndef POSIXPATHS_CBITS_DIRUTILS_H
#define POSIXPATHS_CBITS_DIRUTILS_H
#include <stdlib.h>
#include <dirent.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
extern unsigned int
__posixdir_d_type(struct dirent* d)
;
#endif

View File

@ -19,23 +19,18 @@ tested-with: GHC==7.10.3
, GHC==8.8.1
extra-source-files: README.md
CHANGELOG.md
cbits/dirutils.h
library
if os(windows)
build-depends: unbuildable<0
buildable: False
exposed-modules: HPath.IO,
HPath.IO.Errors,
System.Posix.Directory.Foreign,
System.Posix.Directory.Traversals,
System.Posix.FD
c-sources: cbits/dirutils.c
exposed-modules: HPath.IO
build-depends: base >= 4.8 && <5
, IfElse
, bytestring >= 0.10.0.0
, exceptions
, hpath >= 0.11 && < 0.12
, hpath-directory >= 0.13 && < 0.14
, hpath-filepath >= 0.10.2 && < 0.11
, safe-exceptions >= 0.1
, streamly >= 0.7
@ -49,56 +44,6 @@ library
hs-source-dirs: src
default-language: Haskell2010
test-suite spec
if os(windows)
build-depends: unbuildable<0
buildable: False
Type: exitcode-stdio-1.0
Default-Language: Haskell2010
Hs-Source-Dirs: test
Main-Is: Main.hs
other-modules:
HPath.IO.AppendFileSpec
HPath.IO.CanonicalizePathSpec
HPath.IO.CopyDirRecursiveCollectFailuresSpec
HPath.IO.CopyDirRecursiveOverwriteSpec
HPath.IO.CopyDirRecursiveSpec
HPath.IO.CopyFileOverwriteSpec
HPath.IO.CopyFileSpec
HPath.IO.CreateDirIfMissingSpec
HPath.IO.CreateDirRecursiveSpec
HPath.IO.CreateDirSpec
HPath.IO.CreateRegularFileSpec
HPath.IO.CreateSymlinkSpec
HPath.IO.DeleteDirRecursiveSpec
HPath.IO.DeleteDirSpec
HPath.IO.DeleteFileSpec
HPath.IO.GetDirsFilesSpec
HPath.IO.GetFileTypeSpec
HPath.IO.MoveFileOverwriteSpec
HPath.IO.MoveFileSpec
HPath.IO.ReadFileSpec
HPath.IO.RecreateSymlinkOverwriteSpec
HPath.IO.RecreateSymlinkSpec
HPath.IO.RenameFileSpec
HPath.IO.ToAbsSpec
HPath.IO.WriteFileLSpec
HPath.IO.WriteFileSpec
Spec
Utils
GHC-Options: -Wall
Build-Depends: base
, HUnit
, IfElse
, bytestring >= 0.10.0.0
, hpath
, hpath-io
, hspec >= 1.3
, process
, time >= 1.8
, unix
, unix-bytestring
, utf8-string
source-repository head
type: git

View File

@ -9,15 +9,9 @@
--
-- This module provides high-level IO related file operations like
-- 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.
--
-- 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`).
-- guarantees us well-typed paths. This is a thin wrapper over
-- System.Posix.RawFilePath.Directory in 'hpath-directory'. It's
-- encouraged to use this module.
--
-- Some of these operations are due to their nature __not atomic__, which
-- means they may do multiple syscalls which form one context. Some
@ -98,6 +92,7 @@ module HPath.IO
, toAbs
, withRawFilePath
, withHandle
, module System.Posix.RawFilePath.Directory.Errors
)
where
@ -197,7 +192,6 @@ import GHC.IO.Exception
IOErrorType(..)
)
import HPath
import HPath.IO.Errors
import Prelude hiding (appendFile, readFile, writeFile)
import Streamly
import Streamly.External.ByteString
@ -227,10 +221,6 @@ import System.Posix.Directory.ByteString
, openDirStream
, removeDirectory
)
import System.Posix.Directory.Traversals
(
getDirectoryContents'
)
import System.Posix.Files.ByteString
(
createSymbolicLink
@ -260,9 +250,8 @@ import System.Posix.FD
(
openFd
)
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.RawFilePath.Directory.Errors
import System.Posix.Types
(
FileMode
@ -272,48 +261,17 @@ import System.Posix.Types
)
import System.Posix.Time
import qualified System.Posix.RawFilePath.Directory as RD
import System.Posix.RawFilePath.Directory
(
FileType
, RecursiveErrorMode
, CopyMode
)
-------------
--[ Types ]--
-------------
data FileType = Directory
| RegularFile
| SymbolicLink
| BlockDevice
| CharacterDevice
| NamedPipe
| Socket
deriving (Eq, Show)
-- |The error mode for recursive operations.
--
-- On `FailEarly` the whole operation fails immediately if any of the
-- recursive sub-operations fail, which is sort of the default
-- for IO operations.
--
-- On `CollectFailures` skips errors in the recursion and keeps on recursing.
-- However all errors are collected in the `RecursiveFailure` error type,
-- 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.
data RecursiveErrorMode = FailEarly
| CollectFailures
-- |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
--------------------
@ -379,68 +337,8 @@ copyDirRecursive :: Path b1 -- ^ source dir
-> CopyMode
-> RecursiveErrorMode
-> IO ()
copyDirRecursive fromp destdirp cm rm
= do
ce <- newIORef []
-- for performance, sanity checks are only done for the top dir
throwSameFile fromp destdirp
throwDestinationInSource fromp destdirp
go ce fromp destdirp
collectedExceptions <- readIORef ce
unless (null collectedExceptions)
(throwIO . RecursiveFailure $ collectedExceptions)
where
go :: IORef [(RecursiveFailureHint, IOException)]
-> Path b1 -> Path b2 -> IO ()
go ce fromp'@(Path fromBS) destdirp'@(Path destdirpBS) = do
-- NOTE: order is important here, so we don't get empty directories
-- on failure
-- get the contents of the source dir
contents <- handleIOE (ReadContentsFailed fromBS destdirpBS) ce [] $ do
contents <- getDirsFiles fromp'
-- create the destination dir and
-- only return contents if we succeed
handleIOE (CreateDirFailed fromBS destdirpBS) ce [] $ do
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus fromBS
case cm of
Strict -> createDirectory destdirpBS fmode'
Overwrite -> catchIOError (createDirectory destdirpBS
fmode')
$ \e ->
case ioeGetErrorType e of
AlreadyExists -> setFileMode destdirpBS
fmode'
_ -> ioError e
return contents
-- NOTE: we can't use `easyCopy` here, because we want to call `go`
-- recursively to skip the top-level sanity checks
-- if reading the contents and creating the destination dir worked,
-- then copy the contents to the destination too
for_ contents $ \f -> do
ftype <- getFileType f
newdest <- (destdirp' </>) <$> basename f
case ftype of
SymbolicLink -> handleIOE (RecreateSymlinkFailed (toFilePath f) (toFilePath newdest)) ce ()
$ recreateSymlink f newdest cm
Directory -> go ce f newdest
RegularFile -> handleIOE (CopyFileFailed (toFilePath f) (toFilePath newdest)) ce ()
$ copyFile f newdest cm
_ -> return ()
-- 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):)
>> return def)
copyDirRecursive (Path fromp) (Path destdirp) cm rm
= RD.copyDirRecursive fromp destdirp cm rm
-- |Recreate a symlink.
@ -476,21 +374,8 @@ recreateSymlink :: Path b1 -- ^ the old symlink file
-> Path b2 -- ^ destination file
-> CopyMode
-> IO ()
recreateSymlink symsource@(Path symsourceBS) newsym@(Path newsymBS) cm
= do
throwSameFile symsource newsym
sympoint <- readSymbolicLink symsourceBS
case cm of
Strict -> return ()
Overwrite -> do
writable <- toAbs newsym >>= (\p -> do
e <- doesExist p
if e then isWritable p else pure False)
isfile <- doesFileExist newsym
isdir <- doesDirectoryExist newsym
when (writable && isfile) (deleteFile newsym)
when (writable && isdir) (deleteDir newsym)
createSymbolicLink sympoint newsymBS
recreateSymlink (Path symsourceBS) (Path newsymBS) cm
= RD.recreateSymlink symsourceBS newsymBS cm
-- |Copies the given regular file to the given destination.
@ -535,36 +420,7 @@ copyFile :: Path b1 -- ^ source file
-> Path b2 -- ^ destination file
-> CopyMode
-> IO ()
copyFile fp@(Path from) tp@(Path 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)
where
streamlyCopy (fH, tH) = S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256*1024) fH
copyFile (Path from) (Path to) cm = RD.copyFile from to cm
-- |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.
@ -581,13 +437,8 @@ easyCopy :: Path b1
-> CopyMode
-> RecursiveErrorMode
-> IO ()
easyCopy from to cm rm = do
ftype <- getFileType from
case ftype of
SymbolicLink -> recreateSymlink from to cm
RegularFile -> copyFile from to cm
Directory -> copyDirRecursive from to cm rm
_ -> return ()
easyCopy (Path from) (Path to) cm rm = RD.easyCopy from to cm rm
@ -607,7 +458,7 @@ easyCopy from to cm rm = do
-- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if the directory cannot be read
deleteFile :: Path b -> IO ()
deleteFile (Path p) = removeLink p
deleteFile (Path p) = RD.deleteFile p
-- |Deletes the given directory, which must be empty, never symlinks.
@ -622,7 +473,7 @@ deleteFile (Path p) = removeLink p
--
-- Notes: calls `rmdir`
deleteDir :: Path b -> IO ()
deleteDir (Path p) = removeDirectory p
deleteDir (Path p) = RD.deleteDir p
-- |Deletes the given directory recursively. Does not follow symbolic
@ -645,19 +496,8 @@ deleteDir (Path p) = removeDirectory p
-- - `NoSuchThing` if directory does not exist
-- - `PermissionDenied` if we can't open or write to parent directory
deleteDirRecursive :: Path b -> 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
_ -> return ()
removeDirectory . toFilePath $ p
deleteDirRecursive (Path p) = RD.deleteDirRecursive p
-- |Deletes a file, directory or symlink.
@ -670,13 +510,7 @@ deleteDirRecursive p =
-- * examines filetypes explicitly
-- * calls `deleteDirRecursive` for directories
easyDelete :: Path b -> IO ()
easyDelete p = do
ftype <- getFileType p
case ftype of
SymbolicLink -> deleteFile p
Directory -> deleteDirRecursive p
RegularFile -> deleteFile p
_ -> return ()
easyDelete (Path p) = RD.easyDelete p
@ -690,16 +524,14 @@ easyDelete p = do
-- is not checked. This forks a process.
openFile :: Path b
-> IO ProcessID
openFile (Path fp) =
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
openFile (Path fp) = RD.openFile fp
-- |Executes a program with the given arguments. This forks a process.
executeFile :: Path b -- ^ program
-> [ByteString] -- ^ arguments
-> IO ProcessID
executeFile (Path fp) args =
SPP.forkProcess $ SPP.executeFile fp True args Nothing
executeFile (Path fp) args = RD.executeFile fp args
@ -719,11 +551,7 @@ executeFile (Path fp) args =
-- - `NoSuchThing` if any of the parent components of the path
-- do not exist
createRegularFile :: FileMode -> Path b -> IO ()
createRegularFile fm (Path destBS) =
bracket (SPI.openFd destBS SPI.WriteOnly (Just fm)
(SPI.defaultFileFlags { exclusive = True }))
SPI.closeFd
(\_ -> return ())
createRegularFile fm (Path destBS) = RD.createRegularFile fm destBS
-- |Create an empty directory at the given directory with the given filename.
@ -735,7 +563,7 @@ createRegularFile fm (Path destBS) =
-- - `NoSuchThing` if any of the parent components of the path
-- do not exist
createDir :: FileMode -> Path b -> IO ()
createDir fm (Path destBS) = createDirectory destBS fm
createDir fm (Path destBS) = RD.createDir fm destBS
-- |Create an empty directory at the given directory with the given filename.
--
@ -745,8 +573,7 @@ createDir fm (Path destBS) = createDirectory destBS fm
-- - `NoSuchThing` if any of the parent components of the path
-- do not exist
createDirIfMissing :: FileMode -> Path b -> IO ()
createDirIfMissing fm (Path destBS) =
hideError AlreadyExists $ createDirectory destBS fm
createDirIfMissing fm (Path destBS) = RD.createDirIfMissing fm destBS
-- |Create an empty directory at the given directory with the given filename.
@ -770,18 +597,8 @@ createDirIfMissing fm (Path destBS) =
--
-- Note: calls `getcwd` if the input path is a relative path
createDirRecursive :: FileMode -> Path b -> IO ()
createDirRecursive fm p =
toAbs p >>= go
where
go :: Path Abs -> IO ()
go dest@(Path 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
createDirRecursive fm (Path p) = RD.createDirRecursive fm p
-- |Create a symlink.
@ -797,8 +614,7 @@ createDirRecursive fm p =
createSymlink :: Path b -- ^ destination file
-> ByteString -- ^ path the symlink points to
-> IO ()
createSymlink (Path destBS) sympoint
= createSymbolicLink sympoint destBS
createSymlink (Path destBS) sympoint = RD.createSymlink destBS sympoint
@ -829,11 +645,8 @@ createSymlink (Path destBS) sympoint
--
-- Note: calls `rename` (but does not allow to rename over existing files)
renameFile :: Path b1 -> Path b2 -> IO ()
renameFile fromf@(Path fromfBS) tof@(Path tofBS) = do
throwSameFile fromf tof
throwFileDoesExist tof
throwDirDoesExist tof
rename fromfBS tofBS
renameFile (Path from) (Path to) = RD.renameFile from to
-- |Move a file. This also works across devices by copy-delete fallback.
@ -872,30 +685,7 @@ moveFile :: Path b1 -- ^ file to move
-> Path b2 -- ^ destination
-> CopyMode
-> IO ()
moveFile from to cm = do
throwSameFile from to
case cm of
Strict -> catchErrno [eXDEV] (renameFile from to) $ do
easyCopy from to Strict FailEarly
easyDelete from
Overwrite -> do
ft <- getFileType from
writable <- toAbs to >>= (\p -> do
e <- doesFileExist p
if e then isWritable p else pure False)
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
moveFile (Path from) (Path to) cm = RD.moveFile from to cm
@ -922,9 +712,7 @@ moveFile from to cm = do
-- containting it
-- - `NoSuchThing` if the file does not exist
readFile :: Path b -> IO L.ByteString
readFile path = do
stream <- readFileStream path
toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream)
readFile (Path path) = RD.readFile path
@ -939,11 +727,7 @@ readFile path = do
-- - `NoSuchThing` if the file does not exist
readFileStream :: Path b
-> IO (SerialT IO ByteString)
readFileStream (Path fp) = do
fd <- openFd fp SPI.ReadOnly [] Nothing
handle <- SPI.fdToHandle fd
let stream = fmap fromArray (S.unfold (SU.finally SIO.hClose FH.readChunks) handle)
pure stream
readFileStream (Path fp) = RD.readFileStream fp
@ -966,8 +750,7 @@ writeFile :: Path b
-> Maybe FileMode -- ^ if Nothing, file must exist
-> ByteString
-> IO ()
writeFile (Path fp) fmode bs =
bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd) $ \fd -> void $ SPB.fdWrite fd bs
writeFile (Path fp) fmode bs = RD.writeFile fp fmode bs
-- |Write a given lazy ByteString to a file, truncating the file beforehand.
@ -985,11 +768,7 @@ writeFileL :: Path b
-> Maybe FileMode -- ^ if Nothing, file must exist
-> L.ByteString
-> IO ()
writeFileL (Path fp) fmode lbs = do
handle <- bracketOnError (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd) $ SPI.fdToHandle
finally (streamlyCopy handle) (SIO.hClose handle)
where
streamlyCopy tH = S.fold (FH.writeChunks tH) $ SL.toChunks lbs
writeFileL (Path fp) fmode lbs = RD.writeFileL fp fmode lbs
-- |Append a given ByteString to a file.
@ -1002,9 +781,7 @@ writeFileL (Path fp) fmode lbs = do
-- containting it
-- - `NoSuchThing` if the file does not exist
appendFile :: Path b -> ByteString -> IO ()
appendFile (Path fp) bs =
bracket (openFd fp SPI.WriteOnly [SPDF.oAppend] Nothing)
(SPI.closeFd) $ \fd -> void $ SPB.fdWrite fd bs
appendFile (Path fp) bs = RD.appendFile fp bs
@ -1047,11 +824,7 @@ newDirPerms
--
-- Only eNOENT is catched (and returns False).
doesExist :: Path b -> IO Bool
doesExist (Path bs) =
catchErrno [eNOENT] (do
_ <- PF.getSymbolicLinkStatus bs
return $ True)
$ return False
doesExist (Path bs) = RD.doesExist bs
-- |Checks if the given file exists and is not a directory.
@ -1059,11 +832,7 @@ doesExist (Path bs) =
--
-- Only eNOENT is catched (and returns False).
doesFileExist :: Path b -> IO Bool
doesFileExist (Path bs) =
catchErrno [eNOENT] (do
fs <- PF.getSymbolicLinkStatus bs
return $ not . PF.isDirectory $ fs)
$ return False
doesFileExist (Path bs) = RD.doesFileExist bs
-- |Checks if the given file exists and is a directory.
@ -1071,11 +840,7 @@ doesFileExist (Path bs) =
--
-- Only eNOENT is catched (and returns False).
doesDirectoryExist :: Path b -> IO Bool
doesDirectoryExist (Path bs) =
catchErrno [eNOENT] (do
fs <- PF.getSymbolicLinkStatus bs
return $ PF.isDirectory fs)
$ return False
doesDirectoryExist (Path bs) = RD.doesDirectoryExist bs
-- |Checks whether a file or folder is readable.
@ -1086,7 +851,7 @@ doesDirectoryExist (Path bs) =
--
-- - `NoSuchThing` if the file does not exist
isReadable :: Path b -> IO Bool
isReadable (Path bs) = fileAccess bs True False False
isReadable (Path bs) = RD.isReadable bs
-- |Checks whether a file or folder is writable.
--
@ -1096,7 +861,7 @@ isReadable (Path bs) = fileAccess bs True False False
--
-- - `NoSuchThing` if the file does not exist
isWritable :: Path b -> IO Bool
isWritable (Path bs) = fileAccess bs False True False
isWritable (Path bs) = RD.isWritable bs
-- |Checks whether a file or folder is executable.
@ -1107,19 +872,14 @@ isWritable (Path bs) = fileAccess bs False True False
--
-- - `NoSuchThing` if the file does not exist
isExecutable :: Path b -> IO Bool
isExecutable (Path bs) = fileAccess bs False False True
isExecutable (Path bs) = RD.isExecutable bs
-- |Checks whether the directory at the given path exists and can be
-- opened. This invokes `openDirStream` which follows symlinks.
canOpenDirectory :: Path b -> IO Bool
canOpenDirectory (Path bs) =
handleIOError (\_ -> return False) $ do
bracket (openDirStream bs)
closeDirStream
(\_ -> return ())
return True
canOpenDirectory (Path bs) = RD.canOpenDirectory bs
@ -1130,21 +890,13 @@ canOpenDirectory (Path bs) =
getModificationTime :: Path b -> IO UTCTime
getModificationTime (Path bs) = do
fs <- PF.getFileStatus bs
pure $ posixSecondsToUTCTime $ PF.modificationTimeHiRes fs
getModificationTime (Path bs) = RD.getModificationTime bs
setModificationTime :: Path b -> EpochTime -> IO ()
setModificationTime (Path bs) t = do
-- TODO: setFileTimes doesn't allow to pass NULL to utime
ctime <- epochTime
PF.setFileTimes bs ctime t
setModificationTime (Path bs) t = RD.setModificationTime bs t
setModificationTimeHiRes :: Path b -> POSIXTime -> IO ()
setModificationTimeHiRes (Path bs) t = do
-- TODO: setFileTimesHiRes doesn't allow to pass NULL to utimes
ctime <- getPOSIXTime
PF.setFileTimesHiRes bs ctime t
setModificationTimeHiRes (Path bs) t = RD.setModificationTimeHiRes bs t
@ -1177,13 +929,9 @@ getDirsFiles p@(Path fp) = do
-- of prepending the base path.
getDirsFiles' :: Path b -- ^ dir to read
-> IO [Path Rel]
getDirsFiles' p@(Path fp) = do
fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing
rawContents <- getDirectoryContents' fd
fmap catMaybes $ for rawContents $ \(_, f) ->
if FP.isSpecialDirectoryEntry f
then pure Nothing
else fmap Just $ parseRel f
getDirsFiles' (Path fp) = do
rawContents <- RD.getDirsFiles' fp
for rawContents $ \r -> parseRel r
@ -1201,19 +949,7 @@ getDirsFiles' p@(Path fp) = do
-- - `NoSuchThing` if the file does not exist
-- - `PermissionDenied` if any part of the path is not accessible
getFileType :: Path b -> IO FileType
getFileType (Path fp) = do
fs <- PF.getSymbolicLinkStatus fp
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?!"
getFileType (Path fp) = RD.getFileType fp
@ -1232,7 +968,7 @@ getFileType (Path fp) = do
-- - `PathParseException` if realpath does not return an absolute path
canonicalizePath :: Path b -> IO (Path Abs)
canonicalizePath (Path l) = do
nl <- SPDT.realpath l
nl <- RD.canonicalizePath l
parseAbs nl

View File

@ -1,16 +0,0 @@
module HPath.IO where
import HPath
canonicalizePath :: Path b -> IO (Path Abs)
toAbs :: Path b -> IO (Path Abs)
doesFileExist :: Path b -> IO Bool
doesDirectoryExist :: Path b -> IO Bool
isWritable :: Path b -> IO Bool
canOpenDirectory :: Path b -> IO Bool

View File

@ -1,324 +0,0 @@
-- |
-- Module : HPath.IO.Errors
-- Copyright : © 2016 Julian Ospald
-- License : BSD3
--
-- Maintainer : Julian Ospald <hasufell@posteo.de>
-- Stability : experimental
-- Portability : portable
--
-- Provides error handling.
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
module HPath.IO.Errors
(
-- * Types
HPathIOException(..)
, RecursiveFailureHint(..)
-- * Exception identifiers
, isSameFile
, isDestinationInSource
, isRecursiveFailure
, isReadContentsFailed
, isCreateDirFailed
, isCopyFileFailed
, isRecreateSymlinkFailed
-- * Path based functions
, throwFileDoesExist
, throwDirDoesExist
, throwSameFile
, sameFile
, throwDestinationInSource
-- * Error handling functions
, catchErrno
, rethrowErrnoAs
, handleIOError
, hideError
, bracketeer
, reactOnError
)
where
import Control.Applicative
(
(<$>)
)
import Control.Exception.Safe hiding (handleIOError)
import Control.Monad
(
forM
, when
)
import Control.Monad.IfElse
(
whenM
)
import Data.ByteString
(
ByteString
)
import Data.ByteString.UTF8
(
toString
)
import Data.Typeable
(
Typeable
)
import Foreign.C.Error
(
getErrno
, Errno
)
import GHC.IO.Exception
(
IOErrorType
)
import HPath
import {-# SOURCE #-} HPath.IO
(
canonicalizePath
, toAbs
, doesFileExist
, doesDirectoryExist
, isWritable
, canOpenDirectory
)
import System.IO.Error
(
alreadyExistsErrorType
, ioeGetErrorType
, mkIOError
)
import qualified System.Posix.Directory.ByteString as PFD
import System.Posix.Files.ByteString
(
fileAccess
, getFileStatus
)
import qualified System.Posix.Files.ByteString as PF
-- |Additional generic IO exceptions that the posix functions
-- do not provide.
data HPathIOException = SameFile ByteString ByteString
| DestinationInSource ByteString ByteString
| RecursiveFailure [(RecursiveFailureHint, IOException)]
deriving (Eq, Show, Typeable)
-- |A type for giving failure hints on recursive failure, which allows
-- to programmatically make choices without examining
-- the weakly typed I/O error attributes (like `ioeGetFileName`).
--
-- The first argument to the data constructor is always the
-- source and the second the destination.
data RecursiveFailureHint = ReadContentsFailed ByteString ByteString
| CreateDirFailed ByteString ByteString
| CopyFileFailed ByteString ByteString
| RecreateSymlinkFailed ByteString ByteString
deriving (Eq, Show)
instance Exception HPathIOException
toConstr :: HPathIOException -> String
toConstr SameFile {} = "SameFile"
toConstr DestinationInSource {} = "DestinationInSource"
toConstr RecursiveFailure {} = "RecursiveFailure"
-----------------------------
--[ Exception identifiers ]--
-----------------------------
isSameFile, isDestinationInSource, isRecursiveFailure :: HPathIOException -> Bool
isSameFile ex = toConstr (ex :: HPathIOException) == toConstr (SameFile mempty mempty)
isDestinationInSource ex = toConstr (ex :: HPathIOException) == (toConstr $ DestinationInSource mempty mempty)
isRecursiveFailure ex = toConstr (ex :: HPathIOException) == (toConstr $ RecursiveFailure mempty)
isReadContentsFailed, isCreateDirFailed, isCopyFileFailed, isRecreateSymlinkFailed ::RecursiveFailureHint -> Bool
isReadContentsFailed ReadContentsFailed{} = True
isReadContentsFailed _ = False
isCreateDirFailed CreateDirFailed{} = True
isCreateDirFailed _ = False
isCopyFileFailed CopyFileFailed{} = True
isCopyFileFailed _ = False
isRecreateSymlinkFailed RecreateSymlinkFailed{} = True
isRecreateSymlinkFailed _ = False
----------------------------
--[ Path based functions ]--
----------------------------
-- |Throws `AlreadyExists` `IOError` if file exists.
throwFileDoesExist :: Path b -> IO ()
throwFileDoesExist fp@(Path bs) =
whenM (doesFileExist fp)
(ioError . mkIOError
alreadyExistsErrorType
"File already exists"
Nothing
$ (Just (toString $ bs))
)
-- |Throws `AlreadyExists` `IOError` if directory exists.
throwDirDoesExist :: Path b -> IO ()
throwDirDoesExist fp@(Path bs) =
whenM (doesDirectoryExist fp)
(ioError . mkIOError
alreadyExistsErrorType
"Directory already exists"
Nothing
$ (Just (toString $ bs))
)
-- |Uses `isSameFile` and throws `SameFile` if it returns True.
throwSameFile :: Path b1
-> Path b2
-> IO ()
throwSameFile fp1@(Path bs1) fp2@(Path bs2) =
whenM (sameFile fp1 fp2)
(throwIO $ SameFile bs1 bs2)
-- |Check if the files are the same by examining device and file id.
-- This follows symbolic links.
sameFile :: Path b1 -> Path b2 -> IO Bool
sameFile (Path fp1) (Path 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
-- TODO: make this more robust when destination does not exist
-- |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 b1 -- ^ source dir
-> Path b2 -- ^ full destination, @dirname dest@
-- must exist
-> IO ()
throwDestinationInSource (Path sbs) dest@(Path dbs) = do
destAbs <- toAbs dest
dest' <- (\x -> maybe x (\y -> x </> y) $ basename dest)
<$> (canonicalizePath $ dirname destAbs)
dids <- forM (getAllParents dest') $ \p -> do
fs <- PF.getSymbolicLinkStatus (fromAbs p)
return (PF.deviceID fs, PF.fileID fs)
sid <- fmap (\x -> (PF.deviceID x, PF.fileID x))
$ PF.getFileStatus sbs
when (elem sid dids)
(throwIO $ DestinationInSource dbs sbs)
--------------------------------
--[ 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
hideError :: IOErrorType -> IO () -> IO ()
hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else ioError e)
-- |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
-> [(HPathIOException, IO a)] -- ^ reaction on HPathIOException
-> 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 :: HPathIOException) ->
foldr (\(t, a') y -> if toConstr ex == toConstr t
then a'
else y)
(throwIO ex)
fmios

View File

@ -1,55 +0,0 @@
module System.Posix.Directory.Foreign where
import Data.Bits
import Data.List (foldl')
import Foreign.C.Types
#include <limits.h>
#include <stdlib.h>
#include <dirent.h>
#include <sys/types.h>
#include <sys/stat.h>
#include <fcntl.h>
newtype DirType = DirType Int deriving (Eq, Show)
data Flags = Flags Int | UnsupportedFlag String deriving (Eq, Show)
unFlags :: Flags -> Int
unFlags (Flags i) = i
unFlags (UnsupportedFlag name) = error (name ++ " is not supported on this platform")
-- |Returns @True@ if posix-paths was compiled with support for the provided
-- flag. (As of this writing, the only flag for which this check may be
-- necessary is 'oCloexec'; all other flags will always yield @True@.)
isSupported :: Flags -> Bool
isSupported (Flags _) = True
isSupported _ = False
-- |@O_CLOEXEC@ is not supported on every POSIX platform. Use
-- @'isSupported' oCloexec@ to determine if support for @O_CLOEXEC@ was
-- compiled into your version of posix-paths. (If not, using @oCloexec@ will
-- throw an exception.)
oCloexec :: Flags
#ifdef O_CLOEXEC
oCloexec = Flags #{const O_CLOEXEC}
#else
{-# WARNING oCloexec
"This version of posix-paths was compiled without @O_CLOEXEC@ support." #-}
oCloexec = UnsupportedFlag "O_CLOEXEC"
#endif
-- If these enum declarations occur earlier in the file, haddock
-- gets royally confused about the above doc comments.
-- Probably http://trac.haskell.org/haddock/ticket/138
#{enum DirType, DirType, DT_BLK, DT_CHR, DT_DIR, DT_FIFO, DT_LNK, DT_REG, DT_SOCK, DT_UNKNOWN}
#{enum Flags, Flags, O_APPEND, O_ASYNC, O_CREAT, O_DIRECTORY, O_EXCL, O_NOCTTY, O_NOFOLLOW, O_NONBLOCK, O_RDONLY, O_WRONLY, O_RDWR, O_SYNC, O_TRUNC}
pathMax :: Int
pathMax = #{const PATH_MAX}
unionFlags :: [Flags] -> CInt
unionFlags = fromIntegral . foldl' ((. unFlags) . (.|.)) 0

View File

@ -1,264 +0,0 @@
-- |
-- Module : System.Posix.Directory.Traversals
-- Copyright : © 2016 Julian Ospald
-- License : BSD3
--
-- Maintainer : Julian Ospald <hasufell@posteo.de>
-- Stability : experimental
-- Portability : portable
--
-- Traversal and read operations on directories.
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wall #-}
module System.Posix.Directory.Traversals (
getDirectoryContents
, getDirectoryContents'
, allDirectoryContents
, allDirectoryContents'
, traverseDirectory
-- lower-level stuff
, readDirEnt
, packDirStream
, unpackDirStream
, fdOpendir
, realpath
) where
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative ((<$>))
#endif
import Control.Monad
import System.Posix.FilePath ((</>))
import System.Posix.Directory.Foreign
import qualified System.Posix as Posix
import System.IO.Error
import Control.Exception
import qualified Data.ByteString.Char8 as BS
import System.Posix.ByteString.FilePath
import System.Posix.Directory.ByteString as PosixBS
import System.Posix.Files.ByteString
import System.IO.Unsafe
import "unix" System.Posix.IO.ByteString (closeFd)
import Unsafe.Coerce (unsafeCoerce)
import Foreign.C.Error
import Foreign.C.String
import Foreign.C.Types
import Foreign.Marshal.Alloc (alloca,allocaBytes)
import Foreign.Ptr
import Foreign.Storable
----------------------------------------------------------
-- | Get all files from a directory and its subdirectories.
--
-- Upon entering a directory, 'allDirectoryContents' will get all entries
-- strictly. However the returned list is lazy in that directories will only
-- be accessed on demand.
--
-- Follows symbolic links for the input dir.
allDirectoryContents :: RawFilePath -> IO [RawFilePath]
allDirectoryContents topdir = do
namesAndTypes <- getDirectoryContents topdir
let properNames = filter ((`notElem` [".", ".."]) . snd) namesAndTypes
paths <- forM properNames $ \(typ,name) -> unsafeInterleaveIO $ do
let path = topdir </> name
case () of
() | typ == dtDir -> allDirectoryContents path
| typ == dtUnknown -> do
isDir <- isDirectory <$> getFileStatus path
if isDir
then allDirectoryContents path
else return [path]
| otherwise -> return [path]
return (topdir : concat paths)
-- | Get all files from a directory and its subdirectories strictly.
--
-- Follows symbolic links for the input dir.
allDirectoryContents' :: RawFilePath -> IO [RawFilePath]
allDirectoryContents' = fmap reverse . traverseDirectory (\acc fp -> return (fp:acc)) []
-- this uses traverseDirectory because it's more efficient than forcing the
-- lazy version.
-- | Recursively apply the 'action' to the parent directory and all
-- files/subdirectories.
--
-- This function allows for memory-efficient traversals.
--
-- Follows symbolic links for the input dir.
traverseDirectory :: (s -> RawFilePath -> IO s) -> s -> RawFilePath -> IO s
traverseDirectory act s0 topdir = toploop
where
toploop = do
isDir <- isDirectory <$> getFileStatus topdir
s' <- act s0 topdir
if isDir then actOnDirContents topdir s' loop
else return s'
loop typ path acc = do
isDir <- case () of
() | typ == dtDir -> return True
| typ == dtUnknown -> isDirectory <$> getFileStatus path
| otherwise -> return False
if isDir
then act acc path >>= \acc' -> actOnDirContents path acc' loop
else act acc path
actOnDirContents :: RawFilePath
-> b
-> (DirType -> RawFilePath -> b -> IO b)
-> IO b
actOnDirContents pathRelToTop b f =
modifyIOError ((`ioeSetFileName` (BS.unpack pathRelToTop)) .
(`ioeSetLocation` "findBSTypRel")) $
bracket
(openDirStream pathRelToTop)
Posix.closeDirStream
(\dirp -> loop dirp b)
where
loop dirp b' = do
(typ,e) <- readDirEnt dirp
if (e == "")
then return b'
else
if (e == "." || e == "..")
then loop dirp b'
else f typ (pathRelToTop </> e) b' >>= loop dirp
----------------------------------------------------------
-- dodgy stuff
type CDir = ()
type CDirent = ()
-- Posix doesn't export DirStream, so to re-use that type we need to use
-- unsafeCoerce. It's just a newtype, so this is a legitimate usage.
-- ugly trick.
unpackDirStream :: DirStream -> Ptr CDir
unpackDirStream = unsafeCoerce
packDirStream :: Ptr CDir -> DirStream
packDirStream = unsafeCoerce
-- the __hscore_* functions are defined in the unix package. We can import them and let
-- the linker figure it out.
foreign import ccall unsafe "__hscore_readdir"
c_readdir :: Ptr CDir -> Ptr (Ptr CDirent) -> IO CInt
foreign import ccall unsafe "__hscore_free_dirent"
c_freeDirEnt :: Ptr CDirent -> IO ()
foreign import ccall unsafe "__hscore_d_name"
c_name :: Ptr CDirent -> IO CString
foreign import ccall unsafe "__posixdir_d_type"
c_type :: Ptr CDirent -> IO DirType
foreign import ccall "realpath"
c_realpath :: CString -> CString -> IO CString
foreign import ccall unsafe "fdopendir"
c_fdopendir :: Posix.Fd -> IO (Ptr ())
----------------------------------------------------------
-- less dodgy but still lower-level
readDirEnt :: DirStream -> IO (DirType, RawFilePath)
readDirEnt (unpackDirStream -> dirp) =
alloca $ \ptr_dEnt -> loop ptr_dEnt
where
loop ptr_dEnt = do
resetErrno
r <- c_readdir dirp ptr_dEnt
if (r == 0)
then do
dEnt <- peek ptr_dEnt
if (dEnt == nullPtr)
then return (dtUnknown,BS.empty)
else do
dName <- c_name dEnt >>= peekFilePath
dType <- c_type dEnt
c_freeDirEnt dEnt
return (dType, dName)
else do
errno <- getErrno
if (errno == eINTR)
then loop ptr_dEnt
else do
let (Errno eo) = errno
if (eo == 0)
then return (dtUnknown,BS.empty)
else throwErrno "readDirEnt"
-- |Gets all directory contents (not recursively).
getDirectoryContents :: RawFilePath -> IO [(DirType, RawFilePath)]
getDirectoryContents path =
modifyIOError ((`ioeSetFileName` (BS.unpack path)) .
(`ioeSetLocation` "System.Posix.Directory.Traversals.getDirectoryContents")) $
bracket
(PosixBS.openDirStream path)
PosixBS.closeDirStream
_dirloop
-- |Binding to @fdopendir(3)@.
fdOpendir :: Posix.Fd -> IO DirStream
fdOpendir fd =
packDirStream <$> throwErrnoIfNull "fdOpendir" (c_fdopendir fd)
-- |Like `getDirectoryContents` except for a file descriptor.
--
-- To avoid complicated error checks, the file descriptor is
-- __always__ closed, even if `fdOpendir` fails. Usually, this
-- only happens on successful `fdOpendir` and after the directory
-- stream is closed. Also see the manpage of @fdopendir(3)@ for
-- more details.
getDirectoryContents' :: Posix.Fd -> IO [(DirType, RawFilePath)]
getDirectoryContents' fd = do
dirstream <- fdOpendir fd `catchIOError` \e -> do
closeFd fd
ioError e
-- closeDirStream closes the filedescriptor
finally (_dirloop dirstream) (PosixBS.closeDirStream dirstream)
_dirloop :: DirStream -> IO [(DirType, RawFilePath)]
{-# INLINE _dirloop #-}
_dirloop dirp = do
t@(_typ,e) <- readDirEnt dirp
if BS.null e then return [] else do
es <- _dirloop dirp
return (t:es)
-- | return the canonicalized absolute pathname
--
-- like canonicalizePath, but uses @realpath(3)@
realpath :: RawFilePath -> IO RawFilePath
realpath inp =
allocaBytes pathMax $ \tmp -> do
void $ BS.useAsCString inp $ \cstr -> throwErrnoIfNull "realpath" $ c_realpath cstr tmp
BS.packCString tmp

View File

@ -1,75 +0,0 @@
-- |
-- Module : System.Posix.FD
-- Copyright : © 2016 Julian Ospald
-- License : BSD3
--
-- Maintainer : Julian Ospald <hasufell@posteo.de>
-- Stability : experimental
-- Portability : portable
--
-- Provides an alternative for `System.Posix.IO.ByteString.openFd`
-- which gives us more control on what status flags to pass to the
-- low-level @open(2)@ call, in contrast to the unix package.
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# OPTIONS_GHC -Wall #-}
module System.Posix.FD (
openFd
) where
import Foreign.C.String
import Foreign.C.Types
import System.Posix.Directory.Foreign
import qualified System.Posix as Posix
import System.Posix.ByteString.FilePath
foreign import ccall unsafe "open"
c_open :: CString -> CInt -> Posix.CMode -> IO CInt
open_ :: CString
-> Posix.OpenMode
-> [Flags]
-> Maybe Posix.FileMode
-> IO Posix.Fd
open_ str how optional_flags maybe_mode = do
fd <- c_open str all_flags mode_w
return (Posix.Fd fd)
where
all_flags = unionFlags $ optional_flags ++ [open_mode] ++ creat
(creat, mode_w) = case maybe_mode of