From 200fc9b58114da0d470c8c1a3d41082a692978cb Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sun, 29 Dec 2019 20:03:28 +0100 Subject: [PATCH 1/3] Use streamly for copyFile --- hpath.cabal | 1 + src/HPath/IO.hs | 112 +++++++++++++++--------------------------------- 2 files changed, 35 insertions(+), 78 deletions(-) diff --git a/hpath.cabal b/hpath.cabal index d97eb3c..bd28f79 100644 --- a/hpath.cabal +++ b/hpath.cabal @@ -42,6 +42,7 @@ library , exceptions , hspec , simple-sendfile >= 0.2.24 + , streamly >= 0.7 , unix >= 2.5 , unix-bytestring , utf8-string diff --git a/src/HPath/IO.hs b/src/HPath/IO.hs index 6affa01..ff6826d 100644 --- a/src/HPath/IO.hs +++ b/src/HPath/IO.hs @@ -150,9 +150,7 @@ import Data.Word import Foreign.C.Error ( eEXIST - , eINVAL , eNOENT - , eNOSYS , eNOTEMPTY , eXDEV , getErrno @@ -177,16 +175,15 @@ import HPath import HPath.Internal import HPath.IO.Errors import Prelude hiding (appendFile, readFile, writeFile) +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Internal.FileSystem.Handle as IFH +import qualified Streamly.Prelude as S +import qualified System.IO as SIO import System.IO.Error ( catchIOError , ioeGetErrorType ) -import System.Linux.Sendfile - ( - sendfileFd - , FileRange(..) - ) import System.Posix.ByteString ( exclusive @@ -466,6 +463,7 @@ recreateSymlink symsource@(MkPath symsourceBS) newsym@(MkPath newsymBS) cm -- instead. -- -- In `Overwrite` copy mode only overwrites actual files, not directories. +-- In `Strict` mode the destination file must not exist. -- -- Safety/reliability concerns: -- @@ -493,83 +491,41 @@ recreateSymlink symsource@(MkPath symsourceBS) newsym@(MkPath newsymBS) cm -- -- Notes: -- --- - calls `sendfile` and possibly `read`/`write` as fallback -- - may call `getcwd` in Overwrite mode (if destination is a relative path) copyFile :: Path b1 -- ^ source file -> Path b2 -- ^ destination file -> CopyMode -> IO () -copyFile from to cm = do - throwSameFile from to - - case cm of - Strict -> _copyFile [SPDF.oNofollow] - [SPDF.oNofollow, SPDF.oExcl] - from to - Overwrite -> - catchIOError (_copyFile [SPDF.oNofollow] - [SPDF.oNofollow, SPDF.oTrunc] - from to) $ \e -> - case ioeGetErrorType e of - -- if the destination file is not writable, we need to - -- figure out if we can still copy by deleting it first - PermissionDenied -> do - exists <- doesFileExist to - writable <- toAbs to >>= isWritable - if (exists && writable) - then deleteFile to >> copyFile from to Strict - else ioError e - _ -> ioError e - - -_copyFile :: [SPDF.Flags] - -> [SPDF.Flags] - -> Path b1 -- ^ source file - -> Path b2 -- ^ destination file - -> IO () -_copyFile sflags dflags (MkPath fromBS) to@(MkPath toBS) - = - -- from sendfile(2) manpage: - -- Applications may wish to fall back to read(2)/write(2) in - -- the case where sendfile() fails with EINVAL or ENOSYS. - catchErrno [eINVAL, eNOSYS] - (sendFileCopy fromBS toBS) - (void $ readWriteCopy fromBS toBS) +copyFile fp@(MkPath from) tp@(MkPath to) cm = do + throwSameFile fp tp + bracket (do + fd <- openFd from SPI.ReadOnly [SPDF.oNofollow] Nothing + handle <- SPI.fdToHandle fd + pure (fd, handle)) + (\(_, handle) -> SIO.hClose handle) + $ \(fromFd, fH) -> do + sourceFileMode <- System.Posix.Files.ByteString.fileMode <$> getFdStatus fromFd + let dflags = [SPDF.oNofollow, case cm of + Strict -> SPDF.oExcl + Overwrite -> SPDF.oTrunc] + bracketeer (do + fd <- openFd to SPI.WriteOnly dflags $ Just sourceFileMode + handle <- SPI.fdToHandle fd + pure (fd, handle)) + (\(_, handle) -> SIO.hClose handle) + (\(_, handle) -> do + SIO.hClose handle + case cm of + -- if we created the file and copying failed, it's + -- safe to clean up + Strict -> deleteFile tp + Overwrite -> pure ()) + $ \(_, tH) -> do + SIO.hSetBinaryMode fH True + SIO.hSetBinaryMode tH True + streamlyCopy (fH, tH) where - copyWith copyAction source dest = - bracket (openFd source SPI.ReadOnly sflags Nothing) - SPI.closeFd - $ \sfd -> do - fileM <- System.Posix.Files.ByteString.fileMode - <$> getFdStatus sfd - bracketeer (openFd dest SPI.WriteOnly - dflags $ Just fileM) - SPI.closeFd - (\fd -> SPI.closeFd fd >> deleteFile to) - $ \dfd -> copyAction sfd dfd - -- this is low-level stuff utilizing sendfile(2) for speed - sendFileCopy :: ByteString -> ByteString -> IO () - sendFileCopy = copyWith - (\sfd dfd -> sendfileFd dfd sfd EntireFile $ return ()) - -- low-level copy operation utilizing read(2)/write(2) - -- in case `sendFileCopy` fails/is unsupported - readWriteCopy :: ByteString -> ByteString -> IO Int - readWriteCopy = copyWith - (\sfd dfd -> allocaBytes (fromIntegral bufSize) - $ \buf -> write' sfd dfd buf 0) - where - bufSize :: CSize - bufSize = 8192 - write' :: Fd -> Fd -> Ptr Word8 -> Int -> IO Int - write' sfd dfd buf totalsize = do - size <- SPB.fdReadBuf sfd buf bufSize - if size == 0 - then return $ fromIntegral totalsize - else do rsize <- SPB.fdWriteBuf dfd buf size - when (rsize /= size) (ioError $ userError - "wrong size!") - write' sfd dfd buf (totalsize + fromIntegral size) - + 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 -- symbolic link it is just recreated, even if it points to a directory. From 2e0fe6b698eb9da4a973d84028bc90083cd16d8b Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 30 Dec 2019 14:56:15 +0100 Subject: [PATCH 2/3] Fix travis Streamly requires at least cabal 2.2. --- .travis.yml | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/.travis.yml b/.travis.yml index 6412ea1..d1d9ad5 100644 --- a/.travis.yml +++ b/.travis.yml @@ -7,16 +7,16 @@ dist: trusty matrix: include: - - env: CABALVER=1.18 GHCVER=7.6.3 - addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}} - - env: CABALVER=1.22 GHCVER=7.8.4 - addons: {apt: {packages: [cabal-install-1.22,ghc-7.8.4], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=7.10.2 - addons: {apt: {packages: [cabal-install-1.24,ghc-7.10.2], sources: [hvr-ghc]}} - - env: CABALVER=1.24 GHCVER=8.0.1 - addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.1], sources: [hvr-ghc]}} - - env: CABALVER=2.0 GHCVER=8.2.2 - addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} + - env: CABALVER=2.2 GHCVER=7.6.3 + addons: {apt: {packages: [cabal-install-2.2,ghc-7.6.3], sources: [hvr-ghc]}} + - env: CABALVER=2.2 GHCVER=7.8.4 + addons: {apt: {packages: [cabal-install-2.2,ghc-7.8.4], sources: [hvr-ghc]}} + - env: CABALVER=2.2 GHCVER=7.10.2 + addons: {apt: {packages: [cabal-install-2.2,ghc-7.10.2], sources: [hvr-ghc]}} + - env: CABALVER=2.2 GHCVER=8.0.1 + addons: {apt: {packages: [cabal-install-2.2,ghc-8.0.1], sources: [hvr-ghc]}} + - env: CABALVER=2.2 GHCVER=8.2.2 + addons: {apt: {packages: [cabal-install-2.2,ghc-8.2.2], sources: [hvr-ghc]}} - env: CABALVER=2.2 GHCVER=8.4.1 addons: {apt: {packages: [cabal-install-2.2,ghc-8.4.1], sources: [hvr-ghc]}} - env: CABALVER=head GHCVER=head From 21dd1718c01a6061e6b2ca97d6371a03e23af396 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 30 Dec 2019 15:16:59 +0100 Subject: [PATCH 3/3] Fix support for older GHCs --- hpath.cabal | 7 ++-- src/HPath/IO.hs | 87 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 91 insertions(+), 3 deletions(-) diff --git a/hpath.cabal b/hpath.cabal index bd28f79..09c99fa 100644 --- a/hpath.cabal +++ b/hpath.cabal @@ -41,13 +41,14 @@ library , deepseq , exceptions , hspec - , simple-sendfile >= 0.2.24 - , streamly >= 0.7 , unix >= 2.5 , unix-bytestring , utf8-string , word8 - + if impl(ghc >= 8.2) + build-depends: streamly >= 0.7 + else + build-depends: simple-sendfile >= 0.2.24 test-suite doctests-hpath if os(windows) diff --git a/src/HPath/IO.hs b/src/HPath/IO.hs index ff6826d..1b57a10 100644 --- a/src/HPath/IO.hs +++ b/src/HPath/IO.hs @@ -154,6 +154,10 @@ import Foreign.C.Error , eNOTEMPTY , eXDEV , getErrno +#if __GLASGOW_HASKELL__ < 802 + , eINVAL + , eNOSYS +#endif ) import Foreign.C.Types ( @@ -175,10 +179,18 @@ import HPath import HPath.Internal import HPath.IO.Errors import Prelude hiding (appendFile, readFile, writeFile) +#if __GLASGOW_HASKELL__ >= 802 import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.FileSystem.Handle as IFH import qualified Streamly.Prelude as S import qualified System.IO as SIO +#else +import System.Linux.Sendfile + ( + sendfileFd + , FileRange(..) + ) +#endif import System.IO.Error ( catchIOError @@ -491,11 +503,14 @@ recreateSymlink symsource@(MkPath symsourceBS) newsym@(MkPath newsymBS) cm -- -- Notes: -- +-- - on GHC < 8.2: calls `sendfile` and possibly `read`/`write` as fallback +-- - on GHC >= 8.2: uses streamly for file copying -- - may call `getcwd` in Overwrite mode (if destination is a relative path) copyFile :: Path b1 -- ^ source file -> Path b2 -- ^ destination file -> CopyMode -> IO () +#if __GLASGOW_HASKELL__ >= 802 copyFile fp@(MkPath from) tp@(MkPath to) cm = do throwSameFile fp tp bracket (do @@ -526,6 +541,78 @@ copyFile fp@(MkPath from) tp@(MkPath to) cm = do streamlyCopy (fH, tH) where streamlyCopy (fH, tH) = S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256*1024) fH +#else +copyFile from to cm = do + throwSameFile from to + + case cm of + Strict -> _copyFile [SPDF.oNofollow] + [SPDF.oNofollow, SPDF.oExcl] + from to + Overwrite -> + catchIOError (_copyFile [SPDF.oNofollow] + [SPDF.oNofollow, SPDF.oTrunc] + from to) $ \e -> + case ioeGetErrorType e of + -- if the destination file is not writable, we need to + -- figure out if we can still copy by deleting it first + PermissionDenied -> do + exists <- doesFileExist to + writable <- toAbs to >>= isWritable + if (exists && writable) + then deleteFile to >> copyFile from to Strict + else ioError e + _ -> ioError e + + +_copyFile :: [SPDF.Flags] + -> [SPDF.Flags] + -> Path b1 -- ^ source file + -> Path b2 -- ^ destination file + -> IO () +_copyFile sflags dflags (MkPath fromBS) to@(MkPath toBS) + = + -- from sendfile(2) manpage: + -- Applications may wish to fall back to read(2)/write(2) in + -- the case where sendfile() fails with EINVAL or ENOSYS. + catchErrno [eINVAL, eNOSYS] + (sendFileCopy fromBS toBS) + (void $ readWriteCopy fromBS toBS) + where + copyWith copyAction source dest = + bracket (openFd source SPI.ReadOnly sflags Nothing) + SPI.closeFd + $ \sfd -> do + fileM <- System.Posix.Files.ByteString.fileMode + <$> getFdStatus sfd + bracketeer (openFd dest SPI.WriteOnly + dflags $ Just fileM) + SPI.closeFd + (\fd -> SPI.closeFd fd >> deleteFile to) + $ \dfd -> copyAction sfd dfd + -- this is low-level stuff utilizing sendfile(2) for speed + sendFileCopy :: ByteString -> ByteString -> IO () + sendFileCopy = copyWith + (\sfd dfd -> sendfileFd dfd sfd EntireFile $ return ()) + -- low-level copy operation utilizing read(2)/write(2) + -- in case `sendFileCopy` fails/is unsupported + readWriteCopy :: ByteString -> ByteString -> IO Int + readWriteCopy = copyWith + (\sfd dfd -> allocaBytes (fromIntegral bufSize) + $ \buf -> write' sfd dfd buf 0) + where + bufSize :: CSize + bufSize = 8192 + write' :: Fd -> Fd -> Ptr Word8 -> Int -> IO Int + write' sfd dfd buf totalsize = do + size <- SPB.fdReadBuf sfd buf bufSize + if size == 0 + then return $ fromIntegral totalsize + else do rsize <- SPB.fdWriteBuf dfd buf size + when (rsize /= size) (ioError $ userError + "wrong size!") + write' sfd dfd buf (totalsize + fromIntegral size) +#endif -- |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.