b9aa2ce8d1
This method avoids breaking test_readonly. Just check if the dest file exists, and avoid CoW probing when it does, so when CoW probing fails, it can resume where the previous non-CoW copy left off. If CoW has been probed already to work, delete the dest file since a CoW copy will presumably work. It seems like it would be almost as good to just skip CoW copying in this case too, but consider that the dest file might have started to be copied from some other remote, not using CoW, but CoW has been probed to work to copy from the current place. Sponsored-by: Dartmouth College's Datalad project
91 lines
2.9 KiB
Haskell
91 lines
2.9 KiB
Haskell
{- file copying
|
|
-
|
|
- Copyright 2010-2021 Joey Hess <id@joeyh.name>
|
|
-
|
|
- License: BSD-2-clause
|
|
-}
|
|
|
|
module Utility.CopyFile (
|
|
copyFileExternal,
|
|
copyCoW,
|
|
createLinkOrCopy,
|
|
CopyMetaData(..)
|
|
) where
|
|
|
|
import Common
|
|
import qualified BuildInfo
|
|
|
|
data CopyMetaData
|
|
-- Copy timestamps when possible, but no other metadata, and
|
|
-- when copying a symlink, makes a copy of its content.
|
|
= CopyTimeStamps
|
|
-- Copy all metadata when possible.
|
|
| CopyAllMetaData
|
|
deriving (Eq)
|
|
|
|
copyMetaDataParams :: CopyMetaData -> [CommandParam]
|
|
copyMetaDataParams meta = map snd $ filter fst
|
|
[ (allmeta && BuildInfo.cp_a, Param "-a")
|
|
, (allmeta && BuildInfo.cp_p && not BuildInfo.cp_a
|
|
, Param "-p")
|
|
, (not allmeta && BuildInfo.cp_preserve_timestamps
|
|
, Param "--preserve=timestamps")
|
|
-- cp -a may preserve xattrs that have special meaning,
|
|
-- eg to NFS, and have even been observed to prevent later
|
|
-- changing the permissions of the file. So prevent preserving
|
|
-- xattrs.
|
|
, (allmeta && BuildInfo.cp_a && BuildInfo.cp_no_preserve_xattr_supported
|
|
, Param "--no-preserve=xattr")
|
|
]
|
|
where
|
|
allmeta = meta == CopyAllMetaData
|
|
|
|
{- The cp command is used, because I hate reinventing the wheel,
|
|
- and because this allows easy access to features like cp --reflink
|
|
- and preserving metadata. -}
|
|
copyFileExternal :: CopyMetaData -> FilePath -> FilePath -> IO Bool
|
|
copyFileExternal meta src dest = do
|
|
-- Delete any existing dest file because an unwritable file
|
|
-- would prevent cp from working.
|
|
void $ tryIO $ removeFile dest
|
|
boolSystem "cp" $ params ++ [File src, File dest]
|
|
where
|
|
params
|
|
| BuildInfo.cp_reflink_supported =
|
|
Param "--reflink=auto" : copyMetaDataParams meta
|
|
| otherwise = copyMetaDataParams meta
|
|
|
|
{- When a filesystem supports CoW (and cp does), uses it to make
|
|
- an efficient copy of a file. Otherwise, returns False.
|
|
-
|
|
- The dest file must not exist yet, or it will fail to make a CoW copy,
|
|
- and will return False. -}
|
|
copyCoW :: CopyMetaData -> FilePath -> FilePath -> IO Bool
|
|
copyCoW meta src dest
|
|
| BuildInfo.cp_reflink_supported = do
|
|
-- When CoW is not supported, cp will complain to stderr,
|
|
-- so have to discard its stderr.
|
|
ok <- catchBoolIO $ withNullHandle $ \nullh ->
|
|
let p = (proc "cp" $ toCommand $ params ++ [File src, File dest])
|
|
{ std_out = UseHandle nullh
|
|
, std_err = UseHandle nullh
|
|
}
|
|
in withCreateProcess p $ \_ _ _ -> checkSuccessProcess
|
|
-- When CoW is not supported, cp creates the destination
|
|
-- file but leaves it empty.
|
|
unless ok $
|
|
void $ tryIO $ removeFile dest
|
|
return ok
|
|
| otherwise = return False
|
|
where
|
|
params = Param "--reflink=always" : copyMetaDataParams meta
|
|
|
|
{- Create a hard link if the filesystem allows it, and fall back to copying
|
|
- the file. -}
|
|
createLinkOrCopy :: FilePath -> FilePath -> IO Bool
|
|
createLinkOrCopy src dest = go `catchIO` const fallback
|
|
where
|
|
go = do
|
|
createLink src dest
|
|
return True
|
|
fallback = copyFileExternal CopyAllMetaData src dest
|