diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,11 @@ +0.7.0: + * use 'sendfile' from 'simple-sendfile' in _copyFile and do read/write as a fallback only + * add isFileName, hasParentDir, hiddenFile to System.Posix.FilePath + * add our own openFd version for more control + * small documentation improvements + * add a getDirectoryContents' version that works on Fd + * lift version constraints in benchmark + * remove fpToString and userStringToFP, use Data.ByteString.UTF8 directly instead 0.6.0: * fixes 'throwDestinationInSource' to be more reliable. * removes some unused HPathIOException constructors diff --git a/hpath.cabal b/hpath.cabal --- a/hpath.cabal +++ b/hpath.cabal @@ -1,5 +1,5 @@ name: hpath -version: 0.6.0 +version: 0.7.0 synopsis: Support for well-typed paths description: Support for well-typed paths, utilizing ByteString under the hood. license: GPL-2 @@ -29,12 +29,14 @@ HPath.Internal, System.Posix.Directory.Foreign, System.Posix.Directory.Traversals, + System.Posix.FD, System.Posix.FilePath build-depends: base >= 4.2 && <5 , bytestring >= 0.9.2.0 , deepseq , exceptions , hspec + , simple-sendfile >= 0.2.22 , unix >= 2.5 , unix-bytestring , utf8-string @@ -110,9 +112,9 @@ bytestring, unix, directory >= 1.1 && < 1.3, - filepath >= 1.2 && < 1.4, + filepath >= 1.2 && < 1.5, process >= 1.0 && < 1.3, - criterion >= 0.6 && < 0.9 + criterion >= 0.6 && < 1.2 ghc-options: -O2 source-repository head diff --git a/src/HPath.hs b/src/HPath.hs --- a/src/HPath.hs +++ b/src/HPath.hs @@ -45,9 +45,6 @@ ,withAbsPath ,withRelPath ,withFnPath - -- * ByteString operations - ,fpToString - ,userStringToFP ) where diff --git a/src/HPath/IO.hs b/src/HPath/IO.hs --- a/src/HPath/IO.hs +++ b/src/HPath/IO.hs @@ -80,7 +80,6 @@ import Control.Exception ( bracket - , bracketOnError , throwIO ) import Control.Monad @@ -107,6 +106,8 @@ import Foreign.C.Error ( eEXIST + , eINVAL + , eNOSYS , eNOTEMPTY , eXDEV ) @@ -136,6 +137,14 @@ catchIOError , ioeGetErrorType ) +import System.Linux.Sendfile + ( + sendfileFd + ) +import Network.Sendfile + ( + FileRange(..) + ) import System.Posix.ByteString ( exclusive @@ -172,6 +181,10 @@ 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.Directory.Traversals as SPDT import qualified System.Posix.Directory.Foreign as SPDF import qualified System.Posix.Process.ByteString as SPP @@ -341,7 +354,7 @@ -- - `SameFile` if source and destination are the same file (`HPathIOException`) -- - `AlreadyExists` if destination already exists -- --- Note: calls `sendfile` +-- Note: calls `sendfile` and possibly `read`/`write` as fallback copyFile :: Path Abs -- ^ source file -> Path Abs -- ^ destination file -> IO () @@ -358,8 +371,7 @@ -- -- Safety/reliability concerns: -- --- * not atomic --- * falls back to delete-copy method with explicit checks +-- * not atomic, since it uses read/write -- -- Throws: -- @@ -370,7 +382,7 @@ -- - `InvalidArgument` if source file is wrong type (directory) -- - `SameFile` if source and destination are the same file (`HPathIOException`) -- --- Note: calls `sendfile` +-- Note: calls `sendfile` and possibly `read`/`write` as fallback copyFileOverwrite :: Path Abs -- ^ source file -> Path Abs -- ^ destination file -> IO () @@ -398,24 +410,35 @@ -> IO () _copyFile sflags dflags from to = - -- TODO: add sendfile support - void $ readWriteCopy (fromAbs from) (fromAbs to) + -- from sendfile(2) manpage: + -- Applications may wish to fall back to read(2)/write(2) in the case + -- where sendfile() fails with EINVAL or ENOSYS. + withAbsPath to $ \to' -> withAbsPath from $ \from' -> + catchErrno [eINVAL, eNOSYS] + (sendFileCopy from' to') + (void $ readWriteCopy from' to') where - -- low-level copy operation utilizing read(2)/write(2) - -- in case `sendFileCopy` fails/is unsupported - readWriteCopy :: ByteString -> ByteString -> IO Int - readWriteCopy source dest = - bracket (SPDT.openFd source SPI.ReadOnly sflags Nothing) + copyWith copyAction source dest = + bracket (openFd source SPI.ReadOnly sflags Nothing) SPI.closeFd $ \sfd -> do fileM <- System.Posix.Files.ByteString.fileMode <$> getFdStatus sfd - bracketeer (SPDT.openFd dest SPI.WriteOnly + bracketeer (openFd dest SPI.WriteOnly dflags $ Just fileM) SPI.closeFd (\fd -> SPI.closeFd fd >> deleteFile to) - $ \dfd -> allocaBytes (fromIntegral bufSize) $ \buf -> - write' sfd dfd buf 0 + $ \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 @@ -755,14 +778,12 @@ getDirsFiles :: Path Abs -- ^ dir to read -> IO [Path Abs] getDirsFiles p = - withAbsPath p $ \fp -> - bracketOnError (SPDT.openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing) - SPI.closeFd - $ \fd -> - return - . catMaybes - . fmap (\x -> () p <$> (parseMaybe . snd $ x)) - =<< getDirectoryContents' fd + withAbsPath p $ \fp -> do + fd <- openFd fp SPI.ReadOnly [SPDF.oNofollow] Nothing + return + . catMaybes + . fmap (\x -> () p <$> (parseMaybe . snd $ x)) + =<< getDirectoryContents' fd where parseMaybe :: ByteString -> Maybe (Path Fn) parseMaybe = parseFn diff --git a/src/HPath/IO/Errors.hs b/src/HPath/IO/Errors.hs --- a/src/HPath/IO/Errors.hs +++ b/src/HPath/IO/Errors.hs @@ -66,6 +66,10 @@ ( ByteString ) +import Data.ByteString.UTF8 + ( + toString + ) import Data.Data ( Data(..) @@ -114,20 +118,20 @@ instance Show HPathIOException where - show (FileDoesNotExist fp) = "File does not exist:" ++ fpToString fp + show (FileDoesNotExist fp) = "File does not exist:" ++ toString fp show (DirDoesNotExist fp) = "Directory does not exist: " - ++ fpToString fp - show (SameFile fp1 fp2) = fpToString fp1 - ++ " and " ++ fpToString fp2 + ++ toString fp + show (SameFile fp1 fp2) = toString fp1 + ++ " and " ++ toString fp2 ++ " are the same file!" - show (DestinationInSource fp1 fp2) = fpToString fp1 + show (DestinationInSource fp1 fp2) = toString fp1 ++ " is contained in " - ++ fpToString fp2 - show (FileDoesExist fp) = "File does exist: " ++ fpToString fp - show (DirDoesExist fp) = "Directory does exist: " ++ fpToString fp + ++ toString fp2 + show (FileDoesExist fp) = "File does exist: " ++ toString fp + show (DirDoesExist fp) = "Directory does exist: " ++ toString fp show (InvalidOperation str) = "Invalid operation: " ++ str show (Can'tOpenDirectory fp) = "Can't open directory: " - ++ fpToString fp + ++ toString fp show (CopyFailed str) = "Copying failed: " ++ str @@ -266,7 +270,7 @@ return True --- |Throws a `Can'tOpenDirectory` FmIOException if the directory at the given +-- |Throws a `Can'tOpenDirectory` HPathIOException if the directory at the given -- path cannot be opened. throwCantOpenDirectory :: Path Abs -> IO () throwCantOpenDirectory fp = @@ -332,8 +336,8 @@ reactOnError :: IO a - -> [(IOErrorType, IO a)] -- ^ reaction on IO errors - -> [(HPathIOException, IO a)] -- ^ reaction on FmIOException + -> [(IOErrorType, IO a)] -- ^ reaction on IO errors + -> [(HPathIOException, IO a)] -- ^ reaction on HPathIOException -> IO a reactOnError a ios fmios = a `catches` [iohandler, fmiohandler] diff --git a/src/System/Posix/Directory/Traversals.hs b/src/System/Posix/Directory/Traversals.hs --- a/src/System/Posix/Directory/Traversals.hs +++ b/src/System/Posix/Directory/Traversals.hs @@ -1,9 +1,24 @@ +-- | +-- Module : System.Posix.Directory.Traversals +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- Stability : experimental +-- Portability : portable +-- +-- Traversal and read operations on directories. + + {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wall #-} + + module System.Posix.Directory.Traversals ( getDirectoryContents @@ -17,7 +32,7 @@ , readDirEnt , packDirStream , unpackDirStream -, openFd +, fdOpendir , realpath ) where @@ -36,6 +51,7 @@ 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 @@ -54,6 +70,8 @@ -- 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 @@ -71,6 +89,8 @@ 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 @@ -80,6 +100,8 @@ -- 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 @@ -103,17 +125,17 @@ -> IO b actOnDirContents pathRelToTop b f = modifyIOError ((`ioeSetFileName` (BS.unpack pathRelToTop)) . - (`ioeSetLocation` "findBSTypRel")) $ do + (`ioeSetLocation` "findBSTypRel")) $ bracket (openDirStream pathRelToTop) - (Posix.closeDirStream) + Posix.closeDirStream (\dirp -> loop dirp b) where loop dirp b' = do (typ,e) <- readDirEnt dirp if (e == "") then return b' - else do + else if (e == "." || e == "..") then loop dirp b' else f typ (pathRelToTop e) b' >>= loop dirp @@ -154,9 +176,6 @@ foreign import ccall unsafe "fdopendir" c_fdopendir :: Posix.Fd -> IO (Ptr ()) -foreign import ccall unsafe "open" - c_open :: CString -> CInt -> Posix.CMode -> IO CInt - ---------------------------------------------------------- -- less dodgy but still lower-level @@ -189,81 +208,53 @@ 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")) $ do + (`ioeSetLocation` "System.Posix.Directory.Traversals.getDirectoryContents")) $ bracket (PosixBS.openDirStream path) PosixBS.closeDirStream - loop - where - loop dirp = do - t@(_typ,e) <- readDirEnt dirp - if BS.null e then return [] else do - es <- loop dirp - return (t:es) + _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 = - bracket - (fdOpendir fd) - PosixBS.closeDirStream - loop - where - loop dirp = do - t@(_typ,e) <- readDirEnt dirp - if BS.null e then return [] else do - es <- loop dirp - return (t:es) - - -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 - Nothing -> ([],0) - Just x -> ([oCreat], x) - - open_mode = case how of - Posix.ReadOnly -> oRdonly - Posix.WriteOnly -> oWronly - Posix.ReadWrite -> oRdwr +getDirectoryContents' fd = do + dirstream <- fdOpendir fd `catchIOError` \e -> do + closeFd fd + ioError e + -- closeDirStream closes the filedescriptor + finally (_dirloop dirstream) (PosixBS.closeDirStream dirstream) --- |Open and optionally create this file. See 'System.Posix.Files' --- for information on how to use the 'FileMode' type. -openFd :: RawFilePath - -> Posix.OpenMode - -> [Flags] - -> Maybe Posix.FileMode - -> IO Posix.Fd -openFd name how optional_flags maybe_mode = - withFilePath name $ \str -> - throwErrnoPathIfMinus1Retry "openFd" name $ - open_ str how optional_flags maybe_mode +_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) +-- like canonicalizePath, but uses @realpath(3)@ realpath :: RawFilePath -> IO RawFilePath -realpath inp = do +realpath inp = allocaBytes pathMax $ \tmp -> do void $ BS.useAsCString inp $ \cstr -> throwErrnoIfNull "realpath" $ c_realpath cstr tmp BS.packCString tmp diff --git a/src/System/Posix/FD.hs b/src/System/Posix/FD.hs new file mode 100644 --- /dev/null +++ b/src/System/Posix/FD.hs @@ -0,0 +1,75 @@ +-- | +-- Module : System.Posix.FD +-- Copyright : © 2016 Julian Ospald +-- License : BSD3 +-- +-- Maintainer : Julian Ospald +-- 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 + Nothing -> ([],0) + Just x -> ([oCreat], x) + + open_mode = case how of + Posix.ReadOnly -> oRdonly + Posix.WriteOnly -> oWronly + Posix.ReadWrite -> oRdwr + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +-- +-- Note that passing `Just x` as the 4th argument triggers the +-- `oCreat` status flag, which must be set when you pass in `oExcl` +-- to the status flags. Also see the manpage for @open(2)@. +openFd :: RawFilePath + -> Posix.OpenMode + -> [Flags] -- ^ status flags of @open(2)@ + -> Maybe Posix.FileMode -- ^ Just x => creates the file with the given modes, Nothing => the file must exist. + -> IO Posix.Fd +openFd name how optional_flags maybe_mode = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how optional_flags maybe_mode + diff --git a/src/System/Posix/FilePath.hs b/src/System/Posix/FilePath.hs --- a/src/System/Posix/FilePath.hs +++ b/src/System/Posix/FilePath.hs @@ -11,6 +11,7 @@ -- -- Not all functions of "System.FilePath" are implemented yet. Feel free to contribute! + {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -Wall #-} @@ -72,16 +73,11 @@ , equalFilePath , hiddenFile - -- * Type conversion -, fpToString -, userStringToFP - , module System.Posix.ByteString.FilePath ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.ByteString.UTF8 (fromString, toString) import System.Posix.ByteString.FilePath import Data.Maybe (isJust) @@ -94,7 +90,6 @@ -- >>> import Test.QuickCheck -- >>> import Control.Applicative -- >>> import qualified Data.ByteString as BS --- >>> import Data.ByteString (ByteString) -- >>> instance Arbitrary ByteString where arbitrary = BS.pack <$> arbitrary -- >>> instance CoArbitrary ByteString where coarbitrary = coarbitrary . BS.unpack -- @@ -441,7 +436,6 @@ dropDots :: [ByteString] -> [ByteString] dropDots = filter (BS.singleton _period /=) - ------------------------ -- trailing path separators @@ -524,7 +518,8 @@ | _nul `BS.elem` filepath = False | otherwise = True --- | Is the given filename a valid filename? +-- | Is the given path a valid filename? This includes +-- "." and "..". -- -- >>> isFileName "lal" -- True @@ -538,13 +533,13 @@ -- False -- >>> isFileName "/random_ path:*" -- False -isFileName :: ByteString -> Bool +isFileName :: RawFilePath -> Bool isFileName filepath = not (BS.singleton pathSeparator `BS.isInfixOf` filepath) && not (BS.null filepath) && not (_nul `BS.elem` filepath) --- | Helper function: check if the filepath has any parent directories in it. +-- | Check if the filepath has any parent directories in it. -- -- >>> hasParentDir "/.." -- True @@ -560,19 +555,18 @@ -- False -- >>> hasParentDir ".." -- False -hasParentDir :: ByteString -> Bool +hasParentDir :: RawFilePath -> Bool hasParentDir filepath = - ((pathSeparator `BS.cons` pathDoubleDot) - `BS.isSuffixOf` filepath - ) || - ((BS.singleton pathSeparator - `BS.append` pathDoubleDot - `BS.append` BS.singleton pathSeparator - ) `BS.isInfixOf` filepath - ) || - ((pathDoubleDot `BS.append` BS.singleton pathSeparator - ) `BS.isPrefixOf` filepath - ) + (pathSeparator `BS.cons` pathDoubleDot) + `BS.isSuffixOf` filepath + || + (BS.singleton pathSeparator + `BS.append` pathDoubleDot + `BS.append` BS.singleton pathSeparator) + `BS.isInfixOf` filepath + || + (pathDoubleDot `BS.append` BS.singleton pathSeparator) + `BS.isPrefixOf` filepath where pathDoubleDot = BS.pack [_period, _period] @@ -605,32 +599,26 @@ -- True -- >>> hiddenFile "..foo.bar" -- True +-- >>> hiddenFile "some/path/.bar" +-- True -- >>> hiddenFile "..." -- True --- >>> hiddenFile "dod" --- False -- >>> hiddenFile "dod.bar" -- False +-- >>> hiddenFile "." +-- False +-- >>> hiddenFile ".." +-- False +-- >>> hiddenFile "" +-- False hiddenFile :: RawFilePath -> Bool hiddenFile fp - | fp == BS.pack [_period, _period] = False - | fp == BS.pack [_period] = False + | fn == BS.pack [_period, _period] = False + | fn == BS.pack [_period] = False | otherwise = BS.pack [extSeparator] - `BS.isPrefixOf` fp - ------------------------- --- conversion - --- |Uses UTF-8 decoding to convert the bytestring into a String. -fpToString :: ByteString -> String -fpToString = toString - - --- |Uses UTF-8 encoding to convert a user provided String into --- a ByteString, which represents a filepath. -userStringToFP :: String -> ByteString -userStringToFP = fromString - + `BS.isPrefixOf` fn + where + fn = takeFileName fp ------------------------ -- internal stuff @@ -638,7 +626,7 @@ -- Just split the input FileName without adding/normalizing or changing -- anything. splitFileNameRaw :: RawFilePath -> (RawFilePath, RawFilePath) -splitFileNameRaw x = BS.breakEnd isPathSeparator x +splitFileNameRaw = BS.breakEnd isPathSeparator -- | Combine two paths, assuming rhs is NOT absolute. combineRaw :: RawFilePath -> RawFilePath -> RawFilePath