module Annex.CopyFile where
import Annex.Common
-import Types.Remote
import Utility.Metered
import Utility.CopyFile
import Utility.FileMode
import Utility.Touch
import Types.Backend
-import Annex.Verify
import Control.Concurrent
import qualified Data.ByteString as S
import Data.Time.Clock.POSIX
--- Copies from src to dest, updating a meter. If the copy finishes
--- successfully, calls a final check action, which must also succeed, or
--- returns false.
-type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
-
-- To avoid the overhead of trying copy-on-write every time, it's tried
-- once and if it fails, is not tried again.
newtype CopyCoWTried = CopyCoWTried (MVar Bool)
docopycow = watchFileSize dest meterupdate $
copyCoW CopyTimeStamps src dest
-{- Copys a file. Uses copy-on-write if it is supported. Otherwise,
- - copies the file itself. If the destination already exists,
- - an interruped copy will resume where it left off.
+data CopyMethod = CopiedCoW | Copied
+
+{- Copies from src to dest, updating a meter. Preserves mode and mtime.
+ - Uses copy-on-write if it is supported. If the the destination already
+ - exists, an interruped copy will resume where it left off.
+ -
+ - The IncrementalVerifier is updated with the content of the file as it's
+ - being copied. But it is not finalized at the end.
-
- - When copy-on-write is used, returns UnVerified, because the content of
- - the file has not been verified to be correct. When the file has to be
- - read to copy it, a hash is calulated at the same time.
+ - When copy-on-write is used, the IncrementalVerifier is not fed
+ - the content of the file.
-
- Note that, when the destination file already exists, it's read both
- to start calculating the hash, and also to verify that its content is
- (eg when isStableKey is false), and doing this avoids getting a
- corrupted file in such cases.
-}
-fileCopier :: CopyCoWTried -> FileCopier
+fileCopier :: CopyCoWTried -> FilePath -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex CopyMethod
#ifdef mingw32_HOST_OS
-fileCopier _ src dest k meterupdate check verifyconfig = docopy
+fileCopier _ src dest meterupdate iv = docopy
#else
-fileCopier copycowtried src dest k meterupdate check verifyconfig =
+fileCopier copycowtried src dest meterupdate iv =
ifM (liftIO $ tryCopyCoW copycowtried src dest meterupdate)
- ( unVerified check
+ ( return CopiedCoW
, docopy
)
#endif
dest' = toRawFilePath dest
docopy = do
- iv <- startVerifyKeyContentIncrementally verifyconfig k
-
-- The file might have had the write bit removed,
-- so make sure we can write to it.
void $ liftIO $ tryIO $ allowWrite dest'
liftIO $ withBinaryFile dest ReadWriteMode $ \hdest ->
withBinaryFile src ReadMode $ \hsrc -> do
- sofar <- compareexisting iv hdest hsrc zeroBytesProcessed
- docopy' iv hdest hsrc sofar
+ sofar <- compareexisting hdest hsrc zeroBytesProcessed
+ docopy' hdest hsrc sofar
-- Copy src mode and mtime.
mode <- liftIO $ fileMode <$> getFileStatus src
liftIO $ setFileMode dest mode
liftIO $ touch dest' mtime False
- ifM check
- ( case iv of
- Just x -> ifM (liftIO $ finalizeIncremental x)
- ( return (True, Verified)
- , do
- warning "verification of content failed"
- return (False, UnVerified)
- )
- Nothing -> return (True, UnVerified)
- , return (False, UnVerified)
- )
+ return Copied
- docopy' iv hdest hsrc sofar = do
+ docopy' hdest hsrc sofar = do
s <- S.hGet hsrc defaultChunkSize
if s == S.empty
then return ()
S.hPut hdest s
maybe noop (flip updateIncremental s) iv
meterupdate sofar'
- docopy' iv hdest hsrc sofar'
+ docopy' hdest hsrc sofar'
-- Leaves hdest and hsrc seeked to wherever the two diverge,
-- so typically hdest will be seeked to end, and hsrc to the same
-- position.
- compareexisting iv hdest hsrc sofar = do
+ compareexisting hdest hsrc sofar = do
s <- S.hGet hdest defaultChunkSize
if s == S.empty
then return sofar
maybe noop (flip updateIncremental s) iv
let sofar' = addBytesProcessed sofar (S.length s)
meterupdate sofar'
- compareexisting iv hdest hsrc sofar'
+ compareexisting hdest hsrc sofar'
else do
seekbefore hdest s
seekbefore hsrc s'
in byteStorer go k c m
NoChunks ->
let go _k src p = do
- fileCopierUnVerified cow src tmpf k p
+ void $ fileCopier cow src tmpf p Nothing
liftIO $ finalizeStoreGeneric d tmpdir destdir
in fileStorer go k c m
_ ->
kf = keyFile k
destdir = storeDir d k
-fileCopierUnVerified :: CopyCoWTried -> FilePath -> FilePath -> Key -> MeterUpdate -> Annex ()
-fileCopierUnVerified cow src dest k p = do
- (ok, _verification) <- fileCopier cow src dest k p (return True) NoVerify
- unless ok $ giveup "failed to copy file"
-
checkDiskSpaceDirectory :: RawFilePath -> Key -> Annex Bool
checkDiskSpaceDirectory d k = do
annexdir <- fromRepo gitAnnexObjectDir
retrieveKeyFileM d (LegacyChunks _) _ = Legacy.retrieve locations d
retrieveKeyFileM d NoChunks cow = fileRetriever $ \dest k p -> do
src <- liftIO $ fromRawFilePath <$> getLocation d k
- fileCopierUnVerified cow src dest k p
+ void $ fileCopier cow src dest p Nothing
retrieveKeyFileM d _ _ = byteRetriever $ \k sink ->
sink =<< liftIO (L.readFile . fromRawFilePath =<< getLocation d k)
)
storeExportM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex ()
-storeExportM d cow src k loc p = do
+storeExportM d cow src _k loc p = do
liftIO $ createDirectoryUnder d (P.takeDirectory dest)
-- Write via temp file so that checkPresentGeneric will not
-- see it until it's fully stored.
viaTmp go (fromRawFilePath dest) ()
where
dest = exportPath d loc
- go tmp () = fileCopierUnVerified cow src tmp k p
+ go tmp () = void $ fileCopier cow src tmp p Nothing
retrieveExportM :: RawFilePath -> CopyCoWTried -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex ()
-retrieveExportM d cow k loc dest p = fileCopierUnVerified cow src dest k p
+retrieveExportM d cow _k loc dest p = void $ fileCopier cow src dest p Nothing
where
src = fromRawFilePath $ exportPath d loc
guardSameContentIdentifiers cont cid currcid
storeExportWithContentIdentifierM :: RawFilePath -> CopyCoWTried -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier
-storeExportWithContentIdentifierM dir cow src k loc overwritablecids p = do
+storeExportWithContentIdentifierM dir cow src _k loc overwritablecids p = do
liftIO $ createDirectoryUnder dir (toRawFilePath destdir)
withTmpFileIn destdir template $ \tmpf tmph -> do
liftIO $ hClose tmph
- fileCopierUnVerified cow src tmpf k p
+ void $ fileCopier cow src tmpf p Nothing
let tmpf' = toRawFilePath tmpf
resetAnnexFilePerm tmpf'
liftIO (getFileStatus tmpf) >>= liftIO . mkContentIdentifier tmpf' >>= \case
import Logs.Presence
import Annex.Transfer
import Annex.CopyFile
+import Annex.Verify
import Annex.UUID
import qualified Annex.Content
import qualified Annex.BranchState
-- because they can be modified at any time.
<&&> (not <$> annexThin <$> Annex.getGitConfig)
+type FileCopier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> VerifyConfig -> Annex (Bool, Verification)
+
-- If either the remote or local repository wants to use hard links,
-- the copier will do so (falling back to copying if a hard link cannot be
-- made).
-- copying it.
mkFileCopier :: Bool -> State -> Annex FileCopier
mkFileCopier remotewanthardlink (State _ _ copycowtried _ _) = do
- let copier = fileCopier copycowtried
localwanthardlink <- wantHardLink
let linker = \src dest -> createLink src dest >> return True
if remotewanthardlink || localwanthardlink
, copier src dest k p check verifyconfig
)
else return copier
+ where
+ copier src dest k p check verifyconfig = do
+ iv <- startVerifyKeyContentIncrementally verifyconfig k
+ fileCopier copycowtried src dest p iv >>= \case
+ Copied -> ifM check
+ ( case iv of
+ Just x -> ifM (liftIO $ finalizeIncremental x)
+ ( return (True, Verified)
+ , do
+ warning "verification of content failed"
+ return (False, UnVerified)
+ )
+ Nothing -> return (True, UnVerified)
+ , return (False, UnVerified)
+ )
+ CopiedCoW -> unVerified check
{- Normally the UUID of a local repository is checked at startup,
- but annex-checkuuid config can prevent that. To avoid getting
projects / git-annex.git / commitdiff