From c4c9b99e22255a5ccea6613222808be702e0acc1 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 10 Feb 2021 13:38:45 -0400 Subject: [PATCH] refactoring --- Remote/Git.hs | 110 ++++++++++++++++++++++++++------------------------ 1 file changed, 58 insertions(+), 52 deletions(-) diff --git a/Remote/Git.hs b/Remote/Git.hs index 43255ec32d..f05b9c92a1 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -545,7 +545,7 @@ copyFromRemote'' repo forcersync r st@(State connpool _ _ _ _) key file dest met (ok, v) <- runTransfer (Transfer Download u (fromKey id key)) file Nothing stdRetry $ \p -> metered (Just (combineMeterUpdate p meterupdate)) key $ \_ p' -> - copier object dest p' checksuccess + copier object dest key p' checksuccess if ok then return v else giveup "failed to retrieve content from remote" @@ -690,7 +690,7 @@ copyToRemote' repo r st@(State connpool duc _ _ _) key file meterupdate let rsp = RetrievalAllKeysSecure res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key $ \_ p' -> - copier object (fromRawFilePath dest) p' (liftIO checksuccessio) + copier object (fromRawFilePath dest) key p' (liftIO checksuccessio) Annex.Content.saveState True return res ) @@ -783,50 +783,6 @@ onLocal' (LocalRemoteAnnex repo v) a = liftIO (takeMVar v) >>= \case onLocalFast :: State -> Annex a -> Annex a onLocalFast st a = onLocal st $ Annex.BranchState.disableUpdate >> a --- 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) - -newCopyCoWTried :: IO CopyCoWTried -newCopyCoWTried = CopyCoWTried <$> newEmptyMVar - -{- Copys a file. Uses copy-on-write if it is supported. Otherwise, - - uses rsync, so that interrupted copies can be resumed. -} -rsyncOrCopyFile :: State -> [CommandParam] -> FilePath -> FilePath -> MeterUpdate -> Annex Bool -#ifdef mingw32_HOST_OS -rsyncOrCopyFile _st _rsyncparams src dest p = - -- rsync is only available on Windows in some installation methods, - -- and is not strictly needed here, so don't use it. - docopywith copyFileExternal - where -#else -rsyncOrCopyFile st rsyncparams src dest p = - -- If multiple threads reach this at the same time, they - -- will both try CoW, which is acceptable. - ifM (liftIO $ isEmptyMVar copycowtried) - ( do - ok <- docopycow - void $ liftIO $ tryPutMVar copycowtried ok - pure ok <||> dorsync - , ifM (liftIO $ readMVar copycowtried) - ( docopycow <||> dorsync - , dorsync - ) - ) - where - copycowtried = case st of - State _ _ (CopyCoWTried v) _ _ -> v - dorsync = do - -- dest may already exist, so make sure rsync can write to it - void $ liftIO $ tryIO $ allowWrite (toRawFilePath dest) - oh <- mkOutputHandlerQuiet - Ssh.rsyncHelper oh (Just p) $ - rsyncparams ++ [File src, File dest] - docopycow = docopywith copyCoW -#endif - docopywith a = liftIO $ watchFileSize dest p $ - a CopyTimeStamps src dest - commitOnCleanup :: Git.Repo -> Remote -> State -> Annex a -> Annex a commitOnCleanup repo r st a = go `after` a where @@ -867,23 +823,23 @@ wantHardLink = (annexHardLink <$> Annex.getGitConfig) -- -- When a hard link is created, returns Verified; the repo being linked -- from is implicitly trusted, so no expensive verification needs to be --- done. -type Copier = FilePath -> FilePath -> MeterUpdate -> Annex Bool -> Annex (Bool, Verification) +-- done. Also returns Verified if the key's content is verified while +-- copying it. +type Copier = FilePath -> FilePath -> Key -> MeterUpdate -> Annex Bool -> Annex (Bool, Verification) mkCopier :: Bool -> State -> [CommandParam] -> Annex Copier mkCopier remotewanthardlink st rsyncparams = do - let copier = \src dest p check -> unVerified $ - rsyncOrCopyFile st rsyncparams src dest p <&&> check + let copier = fileCopier st rsyncparams localwanthardlink <- wantHardLink let linker = \src dest -> createLink src dest >> return True if remotewanthardlink || localwanthardlink - then return $ \src dest p check -> + then return $ \src dest k p check -> ifM (liftIO (catchBoolIO (linker src dest))) ( ifM check ( return (True, Verified) , return (False, UnVerified) ) - , copier src dest p check + , copier src dest k p check ) else return copier @@ -941,3 +897,53 @@ mkState r u gc = do ) return (duc, getrepo) + +-- 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) + +newCopyCoWTried :: IO CopyCoWTried +newCopyCoWTried = CopyCoWTried <$> newEmptyMVar + +{- Copys a file. Uses copy-on-write if it is supported. Otherwise, + - uses rsync, so that interrupted copies can be resumed. -} +fileCopier :: State -> [CommandParam] -> Copier +#ifdef mingw32_HOST_OS +rsyncOrCopyFile _st _rsyncparams src dest k p check = + -- rsync is only available on Windows in some installation methods, + -- and is not strictly needed here, so don't use it. + unVerified $ docopywith copyFileExternal <&&> check + where +#else +fileCopier st rsyncparams src dest _k p check = + -- If multiple threads reach this at the same time, they + -- will both try CoW, which is acceptable. + ifM (liftIO $ isEmptyMVar copycowtried) + ( do + ok <- docopycow + void $ liftIO $ tryPutMVar copycowtried ok + if ok + then unVerified check + else unVerified $ dorsync <&&> check + , ifM (liftIO $ readMVar copycowtried) + ( do + ok <- docopycow + if ok + then unVerified check + else unVerified $ dorsync <&&> check + , unVerified dorsync + ) + ) + where + copycowtried = case st of + State _ _ (CopyCoWTried v) _ _ -> v + dorsync = do + -- dest may already exist, so make sure rsync can write to it + void $ liftIO $ tryIO $ allowWrite (toRawFilePath dest) + oh <- mkOutputHandlerQuiet + Ssh.rsyncHelper oh (Just p) $ + rsyncparams ++ [File src, File dest] + docopycow = docopywith copyCoW +#endif + docopywith a = liftIO $ watchFileSize dest p $ + a CopyTimeStamps src dest