Copy.hs

{-# LANGUAGE CPP #-}
-- Cross-platform copy-on-write file semantics.
module System.IO.Copy 
  (copyFile
#if linux_HOST_OS || darwin_HOST_OS
   ,copyFileOnlyIfCopyOnWrite
   ,CopyError(..)
#endif
  ) where
import Foreign.C.Error (Errno(..))
#if defined(mingw32_HOST_OS)
-- WINDOWS
import qualified System.Win32.File as Win32
# if defined(i386_HOST_ARCH)
#  define WINDOWS_CCONV stdcall
# elif defined(x86_64_HOST_ARCH)
#  define WINDOWS_CCONV ccall
# endif
#else
-- LINUX
import Foreign.Ptr (Ptr, nullPtr)
import Foreign.C.Types
import System.IO (Handle, IOMode(..), openFile)
import Control.Exception (throwIO)
import System.Posix.Types (Fd(..))
import System.Posix.IO (handleToFd, closeFd)
import Foreign.C.Error (getErrno, eBADF, eFAULT, eNOTTY, eTXTBSY, eISDIR, eXDEV, eOPNOTSUPP, ePERM, eINVAL, errnoToIOError)
#endif

#if linux_HOST_OS
-- | True if the function should fallback on non-copy-on-write semantics if copy-on-write is not possible.
type CopyFallback = Bool

-- | Copy data from one handle to the other hopefully using copy-on-write semantics, but fallback to generic copy if copy-on-write fails.
copyHandle :: CopyFallback -> Handle -> Handle -> IO (Either CopyError ())
copyHandle fallback source dest = do
  sourceFd <- handleToFd source
  destFd <- handleToFd dest
  ret <- ficlone destFd sourceFd
  errno <- getErrno
  let convertError errno'
        | errno' `elem` [eBADF, ePERM, eTXTBSY] =
          InvalidFileDescriptorError errno'
      convertError errno'
        | errno' `elem` [eXDEV] =
          CrossFSWriteError errno'
      convertError errno'
        | errno' `elem` [eINVAL, eISDIR, eOPNOTSUPP] =
          NotSupportedError errno'
      convertError errno' =
        InvalidFileDescriptorError errno'
      cleanup = do
        closeFd sourceFd
        closeFd destFd
  if ret /= 0 then do
    if fallback then do
      if errno `elem` [eBADF, eFAULT, eNOTTY, eTXTBSY, eISDIR, ePERM] then do
        cleanup
        pure (Left (convertError errno))
      else do --EINVAL or EOPNOTSUPP or EXDEV, so perform fallback
        result <- copy_file_range sourceFd destFd
        if result < 0 then do
          err <- getErrno
          cleanup
          pure (Left (FallbackCopyError err))
        else do
          cleanup
          pure (Right ())
    else do
      cleanup
      pure (Left (convertError errno))
  else do
    cleanup
    pure (Right ())
#elif darwin_HOST_OS
  res <- clonefile source dest
  if res < 0 then do
    -- on darwin, there is no fallback- we just assume APFS as the filesystem
    pure (Left (FallbackCopyError (Errno 0)))
  else
    pure (Right ())
#elif mingw32_HOST_OS
#endif

copyFile :: FilePath -> FilePath -> IO ()
copyFile sourcePath destPath = do
  -- call copyHandle on Linux and Darwin
#if linux_HOST_OS || darwin_HOST_OS
  sourceHandle <- openFile sourcePath ReadMode 
  destHandle <- openFile destPath WriteMode 
  res <- copyHandle True sourceHandle destHandle
  case res of
    Left err -> throwIO $ errnoToIOError "copyFile (CoW)" (errnoFromCopyError err) Nothing Nothing
    Right () -> pure ()
#else 
  -- on Windows, copyFile will use CoW where available which is only on ReFS
  Win32.copyFile sourcePath destPath False
#endif
  
data CopyError =
  CrossFSWriteError Errno |
  InvalidFileDescriptorError Errno |
  NotSupportedError Errno |
  FallbackCopyError Errno
  deriving (Eq)

instance Show CopyError where
  show e =
    case e of
      CrossFSWriteError (Errno errno) -> "CrossFSWriteError " <> show errno
      InvalidFileDescriptorError (Errno errno) -> "InvalidFileDescriptorError " <> show errno
      NotSupportedError (Errno errno) -> "NotSupportedError " <> show errno
      FallbackCopyError (Errno errno) -> "FallbackCopyError " <> show errno

#if linux_HOST_OS || darwin_HOST_OS
errnoFromCopyError :: CopyError -> Errno
errnoFromCopyError e =
  case e of
    CrossFSWriteError e' -> e'
    InvalidFileDescriptorError e' -> e'
    NotSupportedError e' -> e'
    FallbackCopyError e' -> e'

copyFileOnlyIfCopyOnWrite :: FilePath -> FilePath -> IO (Either CopyError ())
copyFileOnlyIfCopyOnWrite sourcePath destPath = do
  sourceHandle <- openFile sourcePath ReadMode 
  destHandle <- openFile destPath WriteMode 
  copyHandle False sourceHandle destHandle
#endif

#ifdef linux_HOST_OS
-- LINUX ONLY
-- FICLONE ioctl number. Common value for x86_64 Linux (from linux/fs.h):
-- #define FICLONE        _IOW(0x94, 9, int)
-- Encoded here as 0x40049409 (unsigned long)
-- If this doesn't work on your architecture, check <linux/fs.h>.
ficlone_ioctl :: CULong
ficlone_ioctl = 0x40049409

foreign import ccall unsafe "ioctl"
  c_ioctl :: CInt -> CULong -> CInt -> IO CInt

-- wrapper: perform ioctl with fdDst, FICLONE, fdSrc
ficlone :: Fd -> Fd -> IO CInt
ficlone (Fd fdDst) (Fd fdSrc) = do
  -- third arg should be the source fd cast to unsigned long / int as expected by kernel
  let arg = fromIntegral fdSrc :: CInt
  --throwErrnoIfMinus1_ "ioctl(FICLONE)" $
  c_ioctl (fromIntegral fdDst) ficlone_ioctl arg

foreign import ccall unsafe "copy_file_range"
  c_copy_file_range :: CInt -> Ptr CULong -> CInt -> Ptr CULong -> CULong -> CUInt -> IO CLong

copy_file_range :: Fd -> Fd -> IO CLong
copy_file_range (Fd fdSource) (Fd fdDest) =
  c_copy_file_range (fromIntegral fdSource) nullPtr (fromIntegral fdDest) nullPtr maxBound 0

#elif darwin_HOST_OS
foreign import ccall unsafe "clonefile"
  c_clonefile :: CString -> CString -> IO CInt

clonefile :: FilePath -> FilePath -> IO CInt
clonefile sourcePath destPath =
  withCString sourcePath $ \cSourcePath ->
    withCString destPath $ \cDestPath ->
      c_clonefile cSourcePath cDestPath

#endif