hasufell/hpath
1
1
Fork 0
Code Issues 8 Pull Requests Releases Wiki Activity

Clean up

Browse Source
This commit is contained in:
Julian Ospald 2020-01-26 22:40:03 +01:00
parent 768443df27
commit ecb52f5217
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
3 changed files with 381 additions and 588 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

686
hpath-directory/src/System/Posix/RawFilePath/Directory.hs
View File

@ -28,8 +28,6 @@
-- > import System.Posix.RawFilePath.Directory -- > import System.Posix.RawFilePath.Directory
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module System.Posix.RawFilePath.Directory module System.Posix.RawFilePath.Directory
( (
@ -90,180 +88,135 @@ module System.Posix.RawFilePath.Directory
, canonicalizePath , canonicalizePath
, toAbs , toAbs
) )
where where
import Control.Applicative import Control.Applicative ( (<$>) )
( import Control.Exception.Safe ( IOException
(<$>) , bracket
) , bracketOnError
import Control.Exception.Safe , throwIO
( , finally
IOException )
, bracket import Control.Monad ( unless
, bracketOnError , void
, throwIO , when
, finally )
) import Control.Monad.Catch ( MonadThrow(..) )
import Control.Monad import Control.Monad.Fail ( MonadFail )
( import Control.Monad.IfElse ( unlessM )
unless import qualified Data.ByteString as BS
, void import Data.ByteString ( ByteString )
, when
)
import Control.Monad.Catch (MonadThrow(..))
import Control.Monad.Fail (MonadFail)
import Control.Monad.IfElse
(
unlessM
)
import qualified Data.ByteString as BS
import Data.ByteString
(
ByteString
)
import Data.Traversable ( for ) import Data.Traversable ( for )
import Data.Functor ( ($>) ) import Data.Functor ( ($>) )
#if MIN_VERSION_bytestring(0,10,2) #if MIN_VERSION_bytestring(0,10,2)
import Data.ByteString.Builder import Data.ByteString.Builder
#else #else
import Data.ByteString.Lazy.Builder import Data.ByteString.Lazy.Builder
#endif #endif
( ( Builder
Builder , byteString
, byteString , toLazyByteString
, toLazyByteString )
) import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy as L import Data.ByteString.Unsafe ( unsafePackCStringFinalizer )
import Data.ByteString.Unsafe import qualified Data.ByteString.UTF8 as UTF8
( import Data.Foldable ( for_ )
unsafePackCStringFinalizer import Data.IORef ( IORef
) , modifyIORef
import Data.Foldable , newIORef
( , readIORef
for_ )
) import Data.Maybe ( catMaybes )
import Data.IORef import Data.Monoid ( (<>)
( , mempty
IORef )
, modifyIORef import Data.Time.Clock
, newIORef import Data.Time.Clock.POSIX ( getPOSIXTime
, readIORef , posixSecondsToUTCTime
) , POSIXTime
import Data.Maybe )
( import Data.Word ( Word8 )
catMaybes import Foreign.C.Error ( eEXIST
) , eNOENT
import Data.Monoid , eNOTEMPTY
( , eXDEV
(<>) , getErrno
, mempty )
) import Foreign.C.Types ( CSize )
import Data.Time.Clock import Foreign.Marshal.Alloc ( allocaBytes )
import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime) import Foreign.Ptr ( Ptr )
import Data.Word import GHC.IO.Exception ( IOErrorType(..) )
( import Prelude hiding ( appendFile
Word8 , readFile
) , writeFile
import Foreign.C.Error )
( import Streamly
eEXIST import Streamly.External.ByteString
, eNOENT import qualified Streamly.External.ByteString.Lazy
, eNOTEMPTY as SL
, eXDEV import qualified Streamly.Data.Fold as FL
, getErrno import Streamly.Memory.Array
) import qualified Streamly.FileSystem.Handle as FH
import Foreign.C.Types
(
CSize
)
import Foreign.Marshal.Alloc
(
allocaBytes
)
import Foreign.Ptr
(
Ptr
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import Prelude hiding (appendFile, readFile, writeFile)
import Streamly
import Streamly.External.ByteString
import qualified Streamly.External.ByteString.Lazy as SL
import qualified Streamly.Data.Fold as FL
import Streamly.Memory.Array
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Internal.FileSystem.Handle as IFH import qualified Streamly.Internal.FileSystem.Handle
import qualified Streamly.Internal.Memory.ArrayStream as AS as IFH
import qualified Streamly.Prelude as S import qualified Streamly.Internal.Memory.ArrayStream
import qualified System.IO as SIO as AS
import System.IO.Error import qualified Streamly.Prelude as S
( import qualified System.IO as SIO
catchIOError import System.IO.Error ( catchIOError
, ioeGetErrorType , ioeGetErrorType
) )
import System.Posix.FilePath import System.Posix.FilePath
import System.Posix.ByteString import System.Posix.ByteString ( exclusive )
( import System.Posix.RawFilePath.Directory.Errors
exclusive import System.Posix.Directory.ByteString
) ( createDirectory
import System.Posix.RawFilePath.Directory.Errors , closeDirStream
import System.Posix.Directory.ByteString , getWorkingDirectory
( , openDirStream
createDirectory , removeDirectory
, closeDirStream )
, getWorkingDirectory import System.Posix.RawFilePath.Directory.Traversals
, openDirStream ( getDirectoryContents' )
, removeDirectory import System.Posix.Files.ByteString ( createSymbolicLink
) , fileAccess
import System.Posix.RawFilePath.Directory.Traversals , fileMode
( , getFdStatus
getDirectoryContents' , groupExecuteMode
) , groupReadMode
import System.Posix.Files.ByteString , groupWriteMode
( , otherExecuteMode
createSymbolicLink , otherReadMode
, fileAccess , otherWriteMode
, fileMode , ownerModes
, getFdStatus , ownerReadMode
, groupExecuteMode , ownerWriteMode
, groupReadMode , readSymbolicLink
, groupWriteMode , removeLink
, otherExecuteMode , rename
, otherReadMode , setFileMode
, otherWriteMode , unionFileModes
, ownerModes )
, ownerReadMode import qualified System.Posix.FilePath as FP
, ownerWriteMode
, readSymbolicLink
, removeLink
, rename
, setFileMode
, unionFileModes
)
import qualified System.Posix.FilePath as FP
import qualified System.Posix.Files.ByteString as PF import qualified System.Posix.Files.ByteString as PF
import qualified "unix" System.Posix.IO.ByteString as SPI import qualified "unix" System.Posix.IO.ByteString
import qualified "unix-bytestring" System.Posix.IO.ByteString as SPB as SPI
import System.Posix.FD import qualified "unix-bytestring" System.Posix.IO.ByteString
( as SPB
openFd import System.Posix.FD ( openFd )
) import qualified System.Posix.RawFilePath.Directory.Traversals
import qualified System.Posix.RawFilePath.Directory.Traversals as SPDT as SPDT
import qualified System.Posix.Foreign as SPDF import qualified System.Posix.Foreign as SPDF
import qualified System.Posix.Process.ByteString as SPP import qualified System.Posix.Process.ByteString
import System.Posix.Types as SPP
( import System.Posix.Types ( FileMode
FileMode , ProcessID
, ProcessID , Fd
, Fd , EpochTime
, EpochTime )
) import System.Posix.Time
import System.Posix.Time
@ -372,72 +325,74 @@ copyDirRecursive :: RawFilePath -- ^ source dir
-> CopyMode -> CopyMode
-> RecursiveErrorMode -> RecursiveErrorMode
-> IO () -> IO ()
copyDirRecursive fromp destdirp cm rm copyDirRecursive fromp destdirp cm rm = do
= do ce <- newIORef []
ce <- newIORef [] -- for performance, sanity checks are only done for the top dir
-- for performance, sanity checks are only done for the top dir throwSameFile fromp destdirp
throwSameFile fromp destdirp throwDestinationInSource fromp destdirp
throwDestinationInSource fromp destdirp go ce fromp destdirp
go ce fromp destdirp collectedExceptions <- readIORef ce
collectedExceptions <- readIORef ce unless (null collectedExceptions)
unless (null collectedExceptions) (throwIO . RecursiveFailure $ collectedExceptions)
(throwIO . RecursiveFailure $ collectedExceptions) where
where basename :: MonadFail m => RawFilePath -> m RawFilePath
basename :: MonadFail m => RawFilePath -> m RawFilePath basename x =
basename x = let b = takeBaseName x let b = takeBaseName x
in if BS.null b then fail ("No base name" :: String) else pure b in if BS.null b then fail ("No base name" :: String) else pure b
go :: IORef [(RecursiveFailureHint, IOException)] go :: IORef [(RecursiveFailureHint, IOException)]
-> RawFilePath -> RawFilePath -> IO () -> RawFilePath
go ce from destdir = do -> RawFilePath
-> IO ()
go ce from destdir = do
-- NOTE: order is important here, so we don't get empty directories -- NOTE: order is important here, so we don't get empty directories
-- on failure -- on failure
-- get the contents of the source dir -- get the contents of the source dir
contents <- handleIOE (ReadContentsFailed from destdir) ce [] $ do contents <- handleIOE (ReadContentsFailed from destdir) ce [] $ do
contents <- getDirsFiles from contents <- getDirsFiles from
-- create the destination dir and -- create the destination dir and
-- only return contents if we succeed -- only return contents if we succeed
handleIOE (CreateDirFailed from destdir) ce [] $ do handleIOE (CreateDirFailed from destdir) ce [] $ do
fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus from fmode' <- PF.fileMode <$> PF.getSymbolicLinkStatus from
case cm of case cm of
Strict -> createDirectory destdir fmode' Strict -> createDirectory destdir fmode'
Overwrite -> catchIOError (createDirectory destdir Overwrite -> catchIOError (createDirectory destdir fmode') $ \e ->
fmode') case ioeGetErrorType e of
$ \e -> AlreadyExists -> setFileMode destdir fmode'
case ioeGetErrorType e of _ -> ioError e
AlreadyExists -> setFileMode destdir return contents
fmode'
_ -> ioError e
return contents
-- NOTE: we can't use `easyCopy` here, because we want to call `go` -- NOTE: we can't use `easyCopy` here, because we want to call `go`
-- recursively to skip the top-level sanity checks -- recursively to skip the top-level sanity checks
-- if reading the contents and creating the destination dir worked, -- if reading the contents and creating the destination dir worked,
-- then copy the contents to the destination too -- then copy the contents to the destination too
for_ contents $ \f -> do for_ contents $ \f -> do
ftype <- getFileType f ftype <- getFileType f
newdest <- (destdir </>) <$> basename f newdest <- (destdir </>) <$> basename f
case ftype of case ftype of
SymbolicLink -> handleIOE (RecreateSymlinkFailed f newdest) ce () SymbolicLink ->
$ recreateSymlink f newdest cm handleIOE (RecreateSymlinkFailed f newdest) ce ()
Directory -> go ce f newdest $ recreateSymlink f newdest cm
RegularFile -> handleIOE (CopyFileFailed f newdest) ce () Directory -> go ce f newdest
$ copyFile f newdest cm RegularFile ->
_ -> return () handleIOE (CopyFileFailed f newdest) ce () $ copyFile f newdest cm
_ -> return ()
-- helper to handle errors for both RecursiveErrorModes and return a -- helper to handle errors for both RecursiveErrorModes and return a
-- default value -- default value
handleIOE :: RecursiveFailureHint handleIOE :: RecursiveFailureHint
-> IORef [(RecursiveFailureHint, IOException)] -> IORef [(RecursiveFailureHint, IOException)]
-> a -> IO a -> IO a -> a
handleIOE hint ce def = case rm of -> IO a
FailEarly -> handleIOError throwIO -> IO a
CollectFailures -> handleIOError (\e -> modifyIORef ce ((hint, e):) handleIOE hint ce def = case rm of
>> return def) FailEarly -> handleIOError throwIO
CollectFailures ->
handleIOError (\e -> modifyIORef ce ((hint, e) :) >> return def)
-- |Recreate a symlink. -- |Recreate a symlink.
@ -473,21 +428,20 @@ recreateSymlink :: RawFilePath -- ^ the old symlink file
-> RawFilePath -- ^ destination file -> RawFilePath -- ^ destination file
-> CopyMode -> CopyMode
-> IO () -> IO ()
recreateSymlink symsource newsym cm recreateSymlink symsource newsym cm = do
= do throwSameFile symsource newsym
throwSameFile symsource newsym sympoint <- readSymbolicLink symsource
sympoint <- readSymbolicLink symsource case cm of
case cm of Strict -> return ()
Strict -> return () Overwrite -> do
Overwrite -> do writable <- do
writable <- do e <- doesExist newsym
e <- doesExist newsym if e then isWritable newsym else pure False
if e then isWritable newsym else pure False isfile <- doesFileExist newsym
isfile <- doesFileExist newsym isdir <- doesDirectoryExist newsym
isdir <- doesDirectoryExist newsym when (writable && isfile) (deleteFile newsym)
when (writable && isfile) (deleteFile newsym) when (writable && isdir) (deleteDir newsym)
when (writable && isdir) (deleteDir newsym) createSymbolicLink sympoint newsym
createSymbolicLink sympoint newsym
-- |Copies the given regular file to the given destination. -- |Copies the given regular file to the given destination.
@ -534,34 +488,44 @@ copyFile :: RawFilePath -- ^ source file
-> IO () -> IO ()
copyFile from to cm = do copyFile from to cm = do
throwSameFile from to throwSameFile from to
bracket (do bracket
fd <- openFd from SPI.ReadOnly [SPDF.oNofollow] Nothing (do
handle <- SPI.fdToHandle fd fd <- openFd from SPI.ReadOnly [SPDF.oNofollow] Nothing
pure (fd, handle)) handle <- SPI.fdToHandle fd
(\(_, handle) -> SIO.hClose handle) pure (fd, handle)
)
(\(_, handle) -> SIO.hClose handle)
$ \(fromFd, fH) -> do $ \(fromFd, fH) -> do
sourceFileMode <- System.Posix.Files.ByteString.fileMode <$> getFdStatus fromFd sourceFileMode <- System.Posix.Files.ByteString.fileMode
let dflags = [SPDF.oNofollow, case cm of <$> getFdStatus fromFd
Strict -> SPDF.oExcl let dflags =
Overwrite -> SPDF.oTrunc] [ SPDF.oNofollow
bracketeer (do , case cm of
fd <- openFd to SPI.WriteOnly dflags $ Just sourceFileMode Strict -> SPDF.oExcl
handle <- SPI.fdToHandle fd Overwrite -> SPDF.oTrunc
pure (fd, handle)) ]
(\(_, handle) -> SIO.hClose handle) bracketeer
(\(_, handle) -> do (do
SIO.hClose handle fd <- openFd to SPI.WriteOnly dflags $ Just sourceFileMode
case cm of handle <- SPI.fdToHandle fd
-- if we created the file and copying failed, it's pure (fd, handle)
-- safe to clean up )
Strict -> deleteFile to (\(_, handle) -> SIO.hClose handle)
Overwrite -> pure ()) (\(_, handle) -> do
$ \(_, tH) -> do SIO.hClose handle
SIO.hSetBinaryMode fH True case cm of
SIO.hSetBinaryMode tH True -- if we created the file and copying failed, it's
streamlyCopy (fH, tH) -- safe to clean up
where Strict -> deleteFile to
streamlyCopy (fH, tH) = S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256*1024) fH 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
-- |Copies a regular file, directory or symbolic link. In case of a -- |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. -- symbolic link it is just recreated, even if it points to a directory.
@ -581,10 +545,10 @@ easyCopy :: RawFilePath
easyCopy from to cm rm = do easyCopy from to cm rm = do
ftype <- getFileType from ftype <- getFileType from
case ftype of case ftype of
SymbolicLink -> recreateSymlink from to cm SymbolicLink -> recreateSymlink from to cm
RegularFile -> copyFile from to cm RegularFile -> copyFile from to cm
Directory -> copyDirRecursive from to cm rm Directory -> copyDirRecursive from to cm rm
_ -> return () _ -> return ()
@ -644,19 +608,16 @@ deleteDir = removeDirectory
-- - `NoSuchThing` if directory does not exist -- - `NoSuchThing` if directory does not exist
-- - `PermissionDenied` if we can't open or write to parent directory -- - `PermissionDenied` if we can't open or write to parent directory
deleteDirRecursive :: RawFilePath -> IO () deleteDirRecursive :: RawFilePath -> IO ()
deleteDirRecursive p = deleteDirRecursive p = catchErrno [eNOTEMPTY, eEXIST] (deleteDir p) $ do
catchErrno [eNOTEMPTY, eEXIST] files <- getDirsFiles p
(deleteDir p) for_ files $ \file -> do
$ do ftype <- getFileType file
files <- getDirsFiles p case ftype of
for_ files $ \file -> do SymbolicLink -> deleteFile file
ftype <- getFileType file Directory -> deleteDirRecursive file
case ftype of RegularFile -> deleteFile file
SymbolicLink -> deleteFile file _ -> return ()
Directory -> deleteDirRecursive file removeDirectory p
RegularFile -> deleteFile file
_ -> return ()
removeDirectory p
-- |Deletes a file, directory or symlink. -- |Deletes a file, directory or symlink.
@ -687,18 +648,16 @@ easyDelete p = do
-- |Opens a file appropriately by invoking xdg-open. The file type -- |Opens a file appropriately by invoking xdg-open. The file type
-- is not checked. This forks a process. -- is not checked. This forks a process.
openFile :: RawFilePath openFile :: RawFilePath -> IO ProcessID
-> IO ProcessID openFile fp = SPP.forkProcess
openFile fp = $ SPP.executeFile (UTF8.fromString "xdg-open") True [fp] Nothing
SPP.forkProcess $ SPP.executeFile "xdg-open" True [fp] Nothing
-- |Executes a program with the given arguments. This forks a process. -- |Executes a program with the given arguments. This forks a process.
executeFile :: RawFilePath -- ^ program executeFile :: RawFilePath -- ^ program
-> [ByteString] -- ^ arguments -> [ByteString] -- ^ arguments
-> IO ProcessID -> IO ProcessID
executeFile fp args = executeFile fp args = SPP.forkProcess $ SPP.executeFile fp True args Nothing
SPP.forkProcess $ SPP.executeFile fp True args Nothing
@ -718,11 +677,14 @@ executeFile fp args =
-- - `NoSuchThing` if any of the parent components of the path -- - `NoSuchThing` if any of the parent components of the path
-- do not exist -- do not exist
createRegularFile :: FileMode -> RawFilePath -> IO () createRegularFile :: FileMode -> RawFilePath -> IO ()
createRegularFile fm destBS = createRegularFile fm destBS = bracket
bracket (SPI.openFd destBS SPI.WriteOnly (Just fm) (SPI.openFd destBS
(SPI.defaultFileFlags { exclusive = True })) SPI.WriteOnly
SPI.closeFd (Just fm)
(\_ -> return ()) (SPI.defaultFileFlags { exclusive = True })
)
SPI.closeFd
(\_ -> return ())
-- |Create an empty directory at the given directory with the given filename. -- |Create an empty directory at the given directory with the given filename.
@ -769,18 +731,21 @@ createDirIfMissing fm destBS =
-- --
-- Note: calls `getcwd` if the input path is a relative path -- Note: calls `getcwd` if the input path is a relative path
createDirRecursive :: FileMode -> RawFilePath -> IO () createDirRecursive :: FileMode -> RawFilePath -> IO ()
createDirRecursive fm p = createDirRecursive fm p = go p
go p where
where go :: RawFilePath -> IO ()
go :: RawFilePath -> IO () go dest = do
go dest = do catchIOError (createDirectory dest fm) $ \e -> do
catchIOError (createDirectory dest fm) $ \e -> do errno <- getErrno
errno <- getErrno case errno of
case errno of en
en | en == eEXIST -> unlessM (doesDirectoryExist dest) (ioError e) | en == eEXIST
| en == eNOENT -> createDirRecursive fm (takeDirectory dest) -> unlessM (doesDirectoryExist dest) (ioError e)
>> createDirectory dest fm | en == eNOENT
| otherwise -> ioError e -> createDirRecursive fm (takeDirectory dest)
>> createDirectory dest fm
| otherwise
-> ioError e
-- |Create a symlink. -- |Create a symlink.
@ -796,8 +761,7 @@ createDirRecursive fm p =
createSymlink :: RawFilePath -- ^ destination file createSymlink :: RawFilePath -- ^ destination file
-> RawFilePath -- ^ path the symlink points to -> RawFilePath -- ^ path the symlink points to
-> IO () -> IO ()
createSymlink destBS sympoint createSymlink destBS sympoint = createSymbolicLink sympoint destBS
= createSymbolicLink sympoint destBS
@ -875,13 +839,13 @@ moveFile from to cm = do
throwSameFile from to throwSameFile from to
case cm of case cm of
Strict -> catchErrno [eXDEV] (renameFile from to) $ do Strict -> catchErrno [eXDEV] (renameFile from to) $ do
easyCopy from to Strict FailEarly easyCopy from to Strict FailEarly
easyDelete from easyDelete from
Overwrite -> do Overwrite -> do
ft <- getFileType from ft <- getFileType from
writable <- do writable <- do
e <- doesFileExist to e <- doesFileExist to
if e then isWritable to else pure False if e then isWritable to else pure False
case ft of case ft of
RegularFile -> do RegularFile -> do
@ -936,12 +900,12 @@ readFile path = do
-- - `PermissionDenied` if we cannot read the file or the directory -- - `PermissionDenied` if we cannot read the file or the directory
-- containting it -- containting it
-- - `NoSuchThing` if the file does not exist -- - `NoSuchThing` if the file does not exist
readFileStream :: RawFilePath readFileStream :: RawFilePath -> IO (SerialT IO ByteString)
-> IO (SerialT IO ByteString)
readFileStream fp = do readFileStream fp = do
fd <- openFd fp SPI.ReadOnly [] Nothing fd <- openFd fp SPI.ReadOnly [] Nothing
handle <- SPI.fdToHandle fd handle <- SPI.fdToHandle fd
let stream = fmap fromArray (S.unfold (SU.finally SIO.hClose FH.readChunks) handle) let stream =
fmap fromArray (S.unfold (SU.finally SIO.hClose FH.readChunks) handle)
pure stream pure stream
@ -966,7 +930,8 @@ writeFile :: RawFilePath
-> ByteString -> ByteString
-> IO () -> IO ()
writeFile fp fmode bs = writeFile fp fmode bs =
bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd) $ \fd -> void $ SPB.fdWrite fd bs bracket (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd)
$ \fd -> void $ SPB.fdWrite fd bs
-- |Write a given lazy ByteString to a file, truncating the file beforehand. -- |Write a given lazy ByteString to a file, truncating the file beforehand.
@ -985,10 +950,11 @@ writeFileL :: RawFilePath
-> L.ByteString -> L.ByteString
-> IO () -> IO ()
writeFileL fp fmode lbs = do writeFileL fp fmode lbs = do
handle <- bracketOnError (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd) $ SPI.fdToHandle handle <-
bracketOnError (openFd fp SPI.WriteOnly [SPDF.oTrunc] fmode) (SPI.closeFd)
$ SPI.fdToHandle
finally (streamlyCopy handle) (SIO.hClose handle) finally (streamlyCopy handle) (SIO.hClose handle)
where where streamlyCopy tH = S.fold (FH.writeChunks tH) $ SL.toChunks lbs
streamlyCopy tH = S.fold (FH.writeChunks tH) $ SL.toChunks lbs
-- |Append a given ByteString to a file. -- |Append a given ByteString to a file.
@ -1002,8 +968,8 @@ writeFileL fp fmode lbs = do
-- - `NoSuchThing` if the file does not exist -- - `NoSuchThing` if the file does not exist
appendFile :: RawFilePath -> ByteString -> IO () appendFile :: RawFilePath -> ByteString -> IO ()
appendFile fp bs = appendFile fp bs =
bracket (openFd fp SPI.WriteOnly [SPDF.oAppend] Nothing) bracket (openFd fp SPI.WriteOnly [SPDF.oAppend] Nothing) (SPI.closeFd)
(SPI.closeFd) $ \fd -> void $ SPB.fdWrite fd bs $ \fd -> void $ SPB.fdWrite fd bs
@ -1015,8 +981,8 @@ appendFile fp bs =
-- |Default permissions for a new file. -- |Default permissions for a new file.
newFilePerms :: FileMode newFilePerms :: FileMode
newFilePerms newFilePerms =
= ownerWriteMode ownerWriteMode
`unionFileModes` ownerReadMode `unionFileModes` ownerReadMode
`unionFileModes` groupWriteMode `unionFileModes` groupWriteMode
`unionFileModes` groupReadMode `unionFileModes` groupReadMode
@ -1026,8 +992,8 @@ newFilePerms
-- |Default permissions for a new directory. -- |Default permissions for a new directory.
newDirPerms :: FileMode newDirPerms :: FileMode
newDirPerms newDirPerms =
= ownerModes ownerModes
`unionFileModes` groupExecuteMode `unionFileModes` groupExecuteMode
`unionFileModes` groupReadMode `unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode `unionFileModes` otherExecuteMode
@ -1047,9 +1013,12 @@ newDirPerms
-- Only eNOENT is catched (and returns False). -- Only eNOENT is catched (and returns False).
doesExist :: RawFilePath -> IO Bool doesExist :: RawFilePath -> IO Bool
doesExist bs = doesExist bs =
catchErrno [eNOENT] (do catchErrno
_ <- PF.getSymbolicLinkStatus bs [eNOENT]
return $ True) (do
_ <- PF.getSymbolicLinkStatus bs
return $ True
)
$ return False $ return False
@ -1059,9 +1028,12 @@ doesExist bs =
-- Only eNOENT is catched (and returns False). -- Only eNOENT is catched (and returns False).
doesFileExist :: RawFilePath -> IO Bool doesFileExist :: RawFilePath -> IO Bool
doesFileExist bs = doesFileExist bs =
catchErrno [eNOENT] (do catchErrno
fs <- PF.getSymbolicLinkStatus bs [eNOENT]
return $ not . PF.isDirectory $ fs) (do
fs <- PF.getSymbolicLinkStatus bs
return $ not . PF.isDirectory $ fs
)
$ return False $ return False
@ -1071,9 +1043,12 @@ doesFileExist bs =
-- Only eNOENT is catched (and returns False). -- Only eNOENT is catched (and returns False).
doesDirectoryExist :: RawFilePath -> IO Bool doesDirectoryExist :: RawFilePath -> IO Bool
doesDirectoryExist bs = doesDirectoryExist bs =
catchErrno [eNOENT] (do catchErrno
fs <- PF.getSymbolicLinkStatus bs [eNOENT]
return $ PF.isDirectory fs) (do
fs <- PF.getSymbolicLinkStatus bs
return $ PF.isDirectory fs
)
$ return False $ return False
@ -1113,12 +1088,9 @@ isExecutable bs = fileAccess bs False False True
-- |Checks whether the directory at the given path exists and can be -- |Checks whether the directory at the given path exists and can be
-- opened. This invokes `openDirStream` which follows symlinks. -- opened. This invokes `openDirStream` which follows symlinks.
canOpenDirectory :: RawFilePath -> IO Bool canOpenDirectory :: RawFilePath -> IO Bool
canOpenDirectory bs = canOpenDirectory bs = handleIOError (\_ -> return False) $ do
handleIOError (\_ -> return False) $ do bracket (openDirStream bs) closeDirStream (\_ -> return ())
bracket (openDirStream bs) return True
closeDirStream
(\_ -> return ())
return True
@ -1176,12 +1148,10 @@ getDirsFiles p = do
getDirsFiles' :: RawFilePath -- ^ dir to read getDirsFiles' :: RawFilePath -- ^ dir to read
-> IO [RawFilePath] -> IO [RawFilePath]
getDirsFiles' fp = do getDirsFiles' fp = do
fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing
rawContents <- getDirectoryContents' fd rawContents <- getDirectoryContents' fd
fmap catMaybes $ for rawContents $ \(_, f) -> fmap catMaybes $ for rawContents $ \(_, f) ->
if FP.isSpecialDirectoryEntry f if FP.isSpecialDirectoryEntry f then pure Nothing else pure $ Just f
then pure Nothing
else pure $ Just f
@ -1202,16 +1172,15 @@ getFileType :: RawFilePath -> IO FileType
getFileType fp = do getFileType fp = do
fs <- PF.getSymbolicLinkStatus fp fs <- PF.getSymbolicLinkStatus fp
decide fs decide fs
where where
decide fs decide fs | PF.isDirectory fs = return Directory
| PF.isDirectory fs = return Directory | PF.isRegularFile fs = return RegularFile
| PF.isRegularFile fs = return RegularFile | PF.isSymbolicLink fs = return SymbolicLink
| PF.isSymbolicLink fs = return SymbolicLink | PF.isBlockDevice fs = return BlockDevice
| PF.isBlockDevice fs = return BlockDevice | PF.isCharacterDevice fs = return CharacterDevice
| PF.isCharacterDevice fs = return CharacterDevice | PF.isNamedPipe fs = return NamedPipe
| PF.isNamedPipe fs = return NamedPipe | PF.isSocket fs = return Socket
| PF.isSocket fs = return Socket | otherwise = ioError $ userError "No filetype?!"
| otherwise = ioError $ userError "No filetype?!"
@ -1243,4 +1212,3 @@ toAbs bs = do
False -> do False -> do
cwd <- getWorkingDirectory cwd <- getWorkingDirectory
return $ cwd </> bs return $ cwd </> bs

5
hpath-io/hpath-io.cabal
View File

@ -26,19 +26,14 @@ library
buildable: False buildable: False
exposed-modules: HPath.IO exposed-modules: HPath.IO
build-depends: base >= 4.8 && <5 build-depends: base >= 4.8 && <5
, IfElse
, bytestring >= 0.10.0.0 , bytestring >= 0.10.0.0
, exceptions , exceptions
, hpath >= 0.11 && < 0.12 , hpath >= 0.11 && < 0.12
, hpath-directory >= 0.13 && < 0.14 , hpath-directory >= 0.13 && < 0.14
, hpath-filepath >= 0.10.2 && < 0.11
, safe-exceptions >= 0.1 , safe-exceptions >= 0.1
, streamly >= 0.7 , streamly >= 0.7
, streamly-bytestring >= 0.1
, time >= 1.8 , time >= 1.8
, unix >= 2.5 , unix >= 2.5
, unix-bytestring
, utf8-string
if !impl(ghc>=7.11) if !impl(ghc>=7.11)
build-depends: transformers build-depends: transformers
hs-source-dirs: src hs-source-dirs: src

278
hpath-io/src/HPath/IO.hs
View File

@ -27,10 +27,7 @@
-- For other functions (like `copyFile`), the behavior on these file types is -- For other functions (like `copyFile`), the behavior on these file types is
-- unreliable/unsafe. Check the documentation of those functions for details. -- unreliable/unsafe. Check the documentation of those functions for details.
{-# LANGUAGE CPP #-}
{-# LANGUAGE PackageImports #-} {-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
module HPath.IO module HPath.IO
( (
@ -68,8 +65,8 @@ module HPath.IO
, writeFileL , writeFileL
, appendFile , appendFile
-- * File permissions -- * File permissions
, newFilePerms , RD.newFilePerms
, newDirPerms , RD.newDirPerms
-- * File checks -- * File checks
, doesExist , doesExist
, doesFileExist , doesFileExist
@ -94,180 +91,43 @@ module HPath.IO
, withHandle , withHandle
, module System.Posix.RawFilePath.Directory.Errors , module System.Posix.RawFilePath.Directory.Errors
) )
where where
import Control.Applicative import Control.Exception.Safe ( bracketOnError
( , finally
(<$>) )
) import Control.Monad.Catch ( MonadThrow(..) )
import Control.Exception.Safe
( import Data.ByteString ( ByteString )
IOException
, bracket
, bracketOnError
, throwIO
, finally
)
import Control.Monad
(
unless
, void
, when
)
import Control.Monad.Catch (MonadThrow(..))
import Control.Monad.IfElse
(
unlessM
)
import Data.ByteString
(
ByteString
)
import Data.Traversable ( for ) import Data.Traversable ( for )
import Data.Functor ( ($>) ) import qualified Data.ByteString.Lazy as L
#if MIN_VERSION_bytestring(0,10,2) import Data.Time.Clock
import Data.ByteString.Builder import Data.Time.Clock.POSIX ( POSIXTime )
#else import HPath
import Data.ByteString.Lazy.Builder import Prelude hiding ( appendFile
#endif , readFile
( , writeFile
Builder )
, byteString import Streamly
, toLazyByteString import qualified System.IO as SIO
) import System.Posix.Directory.ByteString
import qualified Data.ByteString.Lazy as L ( getWorkingDirectory )
import Data.ByteString.Unsafe import qualified "unix" System.Posix.IO.ByteString
( as SPI
unsafePackCStringFinalizer import System.Posix.FD ( openFd )
) import System.Posix.RawFilePath.Directory.Errors
import Data.Foldable import System.Posix.Types ( FileMode
( , ProcessID
for_ , EpochTime
) )
import Data.IORef import qualified System.Posix.RawFilePath.Directory
( as RD
IORef import System.Posix.RawFilePath.Directory
, modifyIORef ( FileType
, newIORef , RecursiveErrorMode
, readIORef , CopyMode
) )
import Data.Maybe
(
catMaybes
)
import Data.Monoid
(
(<>)
, mempty
)
import Data.Time.Clock
import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime)
import Data.Word
(
Word8
)
import Foreign.C.Error
(
eEXIST
, eNOENT
, eNOTEMPTY
, eXDEV
, getErrno
)
import Foreign.C.Types
(
CSize
)
import Foreign.Marshal.Alloc
(
allocaBytes
)
import Foreign.Ptr
(
Ptr
)
import GHC.IO.Exception
(
IOErrorType(..)
)
import HPath
import Prelude hiding (appendFile, readFile, writeFile)
import Streamly
import Streamly.External.ByteString
import qualified Streamly.External.ByteString.Lazy as SL
import qualified Streamly.Data.Fold as FL
import Streamly.Memory.Array
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Internal.FileSystem.Handle as IFH
import qualified Streamly.Internal.Memory.ArrayStream as AS
import qualified Streamly.Prelude as S
import qualified System.IO as SIO
import System.IO.Error
(
catchIOError
, ioeGetErrorType
)
import System.Posix.ByteString
(
exclusive
)
import System.Posix.Directory.ByteString
(
createDirectory
, closeDirStream
, getWorkingDirectory
, openDirStream
, removeDirectory
)
import System.Posix.Files.ByteString
(
createSymbolicLink
, fileAccess
, fileMode
, getFdStatus
, groupExecuteMode
, groupReadMode
, groupWriteMode
, otherExecuteMode
, otherReadMode
, otherWriteMode
, ownerModes
, ownerReadMode
, ownerWriteMode
, readSymbolicLink
, removeLink
, rename
, setFileMode
, unionFileModes
)
import qualified System.Posix.FilePath as FP
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 System.Posix.FD
(
openFd
)
import qualified System.Posix.Process.ByteString as SPP
import System.Posix.RawFilePath.Directory.Errors
import System.Posix.Types
(
FileMode
, ProcessID
, Fd
, EpochTime
)
import System.Posix.Time
import qualified System.Posix.RawFilePath.Directory as RD
import System.Posix.RawFilePath.Directory
(
FileType
, RecursiveErrorMode
, CopyMode
)
@ -337,8 +197,8 @@ copyDirRecursive :: Path b1 -- ^ source dir
-> CopyMode -> CopyMode
-> RecursiveErrorMode -> RecursiveErrorMode
-> IO () -> IO ()
copyDirRecursive (Path fromp) (Path destdirp) cm rm copyDirRecursive (Path fromp) (Path destdirp) cm rm =
= RD.copyDirRecursive fromp destdirp cm rm RD.copyDirRecursive fromp destdirp cm rm
-- |Recreate a symlink. -- |Recreate a symlink.
@ -374,8 +234,8 @@ recreateSymlink :: Path b1 -- ^ the old symlink file
-> Path b2 -- ^ destination file -> Path b2 -- ^ destination file
-> CopyMode -> CopyMode
-> IO () -> IO ()
recreateSymlink (Path symsourceBS) (Path newsymBS) cm recreateSymlink (Path symsourceBS) (Path newsymBS) cm =
= RD.recreateSymlink symsourceBS newsymBS cm RD.recreateSymlink symsourceBS newsymBS cm
-- |Copies the given regular file to the given destination. -- |Copies the given regular file to the given destination.
@ -432,11 +292,7 @@ copyFile (Path from) (Path to) cm = RD.copyFile from to cm
-- * calls `copyDirRecursive` for directories -- * calls `copyDirRecursive` for directories
-- --
-- Note: may call `getcwd` in Overwrite mode (if destination is a relative path) -- Note: may call `getcwd` in Overwrite mode (if destination is a relative path)
easyCopy :: Path b1 easyCopy :: Path b1 -> Path b2 -> CopyMode -> RecursiveErrorMode -> IO ()
-> Path b2
-> CopyMode
-> RecursiveErrorMode
-> IO ()
easyCopy (Path from) (Path to) cm rm = RD.easyCopy from to cm rm easyCopy (Path from) (Path to) cm rm = RD.easyCopy from to cm rm
@ -522,8 +378,7 @@ easyDelete (Path p) = RD.easyDelete p
-- |Opens a file appropriately by invoking xdg-open. The file type -- |Opens a file appropriately by invoking xdg-open. The file type
-- is not checked. This forks a process. -- is not checked. This forks a process.
openFile :: Path b openFile :: Path b -> IO ProcessID
-> IO ProcessID
openFile (Path fp) = RD.openFile fp openFile (Path fp) = RD.openFile fp
@ -725,8 +580,7 @@ readFile (Path path) = RD.readFile path
-- - `PermissionDenied` if we cannot read the file or the directory -- - `PermissionDenied` if we cannot read the file or the directory
-- containting it -- containting it
-- - `NoSuchThing` if the file does not exist -- - `NoSuchThing` if the file does not exist
readFileStream :: Path b readFileStream :: Path b -> IO (SerialT IO ByteString)
-> IO (SerialT IO ByteString)
readFileStream (Path fp) = RD.readFileStream fp readFileStream (Path fp) = RD.readFileStream fp
@ -786,33 +640,6 @@ appendFile (Path fp) bs = RD.appendFile fp bs
-----------------------
--[ 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
------------------- -------------------
--[ File checks ]-- --[ File checks ]--
@ -920,7 +747,7 @@ setModificationTimeHiRes (Path bs) t = RD.setModificationTimeHiRes bs t
-- - `PathParseException` if a filename could not be parsed (should never happen) -- - `PathParseException` if a filename could not be parsed (should never happen)
getDirsFiles :: Path b -- ^ dir to read getDirsFiles :: Path b -- ^ dir to read
-> IO [Path b] -> IO [Path b]
getDirsFiles p@(Path fp) = do getDirsFiles p = do
contents <- getDirsFiles' p contents <- getDirsFiles' p
pure $ fmap (p </>) contents pure $ fmap (p </>) contents
@ -928,7 +755,7 @@ getDirsFiles p@(Path fp) = do
-- | Like 'getDirsFiles', but returns the filename only, instead -- | Like 'getDirsFiles', but returns the filename only, instead
-- of prepending the base path. -- of prepending the base path.
getDirsFiles' :: Path b -- ^ dir to read getDirsFiles' :: Path b -- ^ dir to read
-> IO [Path Rel] -> IO [Path Rel]
getDirsFiles' (Path fp) = do getDirsFiles' (Path fp) = do
rawContents <- RD.getDirsFiles' fp rawContents <- RD.getDirsFiles' fp
for rawContents $ \r -> parseRel r for rawContents $ \r -> parseRel r
@ -981,11 +808,11 @@ toAbs :: Path b -> IO (Path Abs)
toAbs (Path bs) = do toAbs (Path bs) = do
let mabs = parseAbs bs :: Maybe (Path Abs) let mabs = parseAbs bs :: Maybe (Path Abs)
case mabs of case mabs of
Just a -> return a Just a -> return a
Nothing -> do Nothing -> do
cwd <- getWorkingDirectory >>= parseAbs cwd <- getWorkingDirectory >>= parseAbs
rel <- parseRel bs -- we know it must be relative now r <- parseRel bs -- we know it must be relative now
return $ cwd </> rel return $ cwd </> r
-- | Helper function to use the Path library without -- | Helper function to use the Path library without
@ -996,7 +823,10 @@ toAbs (Path bs) = do
-- --
-- - `PathParseException` if the bytestring could neither be parsed as -- - `PathParseException` if the bytestring could neither be parsed as
-- relative or absolute Path -- relative or absolute Path
withRawFilePath :: MonadThrow m => ByteString -> (Either (Path Abs) (Path Rel) -> m b) -> m b withRawFilePath :: MonadThrow m
=> ByteString
-> (Either (Path Abs) (Path Rel) -> m b)
-> m b
withRawFilePath bs action = do withRawFilePath bs action = do
path <- parseAny bs path <- parseAny bs
action path action path
@ -1017,6 +847,6 @@ withHandle :: ByteString
withHandle bs mode action = do withHandle bs mode action = do
path <- parseAny bs path <- parseAny bs
handle <- handle <-
bracketOnError (openFd bs mode [] (Just newFilePerms)) (SPI.closeFd) bracketOnError (openFd bs mode [] (Just RD.newFilePerms)) (SPI.closeFd)
$ SPI.fdToHandle $ SPI.fdToHandle
finally (action (handle, path)) (SIO.hClose handle) finally (action (handle, path)) (SIO.hClose handle)