diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -22,7 +22,7 @@ setOutput, getFlag, getField, - addCleanup, + addCleanupAction, gitRepo, inRepo, fromRepo, @@ -32,6 +32,7 @@ changeGitRepo, adjustGitRepo, addGitConfigOverride, + getGitConfigOverrides, getRemoteGitConfig, withCurrentState, changeDirectory, @@ -70,6 +71,9 @@ import Types.IndexFiles import Types.CatFileHandles import Types.RemoteConfig +import Types.TransferrerPool +import Types.VectorClock +import Annex.VectorClock.Utility import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url @@ -109,6 +113,7 @@ , repoadjustment :: (Git.Repo -> IO Git.Repo) , gitconfig :: GitConfig , gitconfigadjustment :: (GitConfig -> GitConfig) + , gitconfigoverride :: [String] , gitremotes :: Maybe [Git.Repo] , backend :: Maybe (BackendA Annex) , remotes :: [Types.Remote.RemoteA Annex] @@ -118,6 +123,7 @@ , fast :: Bool , daemon :: Bool , branchstate :: BranchState + , getvectorclock :: IO VectorClock , repoqueue :: Maybe (Git.Queue.Queue Annex) , catfilehandles :: CatFileHandles , hashobjecthandle :: Maybe HashObjectHandle @@ -139,7 +145,8 @@ , sshstalecleaned :: TMVar Bool , flags :: M.Map String Bool , fields :: M.Map String String - , cleanup :: M.Map CleanupAction (Annex ()) + , cleanupactions :: M.Map CleanupAction (Annex ()) + , signalactions :: TVar (M.Map SignalAction (Int -> IO ())) , sentinalstatus :: Maybe SentinalStatus , useragent :: Maybe String , errcounter :: Integer @@ -156,20 +163,25 @@ , cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) , urloptions :: Maybe UrlOptions , insmudgecleanfilter :: Bool + , transferrerpool :: TransferrerPool } newState :: GitConfig -> Git.Repo -> IO AnnexState newState c r = do emptyactiveremotes <- newMVar M.empty emptyactivekeys <- newTVarIO M.empty + si <- newTVarIO M.empty o <- newMessageState sc <- newTMVarIO False kh <- Keys.newDbHandle + tp <- newTransferrerPool + vc <- startVectorClock return $ AnnexState { repo = r , repoadjustment = return , gitconfig = c , gitconfigadjustment = id + , gitconfigoverride = [] , gitremotes = Nothing , backend = Nothing , remotes = [] @@ -179,6 +191,7 @@ , fast = False , daemon = False , branchstate = startBranchState + , getvectorclock = vc , repoqueue = Nothing , catfilehandles = catFileHandlesNonConcurrent , hashobjecthandle = Nothing @@ -200,7 +213,8 @@ , sshstalecleaned = sc , flags = M.empty , fields = M.empty - , cleanup = M.empty + , cleanupactions = M.empty + , signalactions = si , sentinalstatus = Nothing , useragent = Nothing , errcounter = 0 @@ -217,6 +231,7 @@ , cachedgitenv = Nothing , urloptions = Nothing , insmudgecleanfilter = False + , transferrerpool = tp } {- Makes an Annex state object for the specified git repo. @@ -285,9 +300,9 @@ s { fields = M.insert field value $ fields s } {- Adds a cleanup action to perform. -} -addCleanup :: CleanupAction -> Annex () -> Annex () -addCleanup k a = changeState $ \s -> - s { cleanup = M.insert k a $ cleanup s } +addCleanupAction :: CleanupAction -> Annex () -> Annex () +addCleanupAction k a = changeState $ \s -> + s { cleanupactions = M.insert k a $ cleanupactions s } {- Sets the type of output to emit. -} setOutput :: OutputType -> Annex () @@ -345,12 +360,14 @@ changeGitRepo =<< gitRepo {- Adds git config setting, like "foo=bar". It will be passed with -c - - to git processes. The config setting is also recorded in the repo, + - to git processes. The config setting is also recorded in the Repo, - and the GitConfig is updated. -} addGitConfigOverride :: String -> Annex () -addGitConfigOverride v = adjustGitRepo $ \r -> - Git.Config.store (encodeBS' v) Git.Config.ConfigList $ - r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) } +addGitConfigOverride v = do + adjustGitRepo $ \r -> + Git.Config.store (encodeBS' v) Git.Config.ConfigList $ + r { Git.gitGlobalOpts = go (Git.gitGlobalOpts r) } + changeState $ \s -> s { gitconfigoverride = v : gitconfigoverride s } where -- Remove any prior occurrance of the setting to avoid -- building up many of them when the adjustment is run repeatedly, @@ -358,6 +375,10 @@ go [] = [Param "-c", Param v] go (Param "-c": Param v':rest) | v' == v = go rest go (c:rest) = c : go rest + +{- Values that were passed to addGitConfigOverride. -} +getGitConfigOverrides :: Annex [String] +getGitConfigOverrides = reverse <$> getState gitconfigoverride {- Changing the git Repo data also involves re-extracting its GitConfig. -} changeGitRepo :: Git.Repo -> Annex () diff --git a/Annex/Action.hs b/Annex/Action.hs --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -1,14 +1,19 @@ {- git-annex actions - - - Copyright 2010-2015 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.Action ( + action, + verifiedAction, startup, shutdown, stopCoProcesses, + stopNonConcurrentSafeCoProcesses, ) where import qualified Data.Map as M @@ -20,21 +25,73 @@ import Annex.CheckAttr import Annex.HashObject import Annex.CheckIgnore +import Annex.TransferrerPool +import Control.Concurrent.STM +#ifndef mingw32_HOST_OS +import System.Posix.Signals +#endif + +{- Runs an action that may throw exceptions, catching and displaying them. -} +action :: Annex () -> Annex Bool +action a = tryNonAsync a >>= \case + Right () -> return True + Left e -> do + warning (show e) + return False + +verifiedAction :: Annex Verification -> Annex (Bool, Verification) +verifiedAction a = tryNonAsync a >>= \case + Right v -> return (True, v) + Left e -> do + warning (show e) + return (False, UnVerified) + + {- Actions to perform each time ran. -} startup :: Annex () -startup = return () +startup = do +#ifndef mingw32_HOST_OS + av <- Annex.getState Annex.signalactions + let propagate sig = liftIO $ installhandleronce sig av + propagate sigINT + propagate sigQUIT + propagate sigTERM + propagate sigTSTP + propagate sigCONT + propagate sigHUP + -- sigWINCH is not propagated; it should not be needed, + -- and the concurrent-output library installs its own signal + -- handler for it. + -- sigSTOP and sigKILL cannot be caught, so will not be propagated. + where + installhandleronce sig av = void $ + installHandler sig (CatchOnce (gotsignal sig av)) Nothing + gotsignal sig av = do + mapM_ (\a -> a (fromIntegral sig)) =<< atomically (readTVar av) + raiseSignal sig + installhandleronce sig av +#else + return () +#endif {- Cleanup actions. -} shutdown :: Bool -> Annex () shutdown nocommit = do saveState nocommit - sequence_ =<< M.elems <$> Annex.getState Annex.cleanup + sequence_ =<< M.elems <$> Annex.getState Annex.cleanupactions stopCoProcesses -{- Stops all long-running git query processes. -} +{- Stops all long-running child processes, including git query processes. -} stopCoProcesses :: Annex () stopCoProcesses = do + stopNonConcurrentSafeCoProcesses + emptyTransferrerPool + +{- Stops long-running child processes that use handles that are not safe + - for multiple threads to access at the same time. -} +stopNonConcurrentSafeCoProcesses :: Annex () +stopNonConcurrentSafeCoProcesses = do catFileStop checkAttrStop hashObjectStop diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -296,7 +296,7 @@ unless (adjustmentIsStable adj) $ ifM (checkcounter n) ( update adj origbranch - , Annex.addCleanup AdjustedBranchUpdate $ + , Annex.addCleanupAction AdjustedBranchUpdate $ adjustedBranchRefreshFull adj origbranch ) _ -> return () diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -99,9 +99,9 @@ - Also closes various handles in it. -} mergeState :: AnnexState -> Annex () mergeState st = do - st' <- liftIO $ snd <$> run st stopCoProcesses - forM_ (M.toList $ Annex.cleanup st') $ - uncurry addCleanup + st' <- liftIO $ snd <$> run st stopNonConcurrentSafeCoProcesses + forM_ (M.toList $ Annex.cleanupactions st') $ + uncurry addCleanupAction Annex.Queue.mergeFrom st' changeState $ \s -> s { errcounter = errcounter s + errcounter st' } diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -227,12 +227,7 @@ else verification if ok then ifM (verifyKeyContent rsp v verification' key tmpfile) - ( ifM (pruneTmpWorkDirBefore tmpfile (moveAnnex key af)) - ( do - logStatus key InfoPresent - return True - , return False - ) + ( pruneTmpWorkDirBefore tmpfile (moveAnnex key af) , do warning "verification of content failed" -- The bad content is not retained, because diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -11,7 +11,7 @@ import qualified Annex import Logs.Trust import Annex.NumCopies -import Types.Remote (uuid, appendonly, config) +import Types.Remote (uuid, appendonly, config, remotetype, thirdPartyPopulated) import qualified Remote import qualified Command.Drop import Command @@ -30,8 +30,9 @@ - and numcopies settings. - - Skips trying to drop from remotes that are appendonly, since those drops - - would presumably fail. Also skips dropping from exporttree remotes, - - which don't allow dropping individual keys. + - would presumably fail. Also skips dropping from exporttree/importtree remotes, + - which don't allow dropping individual keys, and from thirdPartyPopulated + - remotes. - - The UUIDs are ones where the content is believed to be present. - The Remote list can include other remotes that do not have the content; @@ -87,6 +88,8 @@ | uuid r `S.notMember` slocs = go fs rest n | appendonly r = go fs rest n | exportTree (config r) = go fs rest n + | importTree (config r) = go fs rest n + | thirdPartyPopulated (remotetype r) = go fs rest n | checkcopies n (Just $ Remote.uuid r) = dropr fs r n >>= go fs rest | otherwise = pure n diff --git a/Annex/Export.hs b/Annex/Export.hs --- a/Annex/Export.hs +++ b/Annex/Export.hs @@ -43,10 +43,15 @@ warnExportImportConflict :: Remote -> Annex () warnExportImportConflict r = do - ops <- Remote.isImportSupported r >>= return . \case - True -> "exported to and/or imported from" - False -> "exported to" - toplevelWarning True $ - "Conflict detected. Different trees have been " ++ ops ++ - Remote.name r ++ - ". Use git-annex export to resolve this conflict." + isimport <- Remote.isImportSupported r + isexport <- Remote.isExportSupported r + let (ops, resolvcmd) = case (isexport, isimport) of + (False, True) -> ("imported from", "git-annex import") + (True, False) -> ("exported to", "git-annex export") + _ -> ("exported to and/or imported from", "git-annex export") + toplevelWarning True $ unwords + [ "Conflict detected. Different trees have been" + , ops, Remote.name r ++ ". Use" + , resolvcmd + , "to resolve this conflict." + ] diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -72,9 +72,11 @@ checkMatcher matcher mkey afile notpresent notconfigured d | isEmpty matcher = notconfigured | otherwise = case (mkey, afile) of - (Nothing, AssociatedFile (Just file)) -> go =<< fileMatchInfo file - (Just key, _) -> go (MatchingKey key afile) - _ -> d + (_, AssociatedFile (Just file)) -> + go =<< fileMatchInfo file mkey + (Just key, AssociatedFile Nothing) -> + go (MatchingKey key afile) + (Nothing, _) -> d where go mi = checkMatcher' matcher mi notpresent @@ -82,12 +84,13 @@ checkMatcher' matcher mi notpresent = matchMrun matcher $ \o -> matchAction o notpresent mi -fileMatchInfo :: RawFilePath -> Annex MatchInfo -fileMatchInfo file = do +fileMatchInfo :: RawFilePath -> Maybe Key -> Annex MatchInfo +fileMatchInfo file mkey = do matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) return $ MatchingFile FileInfo { matchFile = matchfile , contentFile = Just file + , matchKey = mkey } matchAll :: FileMatcher Annex diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -12,6 +12,7 @@ ImportCommitConfig(..), buildImportCommit, buildImportTrees, + recordImportTree, canImportKeys, importKeys, makeImportMatcher, @@ -37,6 +38,7 @@ import Annex.HashObject import Annex.Transfer import Annex.CheckIgnore +import Annex.VectorClock import Command import Backend import Types.Key @@ -105,6 +107,28 @@ Nothing -> go Nothing Just _ -> go (Just trackingcommit) where + go trackingcommit = do + (imported, updatestate) <- recordImportTree remote importtreeconfig importable + buildImportCommit' remote importcommitconfig trackingcommit imported >>= \case + Just finalcommit -> do + updatestate + return (Just finalcommit) + Nothing -> return Nothing + +{- Builds a tree for an import from a special remote. + - + - Also returns an action that can be used to update + - all the other state to record the import. + -} +recordImportTree + :: Remote + -> ImportTreeConfig + -> ImportableContents (Either Sha Key) + -> Annex (History Sha, Annex ()) +recordImportTree remote importtreeconfig importable = do + imported@(History finaltree _) <- buildImportTrees basetree subdir importable + return (imported, updatestate finaltree) + where basetree = case importtreeconfig of ImportTree -> emptyTree ImportSubTree _ sha -> sha @@ -112,21 +136,12 @@ ImportTree -> Nothing ImportSubTree dir _ -> Just dir - go trackingcommit = do - imported@(History finaltree _) <- - buildImportTrees basetree subdir importable - buildImportCommit' remote importcommitconfig trackingcommit imported >>= \case - Just finalcommit -> do - updatestate finaltree - return (Just finalcommit) - Nothing -> return Nothing - - updatestate committedtree = do + updatestate finaltree = do importedtree <- case subdir of - Nothing -> pure committedtree + Nothing -> pure finaltree Just dir -> let subtreeref = Ref $ - fromRef' committedtree + fromRef' finaltree <> ":" <> getTopFilePath dir in fromMaybe emptyTree @@ -147,7 +162,7 @@ updateexportlog importedtree = do oldexport <- getExport (Remote.uuid remote) - recordExport (Remote.uuid remote) $ ExportChange + recordExport (Remote.uuid remote) importedtree $ ExportChange { oldTreeish = exportedTreeishes oldexport , newTreeish = importedtree } @@ -308,9 +323,10 @@ :: Remote -> ImportTreeConfig -> Bool + -> Bool -> ImportableContents (ContentIdentifier, ByteSize) -> Annex (Maybe (ImportableContents (Either Sha Key))) -importKeys remote importtreeconfig importcontent importablecontents = do +importKeys remote importtreeconfig importcontent thirdpartypopulated importablecontents = do unless (canImportKeys remote importcontent) $ giveup "This remote does not support importing without downloading content." -- This map is used to remember content identifiers that @@ -327,12 +343,23 @@ bracket CIDDb.openDb CIDDb.closeDb $ \db -> do CIDDb.needsUpdateFromLog db >>= maybe noop (CIDDb.updateFromLog db) - go False cidmap importing importablecontents db + (run (go False cidmap importing importablecontents db)) where + -- When not importing content, reuse the same vector + -- clock for all state that's recorded. This can save + -- a little bit of disk space. Individual file downloads + -- while downloading take too long for this optimisation + -- to be safe to do. + run a + | importcontent = a + | otherwise = reuseVectorClockWhile a + go oldversion cidmap importing (ImportableContents l h) db = do largematcher <- largeFilesMatcher jobs <- forM l $ \i -> - startimport cidmap importing db i oldversion largematcher + if thirdpartypopulated + then thirdpartypopulatedimport cidmap db i + else startimport cidmap importing db i oldversion largematcher l' <- liftIO $ forM jobs $ either pure (atomically . takeTMVar) if any isNothing l' @@ -391,6 +418,20 @@ importaction return (Right job) + thirdpartypopulatedimport cidmap db (loc, (cid, sz)) = + case Remote.importKey ia of + Nothing -> return $ Left Nothing + Just importkey -> + tryNonAsync (importkey loc cid sz nullMeterUpdate) >>= \case + Right (Just k) -> do + recordcidkey cidmap db cid k + logChange k (Remote.uuid remote) InfoPresent + return $ Left $ Just (loc, Right k) + Right Nothing -> return $ Left Nothing + Left e -> do + warning (show e) + return $ Left Nothing + importordownload cidmap db (loc, (cid, sz)) largematcher= do f <- locworktreefile loc matcher <- largematcher f @@ -433,25 +474,22 @@ return Nothing where importer = do - unsizedk <- importkey loc cid - -- Don't display progress when generating - -- key, if the content will later be - -- downloaded, which is a more expensive - -- operation generally. - (if importcontent then nullMeterUpdate else p) - -- This avoids every remote needing - -- to add the size. - let k = alterKey unsizedk $ \kd -> kd - { keySize = keySize kd <|> Just sz } - checkSecureHashes k >>= \case - Nothing -> do - recordcidkey cidmap db cid k - logChange k (Remote.uuid remote) InfoPresent - if importcontent - then getcontent k - else return (Just (k, True)) - Just msg -> giveup (msg ++ " to import") - + -- Don't display progress when generating + -- key, if the content will later be + -- downloaded, which is a more expensive + -- operation generally. + let p' = if importcontent then nullMeterUpdate else p + importkey loc cid sz p' >>= \case + Nothing -> return Nothing + Just k -> checkSecureHashes k >>= \case + Nothing -> do + recordcidkey cidmap db cid k + logChange k (Remote.uuid remote) InfoPresent + if importcontent + then getcontent k + else return (Just (k, True)) + Just msg -> giveup (msg ++ " to import") + getcontent :: Key -> Annex (Maybe (Key, Bool)) getcontent k = do let af = AssociatedFile (Just f) @@ -466,7 +504,7 @@ return (Just (k', ok)) checkDiskSpaceToGet k Nothing $ notifyTransfer Download af $ - download (Remote.uuid remote) k af stdRetry $ \p' -> + download' (Remote.uuid remote) k af stdRetry $ \p' -> withTmp k $ downloader p' -- The file is small, so is added to git, so while importing @@ -520,7 +558,7 @@ return Nothing checkDiskSpaceToGet tmpkey Nothing $ notifyTransfer Download af $ - download (Remote.uuid remote) tmpkey af stdRetry $ \p -> + download' (Remote.uuid remote) tmpkey af stdRetry $ \p -> withTmp tmpkey $ \tmpfile -> metered (Just p) tmpkey $ const (rundownload tmpfile) @@ -531,6 +569,7 @@ let mi = MatchingFile FileInfo { matchFile = f , contentFile = Just tmpfile + , matchKey = Nothing } islargefile <- checkMatcher' matcher mi mempty if islargefile @@ -629,14 +668,17 @@ - regardless. (Similar to how git add behaves on gitignored files.) - This avoids creating a remote tracking branch that, when merged, - would delete the files. + - + - Throws exception if unable to contact the remote. + - Returns Nothing when there is no change since last time. -} getImportableContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> FileMatcher Annex -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) -getImportableContents r importtreeconfig ci matcher = +getImportableContents r importtreeconfig ci matcher = do Remote.listImportableContents (Remote.importActions r) >>= \case - Nothing -> return Nothing Just importable -> do dbhandle <- Export.openDb (Remote.uuid r) Just <$> filterunwanted dbhandle importable + Nothing -> return Nothing where filterunwanted dbhandle ic = ImportableContents <$> filterM (wanted dbhandle) (importableContents ic) diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -378,6 +378,7 @@ Just tmp -> MatchingFile $ FileInfo { contentFile = Just tmp , matchFile = file + , matchKey = Just key } -- Provide as much info as we can without access to the -- file's content. diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -65,8 +65,8 @@ import Control.Concurrent.Async #endif -checkCanInitialize :: Annex a -> Annex a -checkCanInitialize a = canInitialize' >>= \case +checkInitializeAllowed :: Annex a -> Annex a +checkInitializeAllowed a = noAnnexFileContent' >>= \case Nothing -> a Just noannexmsg -> do warning "Initialization prevented by .noannex file (remove the file to override)" @@ -74,11 +74,12 @@ warning noannexmsg giveup "Not initialized." -canInitialize :: Annex Bool -canInitialize = isNothing <$> canInitialize' +initializeAllowed :: Annex Bool +initializeAllowed = isNothing <$> noAnnexFileContent' -canInitialize' :: Annex (Maybe String) -canInitialize' = inRepo (noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree) +noAnnexFileContent' :: Annex (Maybe String) +noAnnexFileContent' = inRepo $ + noAnnexFileContent . fmap fromRawFilePath . Git.repoWorkTree genDescription :: Maybe String -> Annex UUIDDesc genDescription (Just d) = return $ UUIDDesc $ encodeBS d @@ -94,7 +95,7 @@ Left _ -> [hostname, ":", reldir] initialize :: Maybe String -> Maybe RepoVersion -> Annex () -initialize mdescription mversion = checkCanInitialize $ do +initialize mdescription mversion = checkInitializeAllowed $ do {- Has to come before any commits are made as the shared - clone heuristic expects no local objects. -} sharedclone <- checkSharedClone @@ -117,7 +118,7 @@ -- Everything except for uuid setup, shared clone setup, and initial -- description. initialize' :: Maybe RepoVersion -> Annex () -initialize' mversion = checkCanInitialize $ do +initialize' mversion = checkInitializeAllowed $ do checkLockSupport checkFifoSupport checkCrippledFileSystem @@ -158,6 +159,29 @@ removeRepoUUID removeVersion +{- Gets the version that the repo is initialized with. + - + - To make sure the repo is fully initialized, also checks that it has a + - uuid configured. In the unusual case where one is set and the other is + - not, errors out to avoid running in an inconsistent state. + -} +getInitializedVersion :: Annex (Maybe RepoVersion) +getInitializedVersion = do + um <- (\u -> if u == NoUUID then Nothing else Just u) <$> getUUID + vm <- getVersion + case (um, vm) of + (Just _, Just v) -> return (Just v) + (Nothing, Nothing) -> return Nothing + (Just _, Nothing) -> onemissing "annex.version" "annex.uuid" + (Nothing, Just _) -> onemissing "annex.uuid" "annex.version" + where + onemissing missing have = giveup $ unwords + [ "This repository has " ++ have ++ " set," + , "but " ++ missing ++ " is not set. Perhaps that" + , "git config was lost. Cannot use the repository" + , "in this state; set back " ++ missing ++ " to fix this." + ] + {- Will automatically initialize if there is already a git-annex - branch from somewhere. Otherwise, require a manual init - to avoid git-annex accidentally being run in git @@ -166,23 +190,44 @@ - Checks repository version and handles upgrades too. -} ensureInitialized :: Annex () -ensureInitialized = getVersion >>= maybe needsinit checkUpgrade +ensureInitialized = getInitializedVersion >>= maybe needsinit checkUpgrade where - needsinit = ifM Annex.Branch.hasSibling + needsinit = ifM autoInitializeAllowed ( do initialize Nothing Nothing autoEnableSpecialRemotes , giveup "First run: git-annex init" ) -{- Initialize if it can do so automatically. +{- Check if auto-initialize is allowed. -} +autoInitializeAllowed :: Annex Bool +autoInitializeAllowed = Annex.Branch.hasSibling <&&> objectDirNotPresent + +objectDirNotPresent :: Annex Bool +objectDirNotPresent = do + d <- fromRawFilePath <$> fromRepo gitAnnexObjectDir + exists <- liftIO $ doesDirectoryExist d + when exists $ + giveup $ unwords $ + [ "This repository is not initialized for use" + , "by git-annex, but " ++ d ++ " exists," + , "which indicates this repository was used by" + , "git-annex before, and may have lost its" + , "annex.uuid and annex.version configs. Either" + , "set back missing configs, or run git-annex init" + , "to initialize with a new uuid." + ] + return (not exists) + +{- Initialize if it can do so automatically. Avoids failing if it cannot. - - Checks repository version and handles upgrades too. -} autoInitialize :: Annex () -autoInitialize = getVersion >>= maybe needsinit checkUpgrade +autoInitialize = getInitializedVersion >>= maybe needsinit checkUpgrade where - needsinit = whenM (canInitialize <&&> Annex.Branch.hasSibling) $ do + needsinit = + whenM (initializeAllowed <&&> autoInitializeAllowed) $ do initialize Nothing Nothing autoEnableSpecialRemotes @@ -252,7 +297,8 @@ probeLockSupport = withEventuallyCleanedOtherTmp $ \tmp -> do let f = tmp P. "lockprobe" mode <- annexFileMode - liftIO $ withAsync warnstall (const (go f mode)) + annexrunner <- Annex.makeRunner + liftIO $ withAsync (warnstall annexrunner) (const (go f mode)) where go f mode = do removeWhenExistsWith R.removeLink f @@ -264,10 +310,11 @@ removeWhenExistsWith R.removeLink f return ok - warnstall = do + warnstall annexrunner = do threadDelaySeconds (Seconds 10) - warningIO "Probing the filesystem for POSIX fcntl lock support is taking a long time." - warningIO "(Setting annex.pidlock will avoid this probe.)" + annexrunner $ do + warning "Probing the filesystem for POSIX fcntl lock support is taking a long time." + warning "(Setting annex.pidlock will avoid this probe.)" #endif probeFifoSupport :: Annex Bool @@ -336,10 +383,8 @@ autoEnableSpecialRemotes :: Annex () autoEnableSpecialRemotes = do rp <- fromRawFilePath <$> fromRepo Git.repoPath - withNullHandle $ \nullh -> gitAnnexChildProcess - [ "init" - , "--autoenable" - ] + withNullHandle $ \nullh -> gitAnnexChildProcess "init" + [ Param "--autoenable" ] (\p -> p { std_out = UseHandle nullh , std_err = UseHandle nullh diff --git a/Annex/MetaData.hs b/Annex/MetaData.hs --- a/Annex/MetaData.hs +++ b/Annex/MetaData.hs @@ -107,7 +107,7 @@ ('>':v) -> checkcmp (>) v _ -> checkglob "" checkglob v = - let cglob = compileGlob v CaseInsensative + let cglob = compileGlob v CaseInsensative (GlobFilePath False) in matchGlob cglob . decodeBS . fromMetaValue checkcmp cmp v v' = case (doubleval v, doubleval (decodeBS (fromMetaValue v'))) of (Just d, Just d') -> d' `cmp` d diff --git a/Annex/Path.hs b/Annex/Path.hs --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -11,6 +11,7 @@ import Config.Files import Utility.Env import Annex.PidLock +import qualified Annex import System.Environment (getExecutablePath) @@ -55,10 +56,22 @@ - to avoid it deadlocking. -} gitAnnexChildProcess - :: [String] + :: String + -> [CommandParam] -> (CreateProcess -> CreateProcess) -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> Annex a -gitAnnexChildProcess ps f a = do +gitAnnexChildProcess subcmd ps f a = do cmd <- liftIO programPath - pidLockChildProcess cmd ps f a + ps' <- gitAnnexChildProcessParams subcmd ps + pidLockChildProcess cmd ps' f a + +{- Parameters to pass to a git-annex child process to run a subcommand + - with some parameters. + - + - Includes -c values that were passed on the git-annex command line. + -} +gitAnnexChildProcessParams :: String -> [CommandParam] -> Annex [CommandParam] +gitAnnexChildProcessParams subcmd ps = do + cps <- concatMap (\c -> [Param "-c", Param c]) <$> Annex.getGitConfigOverrides + return (Param subcmd : cps ++ ps) diff --git a/Annex/PidLock.hs b/Annex/PidLock.hs --- a/Annex/PidLock.hs +++ b/Annex/PidLock.hs @@ -38,12 +38,12 @@ -} pidLockChildProcess :: FilePath - -> [String] + -> [CommandParam] -> (CreateProcess -> CreateProcess) -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> Annex a pidLockChildProcess cmd ps f a = do - let p = f (proc cmd ps) + let p = f (proc cmd (toCommand ps)) let gonopidlock = withCreateProcess p a #ifndef mingw32_HOST_OS pidLockFile >>= liftIO . \case @@ -75,7 +75,7 @@ - - This is like pidLockChildProcess, but rather than running a process - itself, it runs the action with a modified Annex state that passes the - - necessary env var. + - necessary env var when running git. -} runsGitAnnexChildProcessViaGit :: Annex a -> Annex a #ifndef mingw32_HOST_OS diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -230,7 +230,7 @@ sshCleanup liftIO $ atomically $ putTMVar tv True -- Cleanup at shutdown. - Annex.addCleanup SshCachingCleanup sshCleanup + Annex.addCleanupAction SshCachingCleanup sshCleanup let socketlock = socket2lock socketfile diff --git a/Annex/Tmp.hs b/Annex/Tmp.hs --- a/Annex/Tmp.hs +++ b/Annex/Tmp.hs @@ -24,7 +24,7 @@ -- any time. withOtherTmp :: (RawFilePath -> Annex a) -> Annex a withOtherTmp a = do - Annex.addCleanup OtherTmpCleanup cleanupOtherTmp + Annex.addCleanupAction OtherTmpCleanup cleanupOtherTmp tmpdir <- fromRepo gitAnnexTmpOtherDir tmplck <- fromRepo gitAnnexTmpOtherLock withSharedLock (const tmplck) $ do diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -10,13 +10,16 @@ module Annex.Transfer ( module X, upload, + upload', alwaysUpload, download, + download', runTransfer, alwaysRunTransfer, noRetry, stdRetry, pickRemote, + stallDetection, ) where import Annex.Common @@ -24,7 +27,10 @@ import Logs.Transfer as X import Types.Transfer as X import Annex.Notification as X +import Annex.Content import Annex.Perms +import Annex.Action +import Logs.Location import Utility.Metered import Utility.ThreadScheduler import Annex.LockPool @@ -34,7 +40,9 @@ import Annex.Concurrent.Utility import Types.WorkerPool import Annex.WorkerPool +import Annex.TransferrerPool import Backend (isCryptographicallySecure) +import Types.StallDetection import qualified Utility.RawFilePath as R import Control.Concurrent @@ -42,16 +50,36 @@ import qualified System.FilePath.ByteString as P import Data.Ord -upload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v -upload u key f d a _witness = guardHaveUUID u $ +-- Upload, supporting stall detection. +upload :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool +upload r key f d witness = stallDetection r >>= \case + Nothing -> upload' (Remote.uuid r) key f d go witness + Just sd -> runTransferrer sd r key f d Upload witness + where + go = action . Remote.storeKey r key f + +-- Upload, not supporting stall detection. +upload' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v +upload' u key f d a _witness = guardHaveUUID u $ runTransfer (Transfer Upload u (fromKey id key)) f d a alwaysUpload :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v alwaysUpload u key f d a _witness = guardHaveUUID u $ alwaysRunTransfer (Transfer Upload u (fromKey id key)) f d a -download :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v -download u key f d a _witness = guardHaveUUID u $ +-- Download, supporting stall detection. +download :: Remote -> Key -> AssociatedFile -> RetryDecider -> NotifyWitness -> Annex Bool +download r key f d witness = logStatusAfter key $ stallDetection r >>= \case + Nothing -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key f $ \dest -> + download' (Remote.uuid r) key f d (go dest) witness + Just sd -> runTransferrer sd r key f d Download witness + where + go dest p = verifiedAction $ + Remote.retrieveKeyFile r key f (fromRawFilePath dest) p + +-- Download, not supporting stall detection. +download' :: Observable v => UUID -> Key -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> NotifyWitness -> Annex v +download' u key f d a _witness = guardHaveUUID u $ runTransfer (Transfer Download u (fromKey id key)) f d a guardHaveUUID :: Observable v => UUID -> Annex v -> Annex v @@ -81,7 +109,7 @@ alwaysRunTransfer = runTransfer' True runTransfer' :: Observable v => Bool -> Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v -runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ checkSecureHashes t $ do +runTransfer' ignorelock t afile retrydecider transferaction = enteringStage TransferStage $ debugLocks $ preCheckSecureHashes (transferKey t) $ do info <- liftIO $ startTransferInfo afile (meter, tfile, createtfile, metervar) <- mkProgressUpdater t info mode <- annexFileMode @@ -168,6 +196,31 @@ f <- fromRepo $ gitAnnexTmpObjectLocation (transferKey t) liftIO $ catchDefaultIO 0 $ getFileSize f +runTransferrer + :: StallDetection + -> Remote + -> Key + -> AssociatedFile + -> RetryDecider + -> Direction + -> NotifyWitness + -> Annex Bool +runTransferrer sd r k afile retrydecider direction _witness = + enteringStage TransferStage $ preCheckSecureHashes k $ do + info <- liftIO $ startTransferInfo afile + go 0 info + where + go numretries info = + withTransferrer (performTransfer (Just sd) AnnexLevel id (Just r) t info) >>= \case + Right () -> return True + Left newinfo -> do + let !numretries' = succ numretries + ifM (retrydecider numretries' info newinfo) + ( go numretries' newinfo + , return False + ) + t = Transfer direction (Remote.uuid r) (fromKey id k) + {- Avoid download and upload of keys with insecure content when - annex.securehashesonly is configured. - @@ -180,8 +233,8 @@ - still contains content using an insecure hash, remotes will likewise - tend to be configured to reject it, so Upload is also prevented. -} -checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v -checkSecureHashes t a = ifM (isCryptographicallySecure (transferKey t)) +preCheckSecureHashes :: Observable v => Key -> Annex v -> Annex v +preCheckSecureHashes k a = ifM (isCryptographicallySecure k) ( a , ifM (annexSecureHashesOnly <$> Annex.getGitConfig) ( do @@ -191,7 +244,7 @@ ) ) where - variety = fromKey keyVariety (transferKey t) + variety = fromKey keyVariety k type NumRetries = Integer @@ -314,3 +367,9 @@ lessActiveFirst active a b | Remote.cost a == Remote.cost b = comparing (`M.lookup` active) a b | otherwise = comparing Remote.cost a b + +stallDetection :: Remote -> Annex (Maybe StallDetection) +stallDetection r = maybe globalcfg (pure . Just) remotecfg + where + globalcfg = annexStallDetection <$> Annex.getGitConfig + remotecfg = remoteAnnexStallDetection $ Remote.gitconfig r diff --git a/Annex/TransferrerPool.hs b/Annex/TransferrerPool.hs new file mode 100644 --- /dev/null +++ b/Annex/TransferrerPool.hs @@ -0,0 +1,310 @@ +{- A pool of "git-annex transferrer" processes + - + - Copyright 2013-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} + +module Annex.TransferrerPool where + +import Annex.Common +import qualified Annex +import Types.TransferrerPool +import Types.Transferrer +import Types.Transfer +import qualified Types.Remote as Remote +import Types.StallDetection +import Types.Messages +import Types.CleanupActions +import Messages.Serialized +import Annex.Path +import Utility.Batch +import Utility.Metered +import Utility.HumanTime +import Utility.ThreadScheduler +import qualified Utility.SimpleProtocol as Proto + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM hiding (check) +import Control.Monad.IO.Class (MonadIO) +import System.Log.Logger (debugM) +import qualified Data.Map as M +#ifndef mingw32_HOST_OS +import System.Posix.Signals +import System.Posix.Process (getProcessGroupIDOf) +#endif + +type SignalActionsVar = TVar (M.Map SignalAction (Int -> IO ())) + +data RunTransferrer = RunTransferrer String [CommandParam] BatchCommandMaker + +mkRunTransferrer :: BatchCommandMaker -> Annex RunTransferrer +mkRunTransferrer batchmaker = RunTransferrer + <$> liftIO programPath + <*> gitAnnexChildProcessParams "transferrer" [] + <*> pure batchmaker + +{- Runs an action with a Transferrer from the pool. -} +withTransferrer :: (Transferrer -> Annex a) -> Annex a +withTransferrer a = do + rt <- mkRunTransferrer nonBatchCommandMaker + pool <- Annex.getState Annex.transferrerpool + let nocheck = pure (pure True) + signalactonsvar <- Annex.getState Annex.signalactions + withTransferrer' False signalactonsvar nocheck rt pool a + +withTransferrer' + :: (MonadIO m, MonadMask m) + => Bool + -- ^ When minimizeprocesses is True, only one Transferrer is left + -- running in the pool at a time. So if this needed to start a + -- new Transferrer, it's stopped when done. Otherwise, idle + -- processes are left in the pool for use later. + -> SignalActionsVar + -> MkCheckTransferrer + -> RunTransferrer + -> TransferrerPool + -> (Transferrer -> m a) + -> m a +withTransferrer' minimizeprocesses signalactonsvar mkcheck rt pool a = do + (mi, leftinpool) <- liftIO $ atomically (popTransferrerPool pool) + (i@(TransferrerPoolItem _ check), t) <- liftIO $ case mi of + Nothing -> do + t <- mkTransferrer signalactonsvar rt + i <- mkTransferrerPoolItem mkcheck t + return (i, t) + Just i -> checkTransferrerPoolItem signalactonsvar rt i + a t `finally` returntopool leftinpool check t i + where + returntopool leftinpool check t i + | not minimizeprocesses || leftinpool == 0 = + -- If the transferrer got killed, the handles will + -- be closed, so it should not be returned to the + -- pool. + liftIO $ whenM (hIsOpen (transferrerWrite t)) $ + liftIO $ atomically $ pushTransferrerPool pool i + | otherwise = liftIO $ do + void $ forkIO $ transferrerShutdown t + atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check + +{- Check if a Transferrer from the pool is still ok to be used. + - If not, stop it and start a new one. -} +checkTransferrerPoolItem :: SignalActionsVar -> RunTransferrer -> TransferrerPoolItem -> IO (TransferrerPoolItem, Transferrer) +checkTransferrerPoolItem signalactonsvar rt i = case i of + TransferrerPoolItem (Just t) check -> ifM check + ( return (i, t) + , do + transferrerShutdown t + new check + ) + TransferrerPoolItem Nothing check -> new check + where + new check = do + t <- mkTransferrer signalactonsvar rt + return (TransferrerPoolItem (Just t) check, t) + +data TransferRequestLevel = AnnexLevel | AssistantLevel + deriving (Show) + +{- Requests that a Transferrer perform a Transfer, and waits for it to + - finish. + - + - When a stall is detected, kills the Transferrer. + - + - If the transfer failed or stalled, returns TransferInfo with an + - updated bytesComplete reflecting how much data has been transferred. + -} +performTransfer + :: (Monad m, MonadIO m, MonadMask m) + => Maybe StallDetection + -> TransferRequestLevel + -> (forall a. Annex a -> m a) + -- ^ Run an annex action in the monad. Will not be used with + -- actions that block for a long time. + -> Maybe Remote + -> Transfer + -> TransferInfo + -> Transferrer + -> m (Either TransferInfo ()) +performTransfer stalldetection level runannex r t info transferrer = do + bpv <- liftIO $ newTVarIO zeroBytesProcessed + ifM (catchBoolIO $ bracket setup cleanup (go bpv)) + ( return (Right ()) + , do + n <- case transferDirection t of + Upload -> liftIO $ atomically $ + fromBytesProcessed <$> readTVar bpv + Download -> do + f <- runannex $ fromRepo $ gitAnnexTmpObjectLocation (transferKey t) + liftIO $ catchDefaultIO 0 $ getFileSize f + return $ Left $ info { bytesComplete = Just n } + ) + where + setup = do + liftIO $ sendRequest level t r + (associatedFile info) + (transferrerWrite transferrer) + metervar <- liftIO $ newTVarIO Nothing + stalledvar <- liftIO $ newTVarIO False + tid <- liftIO $ async $ + detectStalls stalldetection metervar $ do + atomically $ writeTVar stalledvar True + killTransferrer transferrer + return (metervar, tid, stalledvar) + + cleanup (_, tid, stalledvar) = do + liftIO $ uninterruptibleCancel tid + whenM (liftIO $ atomically $ readTVar stalledvar) $ do + runannex $ showLongNote "Transfer stalled" + -- Close handles, to prevent the transferrer being + -- reused since the process was killed. + liftIO $ hClose $ transferrerRead transferrer + liftIO $ hClose $ transferrerWrite transferrer + + go bpv (metervar, _, _) = relaySerializedOutput + (liftIO $ readResponse (transferrerRead transferrer)) + (liftIO . sendSerializedOutputResponse (transferrerWrite transferrer)) + (updatemeter bpv metervar) + runannex + + updatemeter bpv metervar (Just n) = liftIO $ do + atomically $ writeTVar metervar (Just n) + atomically $ writeTVar bpv n + updatemeter _bpv metervar Nothing = liftIO $ + atomically $ writeTVar metervar Nothing + +detectStalls :: Maybe StallDetection -> TVar (Maybe BytesProcessed) -> IO () -> IO () +detectStalls Nothing _ _ = noop +detectStalls (Just (StallDetection minsz duration)) metervar onstall = go Nothing + where + go st = do + threadDelaySeconds (Seconds (fromIntegral (durationSeconds duration))) + -- Get whatever progress value was reported last, if any. + v <- atomically $ fmap fromBytesProcessed + <$> readTVar metervar + let cont = go v + case (st, v) of + (Nothing, _) -> cont + (_, Nothing) -> cont + (Just prev, Just sofar) + -- Just in case a progress meter somehow runs + -- backwards, or a second progress meter was + -- started and is at a smaller value than + -- the previous one. + | prev > sofar -> cont + | sofar - prev < minsz -> onstall + | otherwise -> cont + +{- Starts a new git-annex transfer process, setting up handles + - that will be used to communicate with it. -} +mkTransferrer :: SignalActionsVar -> RunTransferrer -> IO Transferrer +mkTransferrer signalactonsvar (RunTransferrer program params batchmaker) = do + {- It runs as a batch job. -} + let (program', params') = batchmaker (program, params) + {- It's put into its own group so that the whole group can be + - killed to stop a transfer. -} + (Just writeh, Just readh, _, ph) <- createProcess + (proc program' $ toCommand params') + { create_group = True + , std_in = CreatePipe + , std_out = CreatePipe + } + + {- Set up signal propagation, so eg ctrl-c will also interrupt + - the processes in the transferrer's process group. + - + - There is a race between the process being created and this point. + - If a signal is received before this can run, it is not sent to + - the transferrer. This leaves the transferrer waiting for the + - first message on stdin to tell what to do. If the signal kills + - this parent process, the transferrer will then get a sigpipe + - and die too. If the signal suspends this parent process, + - it's ok to leave the transferrer running, as it's waiting on + - the pipe until this process wakes back up. + -} +#ifndef mingw32_HOST_OS + pid <- getPid ph + unregistersignalprop <- case pid of + Just p -> getProcessGroupIDOf p >>= \pgrp -> do + atomically $ modifyTVar' signalactonsvar $ + M.insert (PropagateSignalProcessGroup p) $ \sig -> + signalProcessGroup (fromIntegral sig) pgrp + return $ atomically $ modifyTVar' signalactonsvar $ + M.delete (PropagateSignalProcessGroup p) + Nothing -> return noop +#else + let unregistersignalprop = noop +#endif + + return $ Transferrer + { transferrerRead = readh + , transferrerWrite = writeh + , transferrerHandle = ph + , transferrerShutdown = do + hClose readh + hClose writeh + void $ waitForProcess ph + unregistersignalprop + } + +-- | Send a request to perform a transfer. +sendRequest :: TransferRequestLevel -> Transfer -> Maybe Remote -> AssociatedFile -> Handle -> IO () +sendRequest level t mremote afile h = do + let tr = maybe + (TransferRemoteUUID (transferUUID t)) + (TransferRemoteName . Remote.name) + mremote + let f = case (level, transferDirection t) of + (AnnexLevel, Upload) -> UploadRequest + (AnnexLevel, Download) -> DownloadRequest + (AssistantLevel, Upload) -> AssistantUploadRequest + (AssistantLevel, Download) -> AssistantDownloadRequest + let r = f tr (transferKey t) (TransferAssociatedFile afile) + let l = unwords $ Proto.formatMessage r + debugM "transfer" ("> " ++ l) + hPutStrLn h l + hFlush h + +sendSerializedOutputResponse :: Handle -> SerializedOutputResponse -> IO () +sendSerializedOutputResponse h sor = do + let l = unwords $ Proto.formatMessage $ + TransferSerializedOutputResponse sor + debugM "transfer" ("> " ++ show l) + hPutStrLn h l + hFlush h + +-- | Read a response to a transfer request. +-- +-- Before the final response, this will return whatever SerializedOutput +-- should be displayed as the transfer is performed. +readResponse :: Handle -> IO (Either SerializedOutput Bool) +readResponse h = do + l <- liftIO $ hGetLine h + debugM "transfer" ("< " ++ l) + case Proto.parseMessage l of + Just (TransferOutput so) -> return (Left so) + Just (TransferResult r) -> return (Right r) + Nothing -> transferrerProtocolError l + +transferrerProtocolError :: String -> a +transferrerProtocolError l = giveup $ "transferrer protocol error: " ++ show l + +{- Kill the transferrer, and all its child processes. -} +killTransferrer :: Transferrer -> IO () +killTransferrer t = do + interruptProcessGroupOf $ transferrerHandle t + threadDelay 50000 -- 0.05 second grace period + terminateProcess $ transferrerHandle t + +{- Stop all transferrers in the pool. -} +emptyTransferrerPool :: Annex () +emptyTransferrerPool = do + poolvar <- Annex.getState Annex.transferrerpool + pool <- liftIO $ atomically $ swapTVar poolvar [] + liftIO $ forM_ pool $ \case + TransferrerPoolItem (Just t) _ -> transferrerShutdown t + TransferrerPoolItem Nothing _ -> noop diff --git a/Annex/VectorClock.hs b/Annex/VectorClock.hs --- a/Annex/VectorClock.hs +++ b/Annex/VectorClock.hs @@ -3,42 +3,54 @@ - We don't have a way yet to keep true distributed vector clocks. - The next best thing is a timestamp. - - - Copyright 2017-2019 Joey Hess + - Copyright 2017-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -module Annex.VectorClock where - -import Data.Time.Clock.POSIX -import Data.ByteString.Builder -import Control.Applicative -import Prelude +module Annex.VectorClock ( + module Annex.VectorClock, + module Types.VectorClock, +) where -import Utility.Env +import Types.VectorClock +import Annex.Common +import qualified Annex import Utility.TimeStamp -import Utility.QuickCheck + +import Data.ByteString.Builder import qualified Data.Attoparsec.ByteString.Lazy as A --- | Some very old logs did not have any time stamp at all; --- Unknown is used for those. -data VectorClock = Unknown | VectorClock POSIXTime - deriving (Eq, Ord, Show) +currentVectorClock :: Annex VectorClock +currentVectorClock = liftIO =<< Annex.getState Annex.getvectorclock --- Unknown is oldest. -prop_VectorClock_sane :: Bool -prop_VectorClock_sane = Unknown < VectorClock 1 +-- Runs the action and uses the same vector clock throughout. +-- +-- When the action modifies several files in the git-annex branch, +-- this can cause less space to be used, since the same vector clock +-- value is used, which can compress better. +-- +-- However, this should not be used when running a long-duration action, +-- because the vector clock is based on the start of the action, and not on +-- the later points where it writes changes. For example, if this were +-- used across downloads of several files, the location log information +-- would have an earlier vector clock than necessary, which might cause it +-- to be disregarded in favor of other information that was collected +-- at an earlier point in time than when the transfers completted and the +-- log was written. +reuseVectorClockWhile :: Annex a -> Annex a +reuseVectorClockWhile = bracket setup cleanup . const + where + setup = do + origget <- Annex.getState Annex.getvectorclock + vc <- liftIO origget + use (pure vc) + return origget -instance Arbitrary VectorClock where - arbitrary = VectorClock <$> arbitrary + cleanup origget = use origget -currentVectorClock :: IO VectorClock -currentVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK" - where - go Nothing = VectorClock <$> getPOSIXTime - go (Just s) = case parsePOSIXTime s of - Just t -> return (VectorClock t) - Nothing -> VectorClock <$> getPOSIXTime + use vc = Annex.changeState $ \s -> + s { Annex.getvectorclock = vc } formatVectorClock :: VectorClock -> String formatVectorClock Unknown = "0" diff --git a/Annex/VectorClock/Utility.hs b/Annex/VectorClock/Utility.hs new file mode 100644 --- /dev/null +++ b/Annex/VectorClock/Utility.hs @@ -0,0 +1,23 @@ +{- git-annex vector clock utilities + - + - Copyright 2017-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Annex.VectorClock.Utility where + +import Data.Time.Clock.POSIX + +import Types.VectorClock +import Utility.Env +import Utility.TimeStamp + +startVectorClock :: IO (IO VectorClock) +startVectorClock = go =<< getEnv "GIT_ANNEX_VECTOR_CLOCK" + where + go Nothing = timebased + go (Just s) = case parsePOSIXTime s of + Just t -> return (pure (VectorClock t)) + Nothing -> timebased + timebased = return (VectorClock <$> getPOSIXTime) diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -163,11 +163,11 @@ combineViewFilter (FilterValues _) newglob@(FilterGlob _) = (newglob, Widening) combineViewFilter (FilterGlob oldglob) new@(FilterValues s) - | all (matchGlob (compileGlob oldglob CaseInsensative) . decodeBS . fromMetaValue) (S.toList s) = (new, Narrowing) + | all (matchGlob (compileGlob oldglob CaseInsensative (GlobFilePath False)) . decodeBS . fromMetaValue) (S.toList s) = (new, Narrowing) | otherwise = (new, Widening) combineViewFilter (FilterGlob old) newglob@(FilterGlob new) | old == new = (newglob, Unchanged) - | matchGlob (compileGlob old CaseInsensative) new = (newglob, Narrowing) + | matchGlob (compileGlob old CaseInsensative (GlobFilePath False)) new = (newglob, Narrowing) | otherwise = (newglob, Widening) combineViewFilter (FilterGlob _) new@(ExcludeValues _) = (new, Narrowing) combineViewFilter (ExcludeValues _) new@(FilterGlob _) = (new, Widening) @@ -216,7 +216,7 @@ FilterValues s -> \values -> setmatches $ S.intersection s values FilterGlob glob -> - let cglob = compileGlob glob CaseInsensative + let cglob = compileGlob glob CaseInsensative (GlobFilePath False) in \values -> setmatches $ S.filter (matchGlob cglob . decodeBS . fromMetaValue) values ExcludeValues excludes -> \values -> diff --git a/Assistant/DaemonStatus.hs b/Assistant/DaemonStatus.hs --- a/Assistant/DaemonStatus.hs +++ b/Assistant/DaemonStatus.hs @@ -56,7 +56,9 @@ let syncable = filter good rs contentremotes <- filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) $ filter (\r -> Remote.uuid r /= NoUUID) syncable - let (exportremotes, dataremotes) = partition (exportTree . Remote.config) contentremotes + let (exportremotes, nonexportremotes) = partition (exportTree . Remote.config) contentremotes + let isimport r = importTree (Remote.config r) || Remote.thirdPartyPopulated (Remote.remotetype r) + let dataremotes = filter (not . isimport) nonexportremotes return $ \dstatus -> dstatus { syncRemotes = syncable diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -35,7 +35,6 @@ import Assistant.Types.ScanRemotes import Assistant.Types.TransferQueue import Assistant.Types.TransferSlots -import Assistant.Types.TransferrerPool import Assistant.Types.Pushes import Assistant.Types.BranchChange import Assistant.Types.Commits @@ -65,7 +64,6 @@ , scanRemoteMap :: ScanRemoteMap , transferQueue :: TransferQueue , transferSlots :: TransferSlots - , transferrerPool :: TransferrerPool , failedPushMap :: FailedPushMap , failedExportMap :: FailedPushMap , commitChan :: CommitChan @@ -85,7 +83,6 @@ <*> newScanRemoteMap <*> newTransferQueue <*> newTransferSlots - <*> newTransferrerPool (checkNetworkConnections dstatus) <*> newFailedPushMap <*> newFailedPushMap <*> newCommitChan diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -11,15 +11,15 @@ import Assistant.TransferQueue import Assistant.TransferSlots import Types.Transfer -import Annex.Path +import Annex.TransferrerPool import Utility.Batch {- Dispatches transfers from the queue. -} transfererThread :: NamedThread transfererThread = namedThread "Transferrer" $ do - program <- liftIO programPath - batchmaker <- liftIO getBatchCommandMaker - forever $ inTransferSlot program batchmaker $ + rt <- liftAnnex . mkRunTransferrer + =<< liftIO getBatchCommandMaker + forever $ inTransferSlot rt $ maybe (return Nothing) (uncurry genTransfer) =<< getNextTransfer notrunning where diff --git a/Assistant/TransferSlots.hs b/Assistant/TransferSlots.hs --- a/Assistant/TransferSlots.hs +++ b/Assistant/TransferSlots.hs @@ -1,6 +1,6 @@ {- git-annex assistant transfer slots - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -9,30 +9,35 @@ module Assistant.TransferSlots where +import Control.Concurrent.STM + import Assistant.Common import Utility.ThreadScheduler +import Utility.NotificationBroadcaster import Assistant.Types.TransferSlots import Assistant.DaemonStatus -import Assistant.TransferrerPool -import Assistant.Types.TransferrerPool +import Annex.TransferrerPool +import Types.TransferrerPool import Assistant.Types.TransferQueue import Assistant.TransferQueue import Assistant.Alert import Assistant.Alert.Utility import Assistant.Commits import Assistant.Drop +import Annex.Transfer (stallDetection) import Types.Transfer import Logs.Transfer import Logs.Location import qualified Git +import qualified Annex import qualified Remote import qualified Types.Remote as Remote import Annex.Content import Annex.Wanted -import Annex.Path import Utility.Batch import Types.NumCopies +import Data.Either import qualified Data.Map as M import qualified Control.Exception as E import Control.Concurrent @@ -49,17 +54,17 @@ {- Waits until a transfer slot becomes available, then runs a - TransferGenerator, and then runs the transfer action in its own thread. -} -inTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant () -inTransferSlot program batchmaker gen = do +inTransferSlot :: RunTransferrer -> TransferGenerator -> Assistant () +inTransferSlot rt gen = do flip MSemN.wait 1 <<~ transferSlots - runTransferThread program batchmaker =<< gen + runTransferThread rt =<< gen {- Runs a TransferGenerator, and its transfer action, - without waiting for a slot to become available. -} -inImmediateTransferSlot :: FilePath -> BatchCommandMaker -> TransferGenerator -> Assistant () -inImmediateTransferSlot program batchmaker gen = do +inImmediateTransferSlot :: RunTransferrer -> TransferGenerator -> Assistant () +inImmediateTransferSlot rt gen = do flip MSemN.signal (-1) <<~ transferSlots - runTransferThread program batchmaker =<< gen + runTransferThread rt =<< gen {- Runs a transfer action, in an already allocated transfer slot. - Once it finishes, frees the transfer slot. @@ -71,20 +76,25 @@ - then pausing the thread until a ResumeTransfer exception is raised, - then rerunning the action. -} -runTransferThread :: FilePath -> BatchCommandMaker -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant () -runTransferThread _ _ Nothing = flip MSemN.signal 1 <<~ transferSlots -runTransferThread program batchmaker (Just (t, info, a)) = do +runTransferThread :: RunTransferrer -> Maybe (Transfer, TransferInfo, Transferrer -> Assistant ()) -> Assistant () +runTransferThread _ Nothing = flip MSemN.signal 1 <<~ transferSlots +runTransferThread rt (Just (t, info, a)) = do d <- getAssistant id + mkcheck <- checkNetworkConnections + <$> getAssistant daemonStatusHandle aio <- asIO1 a - tid <- liftIO $ forkIO $ runTransferThread' program batchmaker d aio + tid <- liftIO $ forkIO $ runTransferThread' mkcheck rt d aio updateTransferInfo t $ info { transferTid = Just tid } -runTransferThread' :: FilePath -> BatchCommandMaker -> AssistantData -> (Transferrer -> IO ()) -> IO () -runTransferThread' program batchmaker d run = go +runTransferThread' :: MkCheckTransferrer -> RunTransferrer -> AssistantData -> (Transferrer -> IO ()) -> IO () +runTransferThread' mkcheck rt d run = go where - go = catchPauseResume $ - withTransferrer program batchmaker (transferrerPool d) - run + go = catchPauseResume $ do + p <- runAssistant d $ liftAnnex $ + Annex.getState Annex.transferrerpool + signalactonsvar <- runAssistant d $ liftAnnex $ + Annex.getState Annex.signalactions + withTransferrer' True signalactonsvar mkcheck rt p run pause = catchPauseResume $ runEvery (Seconds 86400) noop {- Note: This must use E.try, rather than E.catch. @@ -116,7 +126,8 @@ ( do debug [ "Transferring:" , describeTransfer t info ] notifyTransfer - return $ Just (t, info, go remote) + sd <- liftAnnex $ stallDetection remote + return $ Just (t, info, go remote sd) , do debug [ "Skipping unnecessary transfer:", describeTransfer t info ] @@ -155,7 +166,7 @@ - usual cleanup. However, first check if something else is - running the transfer, to avoid removing active transfers. -} - go remote transferrer = ifM (liftIO $ performTransfer transferrer t info) + go remote sd transferrer = ifM (isRight <$> performTransfer sd AssistantLevel liftAnnex (transferRemote info) t info transferrer) ( do case associatedFile info of AssociatedFile Nothing -> noop @@ -291,10 +302,16 @@ alterTransferInfo t $ \i -> i { transferPaused = False } liftIO $ throwTo tid ResumeTransfer start info = do - program <- liftIO programPath - batchmaker <- liftIO getBatchCommandMaker - inImmediateTransferSlot program batchmaker $ + rt <- liftAnnex . mkRunTransferrer + =<< liftIO getBatchCommandMaker + inImmediateTransferSlot rt $ genTransfer t info getCurrentTransfers :: Assistant TransferMap getCurrentTransfers = currentTransfers <$> getDaemonStatus + +checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer +checkNetworkConnections dstatushandle = do + dstatus <- atomically $ readTVar dstatushandle + h <- newNotificationHandle False (networkConnectedNotifier dstatus) + return $ not <$> checkNotification h diff --git a/Assistant/TransferrerPool.hs b/Assistant/TransferrerPool.hs deleted file mode 100644 --- a/Assistant/TransferrerPool.hs +++ /dev/null @@ -1,94 +0,0 @@ -{- A pool of "git-annex transferkeys" processes - - - - Copyright 2013 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Assistant.TransferrerPool where - -import Assistant.Common -import Assistant.Types.TransferrerPool -import Types.Transfer -import Utility.Batch - -import qualified Command.TransferKeys as T - -import Control.Concurrent.STM hiding (check) -import Control.Exception (throw) -import Control.Concurrent - -{- Runs an action with a Transferrer from the pool. - - - - Only one Transferrer is left running in the pool at a time. - - So if this needed to start a new Transferrer, it's stopped when done. - -} -withTransferrer :: FilePath -> BatchCommandMaker -> TransferrerPool -> (Transferrer -> IO a) -> IO a -withTransferrer program batchmaker pool a = do - (mi, leftinpool) <- atomically (popTransferrerPool pool) - i@(TransferrerPoolItem (Just t) check) <- case mi of - Nothing -> mkTransferrerPoolItem pool =<< mkTransferrer program batchmaker - Just i -> checkTransferrerPoolItem program batchmaker i - v <- tryNonAsync $ a t - if leftinpool == 0 - then atomically $ pushTransferrerPool pool i - else do - void $ forkIO $ stopTransferrer t - atomically $ pushTransferrerPool pool $ TransferrerPoolItem Nothing check - either throw return v - -{- Check if a Transferrer from the pool is still ok to be used. - - If not, stop it and start a new one. -} -checkTransferrerPoolItem :: FilePath -> BatchCommandMaker -> TransferrerPoolItem -> IO TransferrerPoolItem -checkTransferrerPoolItem program batchmaker i = case i of - TransferrerPoolItem (Just t) check -> ifM check - ( return i - , do - stopTransferrer t - new check - ) - TransferrerPoolItem Nothing check -> new check - where - new check = do - t <- mkTransferrer program batchmaker - return $ TransferrerPoolItem (Just t) check - -{- Requests that a Transferrer perform a Transfer, and waits for it to - - finish. -} -performTransfer :: Transferrer -> Transfer -> TransferInfo -> IO Bool -performTransfer transferrer t info = catchBoolIO $ do - T.sendRequest t info (transferrerWrite transferrer) - T.readResponse (transferrerRead transferrer) - -{- Starts a new git-annex transferkeys process, setting up handles - - that will be used to communicate with it. -} -mkTransferrer :: FilePath -> BatchCommandMaker -> IO Transferrer -mkTransferrer program batchmaker = do - {- It runs as a batch job. -} - let (program', params') = batchmaker (program, [Param "transferkeys"]) - {- It's put into its own group so that the whole group can be - - killed to stop a transfer. -} - (Just writeh, Just readh, _, pid) <- createProcess - (proc program' $ toCommand params') - { create_group = True - , std_in = CreatePipe - , std_out = CreatePipe - } - return $ Transferrer - { transferrerRead = readh - , transferrerWrite = writeh - , transferrerHandle = pid - } - -{- Checks if a Transferrer is still running. If not, makes a new one. -} -checkTransferrer :: FilePath -> BatchCommandMaker -> Transferrer -> IO Transferrer -checkTransferrer program batchmaker t = - maybe (return t) (const $ mkTransferrer program batchmaker) - =<< getProcessExitCode (transferrerHandle t) - -{- Closing the fds will stop the transferrer. -} -stopTransferrer :: Transferrer -> IO () -stopTransferrer t = do - hClose $ transferrerRead t - hClose $ transferrerWrite t - void $ waitForProcess $ transferrerHandle t diff --git a/Assistant/Types/TransferrerPool.hs b/Assistant/Types/TransferrerPool.hs deleted file mode 100644 --- a/Assistant/Types/TransferrerPool.hs +++ /dev/null @@ -1,64 +0,0 @@ -{- A pool of "git-annex transferkeys" processes available for use - - - - Copyright 2013 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module Assistant.Types.TransferrerPool where - -import Annex.Common -import Utility.NotificationBroadcaster -import Assistant.Types.DaemonStatus - -import Control.Concurrent.STM hiding (check) - -type TransferrerPool = TVar (MkCheckTransferrer, [TransferrerPoolItem]) - -type CheckTransferrer = IO Bool -type MkCheckTransferrer = IO (IO Bool) - -{- Each item in the pool may have a transferrer running, and has an - - IO action that can be used to check if it's still ok to use the - - transferrer. -} -data TransferrerPoolItem = TransferrerPoolItem (Maybe Transferrer) CheckTransferrer - -data Transferrer = Transferrer - { transferrerRead :: Handle - , transferrerWrite :: Handle - , transferrerHandle :: ProcessHandle - } - -newTransferrerPool :: MkCheckTransferrer -> IO TransferrerPool -newTransferrerPool c = newTVarIO (c, []) - -popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int) -popTransferrerPool p = do - (c, l) <- readTVar p - case l of - [] -> return (Nothing, 0) - (i:is) -> do - writeTVar p (c, is) - return $ (Just i, length is) - -pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM () -pushTransferrerPool p i = do - (c, l) <- readTVar p - let l' = i:l - writeTVar p (c, l') - -{- Note that making a CheckTransferrer may allocate resources, - - such as a NotificationHandle, so it's important that the returned - - TransferrerPoolItem is pushed into the pool, and not left to be - - garbage collected. -} -mkTransferrerPoolItem :: TransferrerPool -> Transferrer -> IO TransferrerPoolItem -mkTransferrerPoolItem p t = do - mkcheck <- atomically $ fst <$> readTVar p - check <- mkcheck - return $ TransferrerPoolItem (Just t) check - -checkNetworkConnections :: DaemonStatusHandle -> MkCheckTransferrer -checkNetworkConnections dstatushandle = do - dstatus <- atomically $ readTVar dstatushandle - h <- newNotificationHandle False (networkConnectedNotifier dstatus) - return $ not <$> checkNotification h diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,45 @@ +git-annex (8.20201129) upstream; urgency=medium + + * New borg special remote. This is a new kind of remote, that examines + borg backups of git-annex repositories, learns what files have been + backed up, and can restore files from the backup and so on. As well + as backups, it can be useful for archival storage, since borg can + efficiently store many related versions of files. + * New config annex.stalldetection, remote.name.annex-stalldetection, + which can be used to deal with remotes that stall during transfers, + or are sometimes too slow to want to use. + * Support special remotes that are configured with importtree=yes but + without exporttree=yes. + * Fix bug that made the next download after an empty file from a ssh + or tor remote fail. + * Avoid spurious "verification of content failed" message when downloading + content from a ssh or tor remote fails due to the remote no longer + having a copy of the content. + * Fix bug that matched include= and exclude= in preferred/required content + expressions relative to the current directory, rather than the path + from the top of the repository. + (Reversion introduced in version 8.20201116.) + * Fix hang on shutdown of external special remote using ASYNC protocol + extension. + (Reversion introduced in version 8.20201007.) + * Guard against running in a repo where annex.uuid is set but + annex.version is not set, or vice-versa. + * Avoid autoinit when a repo does not have annex.version or annex.uuid + set, but has a git-annex objects directory, suggesting it was used + by git-annex before, and the git config may have been lost. + * importfeed: Avoid using youtube-dl when a feed does not contain an + enclosure, but only a link to an url which youtube-dl does not support. + * initremote: Prevent enabling encryption with exporttree=yes or + importtree=yes. + * Windows: include= and exclude= containing '/' will also match filenames + that are written using '\'. (And vice-versa, but it's better to use '/' + for portability.) + * Fix a bug that could prevent getting files from an importtree=yes + remote, because the imported tree was allowed to be garbage collected. + * stack.yaml: Updated to lts-16.27. + + -- Joey Hess Tue, 29 Dec 2020 12:52:58 -0400 + git-annex (8.20201127) upstream; urgency=medium * adjust: New --unlock-present mode which locks files whose content is not diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -131,7 +131,7 @@ matcher <- getMatcher go $ \si f -> let f' = toRawFilePath f - in ifM (matcher $ MatchingFile $ FileInfo (Just f') f') + in ifM (matcher $ MatchingFile $ FileInfo (Just f') f' Nothing) ( a (si, f') , return Nothing ) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -35,6 +35,7 @@ import qualified Command.RegisterUrl import qualified Command.SetKey import qualified Command.DropKey +import qualified Command.Transferrer import qualified Command.TransferKey import qualified Command.TransferKeys import qualified Command.SetPresentKey @@ -177,6 +178,7 @@ , Command.RegisterUrl.cmd , Command.SetKey.cmd , Command.DropKey.cmd + , Command.Transferrer.cmd , Command.TransferKey.cmd , Command.TransferKeys.cmd , Command.SetPresentKey.cmd diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -115,6 +115,7 @@ checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo { contentFile = Just f , matchFile = relf + , matchKey = Nothing } withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek @@ -287,7 +288,7 @@ where process matcher v@(_si, f) = whenM (prefilter v) $ - whenM (matcher $ MatchingFile $ FileInfo (Just f) f) $ + whenM (matcher $ MatchingFile $ FileInfo (Just f) f Nothing) $ a v data MatcherInfo = MatcherInfo @@ -345,7 +346,7 @@ maybe noop (Annex.BranchState.setCache logf) logcontent checkMatcherWhen mi (matcherNeedsLocationLog mi && not (matcherNeedsFileName mi)) - (MatchingKey k (AssociatedFile (Just f))) + (MatchingFile $ FileInfo (Just f) f (Just k)) (commandAction $ startAction seeker si f k) precachefinisher mi lreader Nothing -> return () @@ -365,14 +366,14 @@ -- checked later, to avoid a slow lookup here. (not ((matcherNeedsKey mi || matcherNeedsLocationLog mi) && not (matcherNeedsFileName mi))) - (MatchingFile $ FileInfo (Just f) f) + (MatchingFile $ FileInfo (Just f) f Nothing) (liftIO $ ofeeder ((si, f), sha)) keyaction f mi content a = case parseLinkTargetOrPointerLazy =<< content of Just k -> checkMatcherWhen mi (matcherNeedsKey mi && not (matcherNeedsFileName mi || matcherNeedsLocationLog mi)) - (MatchingKey k (AssociatedFile (Just f))) + (MatchingFile $ FileInfo (Just f) f (Just k)) (checkpresence k (a k)) Nothing -> noop diff --git a/CmdLine/Usage.hs b/CmdLine/Usage.hs --- a/CmdLine/Usage.hs +++ b/CmdLine/Usage.hs @@ -16,7 +16,7 @@ usage :: String -> [Command] -> String usage header cmds = unlines $ usageMessage header : commandList cmds -{- Commands listed by section, with breif usage and description. -} +{- Commands listed by section, with brief usage and description. -} commandList :: [Command] -> [String] commandList cmds = concatMap go [minBound..] where diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -184,7 +184,7 @@ perform :: AddOptions -> RawFilePath -> AddUnlockedMatcher -> CommandPerform perform o file addunlockedmatcher = withOtherTmp $ \tmpdir -> do lockingfile <- not <$> addUnlocked addunlockedmatcher - (MatchingFile (FileInfo (Just file) file)) + (MatchingFile (FileInfo (Just file) file Nothing)) let cfg = LockDownConfig { lockingFile = lockingfile , hardlinkFileTmpDir = Just tmpdir diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -332,7 +332,7 @@ let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink) showNote "using youtube-dl" Transfer.notifyTransfer Transfer.Download url $ - Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> + Transfer.download' webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> youtubeDl url (fromRawFilePath workdir) p >>= \case Right (Just mediafile) -> do cleanuptmp @@ -396,7 +396,7 @@ checkDiskSpaceToGet dummykey Nothing $ do tmp <- fromRepo $ gitAnnexTmpObjectLocation dummykey ok <- Transfer.notifyTransfer Transfer.Download url $ - Transfer.download u dummykey afile Transfer.stdRetry $ \p -> do + Transfer.download' u dummykey afile Transfer.stdRetry $ \p -> do createAnnexDirectory (parentDir tmp) downloader (fromRawFilePath tmp) p if ok diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -46,7 +46,7 @@ cmd :: Command cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $ command "export" SectionCommon - "export content to a remote" + "export a tree of files to a special remote" paramTreeish (seek <$$> optParser) data ExportOptions = ExportOptions @@ -192,7 +192,7 @@ -- from a previous export, that are not part of this export. c <- Annex.getState Annex.errcounter when (c == 0) $ do - recordExport (uuid r) $ ExportChange + recordExportUnderway (uuid r) $ ExportChange { oldTreeish = exportedTreeishes old , newTreeish = new } @@ -283,7 +283,7 @@ sent <- tryNonAsync $ case ek of AnnexKey k -> ifM (inAnnex k) ( notifyTransfer Upload af $ - upload (uuid r) k af stdRetry $ \pm -> do + upload' (uuid r) k af stdRetry $ \pm -> do let rollback = void $ performUnexport r db [ek] loc sendAnnex k rollback $ \f -> @@ -362,10 +362,10 @@ removeExportedLocation db (asKey ek) loc flushDbQueue db - -- An appendonly remote can support removeExportLocation to remove - -- the file from the exported tree, but still retain the content - -- and allow retrieving it. - unless (appendonly r) $ do + -- An versionedExport remote supports removeExportLocation to remove + -- the file from the exported tree, but still retains the content + -- and allows retrieving it. + unless (versionedExport (exportActions r)) $ do remaininglocs <- liftIO $ concat <$> forM eks (\ek -> getExportedLocation db (asKey ek)) when (null remaininglocs) $ diff --git a/Command/Forget.hs b/Command/Forget.hs --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -35,7 +35,7 @@ start :: ForgetOptions -> CommandStart start o = starting "forget" ai si $ do - c <- liftIO currentVectorClock + c <- currentVectorClock let basets = addTransition c ForgetGitHistory noTransitions let ts = if dropDead o then addTransition c ForgetDeadRemotes basets diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -662,7 +662,7 @@ openFsckDb :: UUID -> Annex FsckDb.FsckHandle openFsckDb u = do h <- FsckDb.openDb u - Annex.addCleanup FsckCleanup $ + Annex.addCleanupAction FsckCleanup $ FsckDb.closeDb h return h diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -9,7 +9,6 @@ import Command import qualified Remote -import Annex.Content import Annex.Transfer import Annex.NumCopies import Annex.Wanted @@ -114,10 +113,6 @@ | Remote.hasKeyCheap r = either (const False) id <$> Remote.hasKey r key | otherwise = return True - docopy r witness = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) key afile $ \dest -> - download (Remote.uuid r) key afile stdRetry - (\p -> do - showAction $ "from " ++ Remote.name r - Remote.verifiedAction $ - Remote.retrieveKeyFile r key afile (fromRawFilePath dest) p - ) witness + docopy r witness = do + showAction $ "from " ++ Remote.name r + download r key afile stdRetry witness diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -241,6 +241,7 @@ let mi = MatchingFile $ FileInfo { contentFile = Just srcfile , matchFile = destfile + , matchKey = Nothing } lockingfile <- not <$> addUnlocked addunlockedmatcher mi -- Minimal lock down with no hard linking so nothing @@ -305,7 +306,7 @@ void $ includeCommandAction (listContents remote importtreeconfig ci importabletvar) liftIO (atomically (readTVar importabletvar)) >>= \case Nothing -> return () - Just importable -> importKeys remote importtreeconfig importcontent importable >>= \case + Just importable -> importKeys remote importtreeconfig importcontent False importable >>= \case Nothing -> warning $ concat [ "Failed to import some files from " , Remote.name remote @@ -323,21 +324,25 @@ listContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart listContents remote importtreeconfig ci tvar = starting "list" ai si $ + listContents' remote importtreeconfig ci $ \importable -> do + liftIO $ atomically $ writeTVar tvar importable + next $ return True + where + ai = ActionItemOther (Just (Remote.name remote)) + si = SeekInput [] + +listContents' :: Remote -> ImportTreeConfig -> CheckGitIgnore -> (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize)) -> Annex a) -> Annex a +listContents' remote importtreeconfig ci a = makeImportMatcher remote >>= \case - Right matcher -> getImportableContents remote importtreeconfig ci matcher >>= \case - Just importable -> next $ do - liftIO $ atomically $ writeTVar tvar (Just importable) - return True - Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote + Right matcher -> tryNonAsync (getImportableContents remote importtreeconfig ci matcher) >>= \case + Right importable -> a importable + Left e -> giveup $ "Unable to list contents of " ++ Remote.name remote ++ ": " ++ show e Left err -> giveup $ unwords [ "Cannot import from" , Remote.name remote , "because of a problem with its configuration:" , err ] - where - ai = ActionItemOther (Just (Remote.name remote)) - si = SeekInput [] commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents (Either Sha Key) -> CommandStart commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -308,27 +308,30 @@ downloadmedia linkurl mediaurl mediakey | rawOption (downloadOptions opts) = downloadlink - | otherwise = do - r <- withTmpWorkDir mediakey $ \workdir -> do - dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate - case dl of - Right (Just mediafile) -> do - let ext = case takeExtension mediafile of - [] -> ".m" - s -> s - ok <- rundownload linkurl ext $ \f -> - checkCanAdd (downloadOptions opts) f $ \canadd -> do - addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile)) - return (Just [mediakey]) - return (Just ok) - -- youtude-dl didn't support it, so - -- download it as if the link were - -- an enclosure. - Right Nothing -> Just <$> downloadlink - Left msg -> do - warning msg - return Nothing - return (fromMaybe False r) + | otherwise = ifM (youtubeDlSupported linkurl) + ( do + r <- withTmpWorkDir mediakey $ \workdir -> do + dl <- youtubeDl linkurl (fromRawFilePath workdir) nullMeterUpdate + case dl of + Right (Just mediafile) -> do + let ext = case takeExtension mediafile of + [] -> ".m" + s -> s + ok <- rundownload linkurl ext $ \f -> + checkCanAdd (downloadOptions opts) f $ \canadd -> do + addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just (toRawFilePath mediafile)) + return (Just [mediakey]) + return (Just ok) + -- youtube-dl didn't support it, so + -- download it as if the link were + -- an enclosure. + Right Nothing -> Just <$> downloadlink + Left msg -> do + warning $ linkurl ++ ": " ++ msg + return Nothing + return (fromMaybe False r) + , downloadlink + ) where downloadlink = performDownload addunlockedmatcher opts cache todownload { location = Enclosure linkurl } diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -569,7 +569,7 @@ where initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty) update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) = - ifM (matcher $ MatchingFile $ FileInfo (Just file) file) + ifM (matcher $ MatchingFile $ FileInfo (Just file) file (Just key)) ( do !presentdata' <- ifM (inAnnex key) ( return $ addKey key presentdata diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -74,7 +74,7 @@ seek :: MetaDataOptions -> CommandSeek seek o = case batchOption o of NoBatch -> do - c <- liftIO currentVectorClock + c <- currentVectorClock let ww = WarnUnmatchLsFiles let seeker = AnnexedFileSeeker { startAction = start c o @@ -188,7 +188,7 @@ , keyOptions = Nothing , batchOption = NoBatch } - t <- liftIO currentVectorClock + t <- currentVectorClock -- It would be bad if two batch mode changes used exactly -- the same timestamp, since the order of adds and removals -- of the same metadata value would then be indeterminate. diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -142,8 +142,7 @@ Right False -> logMove srcuuid destuuid False key $ \deststartedwithcopy -> do showAction $ "to " ++ Remote.name dest ok <- notifyTransfer Upload afile $ - upload (Remote.uuid dest) key afile stdRetry $ - Remote.action . Remote.storeKey dest key afile + upload dest key afile stdRetry if ok then finish deststartedwithcopy $ Remote.logStatus dest key InfoPresent @@ -208,10 +207,22 @@ fromPerform src removewhen key afile fromOk :: Remote -> Key -> Annex Bool -fromOk src key = do - u <- getUUID - remotes <- Remote.keyPossibilities key - return $ u /= Remote.uuid src && elem src remotes +fromOk src key + -- check if the remote contains the key, when it can be done cheaply + | Remote.hasKeyCheap src = + Remote.hasKey src key >>= \case + Right True -> return True + -- Don't skip getting the key just because the + -- remote no longer contains it if the log + -- says the remote is supposed to contain it; + -- that would be surprising behavior. + _ -> checklog + | otherwise = checklog + where + checklog = do + u <- getUUID + remotes <- Remote.keyPossibilities key + return $ u /= Remote.uuid src && elem src remotes fromPerform :: Remote -> RemoveWhen -> Key -> AssociatedFile -> CommandPerform fromPerform src removewhen key afile = do @@ -223,10 +234,8 @@ then dispatch removewhen deststartedwithcopy True else dispatch removewhen deststartedwithcopy =<< get where - get = notifyTransfer Download afile $ - download (Remote.uuid src) key afile stdRetry $ \p -> - getViaTmp (Remote.retrievalSecurityPolicy src) (RemoteVerify src) key afile $ \t -> - Remote.verifiedAction $ Remote.retrieveKeyFile src key afile (fromRawFilePath t) p + get = notifyTransfer Download afile $ + download src key afile stdRetry dispatch _ _ False = stop -- failed dispatch RemoveNever _ True = next $ return True -- copy complete diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -16,6 +16,7 @@ import Annex.Content import Annex.UUID import Annex.Perms +import Logs.Location import Utility.FileMode #ifndef mingw32_HOST_OS import Creds @@ -134,7 +135,7 @@ (fs', cleanup) <- seekHelper id ww LsFiles.inRepo =<< workTreeItems ww fs matcher <- Limit.getMatcher - let addlist f o = whenM (matcher $ MatchingFile $ FileInfo (Just f) f) $ + let addlist f o = whenM (matcher $ MatchingFile $ FileInfo (Just f) f Nothing) $ liftIO $ hPutStrLn h o forM_ fs' $ \(_, f) -> do mk <- lookupKey f @@ -212,7 +213,7 @@ Nothing -> do warning $ "Received a file " ++ f ++ " that is not a git-annex key. Deleting this file." liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) - Just k -> void $ + Just k -> void $ logStatusAfter k $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $ liftIO $ catchBoolIO $ do rename f (fromRawFilePath dest) diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -13,6 +13,7 @@ import Annex import Utility.Rsync import Types.Transfer +import Logs.Location import Command.SendKey (fieldTransfer) import qualified CmdLine.GitAnnexShell.Fields as Fields @@ -35,6 +36,7 @@ let rsp = RetrievalAllKeysSecure ifM (getViaTmp rsp verify key (AssociatedFile Nothing) go) ( do + logStatus key InfoPresent -- forcibly quit after receiving one key, -- and shutdown cleanly _ <- shutdown True diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -67,7 +67,7 @@ import Annex.Export import Annex.TaggedPush import Annex.CurrentBranch -import Annex.Import (canImportKeys) +import Annex.Import import Annex.CheckIgnore import Types.FileMatcher import qualified Database.Export as Export @@ -207,11 +207,11 @@ let withbranch a = a =<< getCurrentBranch remotes <- syncRemotes (syncWith o) + -- Remotes that are git repositories, not special remotes. let gitremotes = filter (Remote.gitSyncableRemoteType . Remote.remotetype) remotes - dataremotes <- filter (\r -> Remote.uuid r /= NoUUID) + -- Remotes that contain annex object content. + contentremotes <- filter (\r -> Remote.uuid r /= NoUUID) <$> filterM (not <$$> liftIO . getDynamicConfig . remoteAnnexIgnore . Remote.gitconfig) remotes - let (exportremotes, keyvalueremotes) = partition (exportTree . Remote.config) dataremotes - let importremotes = filter (importTree . Remote.config) dataremotes if cleanupOption o then do @@ -231,17 +231,27 @@ content <- shouldSyncContent o - forM_ importremotes $ + forM_ (filter isImport contentremotes) $ withbranch . importRemote content o mergeConfig + forM_ (filter isThirdPartyPopulated contentremotes) $ + pullThirdPartyPopulated o when content $ do -- Send content to any exports before other -- repositories, in case that lets content -- be dropped from other repositories. exportedcontent <- withbranch $ - seekExportContent (Just o) exportremotes + seekExportContent (Just o) + (filter isExport contentremotes) + + -- Sync content with remotes, but not with + -- export or import remotes, which handle content + -- syncing as part of export and import. syncedcontent <- withbranch $ - seekSyncContent o keyvalueremotes + seekSyncContent o $ filter + (\r -> not (isExport r || isImport r)) + contentremotes + -- Transferring content can take a while, -- and other changes can be pushed to the -- git-annex branch on the remotes in the @@ -479,6 +489,33 @@ where wantpull = remoteAnnexPull (Remote.gitconfig remote) +{- Handle a remote that is populated by a third party, by listing + - the contents of the remote, and then adding only the files on it that + - importKey identifies to a tree. The tree is only used to keep track + - of where keys are located on the remote, no remote tracking branch is + - updated, because the filenames are the names of annex object files, + - not suitable for a tracking branch. Does not transfer any content. -} +pullThirdPartyPopulated :: SyncOptions -> Remote -> CommandSeek +pullThirdPartyPopulated o remote + | not (pullOption o) || not wantpull = noop + | not (canImportKeys remote False) = noop + | otherwise = void $ includeCommandAction $ starting "list" ai si $ + Command.Import.listContents' remote ImportTree (CheckGitIgnore False) go + where + go (Just importable) = importKeys remote ImportTree False True importable >>= \case + Just importablekeys -> do + (_imported, updatestate) <- recordImportTree remote ImportTree importablekeys + next $ do + updatestate + return True + Nothing -> next $ return False + go Nothing = next $ return True -- unchanged from before + + ai = ActionItemOther (Just (Remote.name remote)) + si = SeekInput [] + + wantpull = remoteAnnexPull (Remote.gitconfig remote) + {- The remote probably has both a master and a synced/master branch. - Which to merge from? Well, the master has whatever latest changes - were committed (or pushed changes, if this is a bare remote), @@ -535,7 +572,7 @@ postpushupdate repo = case Git.repoWorkTree repo of Nothing -> return True Just wt -> ifM needemulation - ( gitAnnexChildProcess ["post-receive"] + ( gitAnnexChildProcess "post-receive" [] (\cp -> cp { cwd = Just (fromRawFilePath wt) }) (\_ _ _ pid -> waitForProcess pid >>= return . \case ExitSuccess -> True @@ -778,6 +815,7 @@ wantput r | Remote.readonly r || remoteAnnexReadOnly (Remote.gitconfig r) = return False + | isThirdPartyPopulated r = return False | otherwise = wantSend True (Just k) af (Remote.uuid r) handleput lack = catMaybes <$> ifM (inAnnex k) ( forM lack $ \r -> @@ -890,3 +928,12 @@ | notOnlyAnnexOption o = pure False | onlyAnnexOption o = pure True | otherwise = getGitConfigVal annexSyncOnlyAnnex + +isExport :: Remote -> Bool +isExport = exportTree . Remote.config + +isImport :: Remote -> Bool +isImport = importTree . Remote.config + +isThirdPartyPopulated :: Remote -> Bool +isThirdPartyPopulated = Remote.thirdPartyPopulated . Remote.remotetype diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -294,7 +294,7 @@ Just b -> case Types.Backend.verifyKeyContent b of Nothing -> return True Just verifier -> verifier k (serializeKey' k) - get r k = getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> + get r k = logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) @@ -368,13 +368,13 @@ , check (`notElem` [Right True, Right False]) "checkPresent" $ \r k -> Remote.checkPresent r k , check (== Right False) "retrieveKeyFile" $ \r k -> - getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> + logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> tryNonAsync (Remote.retrieveKeyFile r k (AssociatedFile Nothing) (fromRawFilePath dest) nullMeterUpdate) >>= \case Right v -> return (True, v) Left _ -> return (False, UnVerified) , check (== Right False) "retrieveKeyFileCheap" $ \r k -> case Remote.retrieveKeyFileCheap r of Nothing -> return False - Just a -> getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> + Just a -> logStatusAfter k $ getViaTmp (Remote.retrievalSecurityPolicy r) (RemoteVerify r) k (AssociatedFile Nothing) $ \dest -> unVerified $ isRight <$> tryNonAsync (a k (AssociatedFile Nothing) (fromRawFilePath dest)) ] diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -51,7 +51,7 @@ toPerform :: Key -> AssociatedFile -> Remote -> CommandPerform toPerform key file remote = go Upload file $ - upload (uuid remote) key file stdRetry $ \p -> do + upload' (uuid remote) key file stdRetry $ \p -> do tryNonAsync (Remote.storeKey remote key file p) >>= \case Right () -> do Remote.logStatus remote key InfoPresent @@ -62,8 +62,8 @@ fromPerform :: Key -> AssociatedFile -> Remote -> CommandPerform fromPerform key file remote = go Upload file $ - download (uuid remote) key file stdRetry $ \p -> - getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> + download' (uuid remote) key file stdRetry $ \p -> + logStatusAfter key $ getViaTmp (retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Right v -> return (True, v) Left e -> do diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -1,4 +1,7 @@ -{- git-annex command, used internally by assistant +{- git-annex command, used internally by assistant in version + - 8.20201127 and older and provided only to avoid upgrade breakage. + - Remove at some point when such old versions of git-annex are unlikely + - to be running any longer. - - Copyright 2012, 2013 Joey Hess - @@ -22,7 +25,7 @@ data TransferRequest = TransferRequest Direction Remote Key AssociatedFile cmd :: Command -cmd = command "transferkeys" SectionPlumbing "transfers keys" +cmd = command "transferkeys" SectionPlumbing "transfers keys (deprecated)" paramNothing (withParams seek) seek :: CmdParams -> CommandSeek @@ -37,7 +40,7 @@ where runner (TransferRequest direction remote key file) | direction == Upload = notifyTransfer direction file $ - upload (Remote.uuid remote) key file stdRetry $ \p -> do + upload' (Remote.uuid remote) key file stdRetry $ \p -> do tryNonAsync (Remote.storeKey remote key file p) >>= \case Left e -> do warning (show e) @@ -46,8 +49,8 @@ Remote.logStatus remote key InfoPresent return True | otherwise = notifyTransfer direction file $ - download (Remote.uuid remote) key file stdRetry $ \p -> - getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do + download' (Remote.uuid remote) key file stdRetry $ \p -> + logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case Left e -> do warning (show e) diff --git a/Command/Transferrer.hs b/Command/Transferrer.hs new file mode 100644 --- /dev/null +++ b/Command/Transferrer.hs @@ -0,0 +1,137 @@ +{- git-annex command + - + - Copyright 2012-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Command.Transferrer where + +import Command +import qualified Annex +import Annex.Content +import Logs.Location +import Annex.Transfer +import qualified Remote +import Utility.SimpleProtocol (dupIoHandles) +import qualified Database.Keys +import Annex.BranchState +import Types.Messages +import Annex.TransferrerPool +import Types.Transferrer +import qualified Utility.SimpleProtocol as Proto + +cmd :: Command +cmd = noCommit $ command "transferrer" SectionPlumbing "transfers content" + paramNothing (withParams seek) + +seek :: CmdParams -> CommandSeek +seek = withNothing (commandAction start) + +start :: CommandStart +start = do + enableInteractiveBranchAccess + (readh, writeh) <- liftIO dupIoHandles + let outputwriter = sendTransferResponse writeh . TransferOutput + let outputresponsereader = do + l <- getNextLine readh + return $ case Proto.parseMessage l of + Just (TransferSerializedOutputResponse r) -> Just r + Nothing -> Nothing + Annex.setOutput $ SerializedOutput outputwriter outputresponsereader + runRequests readh writeh runner + stop + where + runner (UploadRequest _ key (TransferAssociatedFile file)) remote = + -- This is called by eg, Annex.Transfer.upload, + -- so caller is responsible for doing notification, + -- and for retrying, and updating location log. + upload' (Remote.uuid remote) key file noRetry + (Remote.action . Remote.storeKey remote key file) + noNotification + runner (DownloadRequest _ key (TransferAssociatedFile file)) remote = + -- This is called by eg, Annex.Transfer.download + -- so caller is responsible for doing notification + -- and for retrying, and updating location log. + let go p = getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do + Remote.verifiedAction (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) + in download' (Remote.uuid remote) key file noRetry go + noNotification + runner (AssistantUploadRequest _ key (TransferAssociatedFile file)) remote = + notifyTransfer Upload file $ + upload' (Remote.uuid remote) key file stdRetry $ \p -> do + tryNonAsync (Remote.storeKey remote key file p) >>= \case + Left e -> do + warning (show e) + return False + Right () -> do + Remote.logStatus remote key InfoPresent + return True + runner (AssistantDownloadRequest _ key (TransferAssociatedFile file)) remote = + notifyTransfer Download file $ + download' (Remote.uuid remote) key file stdRetry $ \p -> + logStatusAfter key $ getViaTmp (Remote.retrievalSecurityPolicy remote) (RemoteVerify remote) key file $ \t -> do + r <- tryNonAsync (Remote.retrieveKeyFile remote key file (fromRawFilePath t) p) >>= \case + Left e -> do + warning (show e) + return (False, UnVerified) + Right v -> return (True, v) + -- Make sure we get the current + -- associated files data for the key, + -- not old cached data. + Database.Keys.closeDb + return r + +runRequests + :: Handle + -> Handle + -> (TransferRequest -> Remote -> Annex Bool) + -> Annex () +runRequests readh writeh a = go Nothing Nothing + where + go lastremoteoruuid lastremote = unlessM (liftIO $ hIsEOF readh) $ do + l <- liftIO $ getNextLine readh + case Proto.parseMessage l of + Just tr -> do + let remoteoruuid = transferRequestRemote tr + -- Often the same remote will be used + -- repeatedly, so cache the last one to + -- avoid looking up repeatedly. + mremote <- if lastremoteoruuid == Just remoteoruuid + then pure lastremote + else case remoteoruuid of + TransferRemoteName n -> + eitherToMaybe <$> Remote.byName' n + TransferRemoteUUID u -> + Remote.byUUID u + case mremote of + Just remote -> do + sendresult =<< a tr remote + go (Just remoteoruuid) mremote + Nothing -> transferrerProtocolError l + Nothing -> transferrerProtocolError l + + sendresult = liftIO . sendTransferResponse writeh . TransferResult + +sendTransferResponse :: Handle -> TransferResponse -> IO () +sendTransferResponse h r = silenceIOErrors $ do + hPutStrLn h $ unwords $ Proto.formatMessage r + hFlush h + +getNextLine :: Handle -> IO String +getNextLine = silenceIOErrors . hGetLine + +{- If the pipe we're talking to gets closed due to the parent git-annex + - having exited, read/write would throw an exception due to sigpipe, + - which gets displayed on the console in an ugly way. This silences that + - display, and exits on exception instead. + - + - Normally signals like SIGINT get propagated to this process + - from the parent process. However, since this process is run in its own + - process group, that propagation requires the parent to actively + - propagate the signal. One way that could not happen is if the parent + - gets a signal it cannot catch. Another way is if the parent is hit by + - the signal before it can set up the signal propagation. + -} +silenceIOErrors :: IO a -> IO a +silenceIOErrors a = catchIO a (const exitFailure) diff --git a/Config/Files.hs b/Config/Files.hs --- a/Config/Files.hs +++ b/Config/Files.hs @@ -29,7 +29,7 @@ programFile = userConfigFile "program" {- A .noannex file in a git repository prevents git-annex from - - initializing that repository.. The content of the file is returned. -} + - initializing that repository. The content of the file is returned. -} noAnnexFileContent :: Maybe FilePath -> IO (Maybe String) noAnnexFileContent repoworktree = case repoworktree of Nothing -> return Nothing diff --git a/Database/ContentIdentifier.hs b/Database/ContentIdentifier.hs --- a/Database/ContentIdentifier.hs +++ b/Database/ContentIdentifier.hs @@ -52,7 +52,9 @@ import Database.Persist.Sql hiding (Key) import Database.Persist.TH +import Database.Persist.Sqlite (runSqlite) import qualified System.FilePath.ByteString as P +import qualified Data.Text as T data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue @@ -62,7 +64,6 @@ cid ContentIdentifier key Key ContentIndentifiersKeyRemoteCidIndex key remote cid - ContentIndentifiersCidRemoteIndex cid remote -- The last git-annex branch tree sha that was used to update -- ContentIdentifiers AnnexBranch @@ -79,9 +80,15 @@ openDb = do dbdir <- fromRepo gitAnnexContentIdentifierDbDir let db = dbdir P. "db" - unlessM (liftIO $ R.doesPathExist db) $ do - initDb db $ void $ + ifM (liftIO $ not <$> R.doesPathExist db) + ( initDb db $ void $ runMigrationSilent migrateContentIdentifier + -- Migrate from old version of database, which had + -- an incorrect uniqueness constraint on the + -- ContentIdentifiers table. + , liftIO $ runSqlite (T.pack (fromRawFilePath db)) $ void $ + runMigrationSilent migrateContentIdentifier + ) h <- liftIO $ H.openDbQueue H.SingleWriter db "content_identifiers" return $ ContentIdentifierHandle h diff --git a/Git/LsTree.hs b/Git/LsTree.hs --- a/Git/LsTree.hs +++ b/Git/LsTree.hs @@ -1,17 +1,17 @@ {- git ls-tree interface - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE BangPatterns #-} - module Git.LsTree ( TreeItem(..), LsTreeMode(..), lsTree, lsTree', + lsTreeStrict, + lsTreeStrict', lsTreeParams, lsTreeFiles, parseLsTree, @@ -30,6 +30,7 @@ import System.Posix.Types import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified Data.Attoparsec.ByteString as AS import qualified Data.Attoparsec.ByteString.Lazy as A import qualified Data.Attoparsec.ByteString.Char8 as A8 @@ -38,7 +39,7 @@ , typeobj :: S.ByteString , sha :: Ref , file :: TopFilePath - } deriving Show + } deriving (Show) data LsTreeMode = LsTreeRecursive | LsTreeNonRecursive @@ -51,6 +52,13 @@ (l, cleanup) <- pipeNullSplit (lsTreeParams lsmode t ps) repo return (rights (map parseLsTree l), cleanup) +lsTreeStrict :: LsTreeMode -> Ref -> Repo -> IO [TreeItem] +lsTreeStrict = lsTreeStrict' [] + +lsTreeStrict' :: [CommandParam] -> LsTreeMode -> Ref -> Repo -> IO [TreeItem] +lsTreeStrict' ps lsmode t repo = rights . map parseLsTreeStrict + <$> pipeNullSplitStrict (lsTreeParams lsmode t ps) repo + lsTreeParams :: LsTreeMode -> Ref -> [CommandParam] -> [CommandParam] lsTreeParams lsmode r ps = [ Param "ls-tree" @@ -82,6 +90,13 @@ parseLsTree b = case A.parse parserLsTree b of A.Done _ r -> Right r A.Fail _ _ err -> Left err + +parseLsTreeStrict :: S.ByteString -> Either String TreeItem +parseLsTreeStrict b = go (AS.parse parserLsTree b) + where + go (AS.Done _ r) = Right r + go (AS.Fail _ _ err) = Left err + go (AS.Partial c) = go (c mempty) {- Parses a line of ls-tree output, in format: - mode SP type SP sha TAB file diff --git a/Git/Types.hs b/Git/Types.hs --- a/Git/Types.hs +++ b/Git/Types.hs @@ -135,7 +135,12 @@ fmtObjectType TreeObject = "tree" {- Types of items in a tree. -} -data TreeItemType = TreeFile | TreeExecutable | TreeSymlink | TreeSubmodule +data TreeItemType + = TreeFile + | TreeExecutable + | TreeSymlink + | TreeSubmodule + | TreeSubtree deriving (Eq, Show) {- Git uses magic numbers to denote the type of a tree item. -} @@ -144,6 +149,7 @@ readTreeItemType "100755" = Just TreeExecutable readTreeItemType "120000" = Just TreeSymlink readTreeItemType "160000" = Just TreeSubmodule +readTreeItemType "040000" = Just TreeSubtree readTreeItemType _ = Nothing fmtTreeItemType :: TreeItemType -> S.ByteString @@ -151,12 +157,14 @@ fmtTreeItemType TreeExecutable = "100755" fmtTreeItemType TreeSymlink = "120000" fmtTreeItemType TreeSubmodule = "160000" +fmtTreeItemType TreeSubtree = "040000" toTreeItemType :: FileMode -> Maybe TreeItemType toTreeItemType 0o100644 = Just TreeFile toTreeItemType 0o100755 = Just TreeExecutable toTreeItemType 0o120000 = Just TreeSymlink toTreeItemType 0o160000 = Just TreeSubmodule +toTreeItemType 0o040000 = Just TreeSubtree toTreeItemType _ = Nothing fromTreeItemType :: TreeItemType -> FileMode @@ -164,6 +172,7 @@ fromTreeItemType TreeExecutable = 0o100755 fromTreeItemType TreeSymlink = 0o120000 fromTreeItemType TreeSubmodule = 0o160000 +fromTreeItemType TreeSubtree = 0o040000 data Commit = Commit { commitTree :: Sha diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -115,7 +115,7 @@ matchGlobFile :: String -> MatchInfo -> Annex Bool matchGlobFile glob = go where - cglob = compileGlob glob CaseSensative -- memoized + cglob = compileGlob glob CaseSensative (GlobFilePath True) -- memoized go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi)) go (MatchingInfo p) = pure $ matchGlob cglob (fromRawFilePath (providedFilePath p)) go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p) @@ -166,7 +166,7 @@ , matchNeedsLocationLog = False } where - cglob = compileGlob glob CaseSensative -- memoized + cglob = compileGlob glob CaseSensative (GlobFilePath False) -- memoized go (MatchingKey _ _) = pure False go (MatchingFile fi) = case contentFile fi of Just f -> catchBoolIO $ @@ -535,9 +535,11 @@ secs = fromIntegral (durationSeconds duration) lookupFileKey :: FileInfo -> Annex (Maybe Key) -lookupFileKey fi = case contentFile fi of - Just f -> lookupKey f - Nothing -> return Nothing +lookupFileKey fi = case matchKey fi of + Just k -> return (Just k) + Nothing -> case contentFile fi of + Just f -> lookupKey f + Nothing -> return Nothing checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a diff --git a/Logs/Activity.hs b/Logs/Activity.hs --- a/Logs/Activity.hs +++ b/Logs/Activity.hs @@ -27,7 +27,7 @@ recordActivity :: Activity -> UUID -> Annex () recordActivity act uuid = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change activityLog $ buildLogOld buildActivity . changeLog c uuid (Right act) diff --git a/Logs/Chunk.hs b/Logs/Chunk.hs --- a/Logs/Chunk.hs +++ b/Logs/Chunk.hs @@ -35,7 +35,7 @@ chunksStored :: UUID -> Key -> ChunkMethod -> ChunkCount -> Annex () chunksStored u k chunkmethod chunkcount = do - c <- liftIO currentVectorClock + c <- currentVectorClock config <- Annex.getGitConfig Annex.Branch.change (chunkLogFile config k) $ buildLog . changeMapLog c (u, chunkmethod) chunkcount . parseLog diff --git a/Logs/Config.hs b/Logs/Config.hs --- a/Logs/Config.hs +++ b/Logs/Config.hs @@ -34,7 +34,7 @@ setGlobalConfig' :: ConfigKey -> ConfigValue -> Annex () setGlobalConfig' name new = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change configLog $ buildGlobalConfig . changeMapLog c name new . parseGlobalConfig diff --git a/Logs/ContentIdentifier.hs b/Logs/ContentIdentifier.hs --- a/Logs/ContentIdentifier.hs +++ b/Logs/ContentIdentifier.hs @@ -30,14 +30,18 @@ -- so ones that were recorded before are preserved. recordContentIdentifier :: RemoteStateHandle -> ContentIdentifier -> Key -> Annex () recordContentIdentifier (RemoteStateHandle u) cid k = do - c <- liftIO currentVectorClock + c <- currentVectorClock config <- Annex.getGitConfig - Annex.Branch.change (remoteContentIdentifierLogFile config k) $ - buildLog . addcid c . parseLog + Annex.Branch.maybeChange (remoteContentIdentifierLogFile config k) $ + addcid c . parseLog where - addcid c l = changeMapLog c u (cid :| contentIdentifierList (M.lookup u m)) l + addcid c v + | cid `elem` l = Nothing -- no change needed + | otherwise = Just $ buildLog $ + changeMapLog c u (cid :| l) v where - m = simpleMap l + m = simpleMap v + l = contentIdentifierList (M.lookup u m) -- | Get all known content identifiers for a key. getContentIdentifiers :: Key -> Annex [(RemoteStateHandle, [ContentIdentifier])] diff --git a/Logs/Difference.hs b/Logs/Difference.hs --- a/Logs/Difference.hs +++ b/Logs/Difference.hs @@ -25,7 +25,7 @@ recordDifferences :: Differences -> UUID -> Annex () recordDifferences ds@(Differences {}) uuid = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change differenceLog $ buildLogOld byteString . changeLog c uuid (encodeBS $ showDifferences ds) diff --git a/Logs/Export.hs b/Logs/Export.hs --- a/Logs/Export.hs +++ b/Logs/Export.hs @@ -1,6 +1,6 @@ -{- git-annex export log +{- git-annex export log (also used to log imports) - - - Copyright 2017-2019 Joey Hess + - Copyright 2017-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -15,8 +15,9 @@ getExport, exportedTreeishes, incompleteExportedTreeishes, - recordExport, recordExportBeginning, + recordExportUnderway, + recordExport, logExportExcluded, getExportExcluded, ) where @@ -64,7 +65,6 @@ incompleteExportedTreeishes :: [Exported] -> [Git.Ref] incompleteExportedTreeishes = concatMap incompleteExportedTreeish - data ExportParticipants = ExportParticipants { exportFrom :: UUID , exportTo :: UUID @@ -86,8 +86,37 @@ | exportTo ep == remoteuuid = Just exported | otherwise = Nothing --- | Record a change in what's exported to a special remote. +-- | Record the beginning of an export, to allow cleaning up from +-- interrupted exports. -- +-- This is called before any changes are made to the remote. +recordExportBeginning :: UUID -> Git.Ref -> Annex () +recordExportBeginning remoteuuid newtree = do + c <- currentVectorClock + u <- getUUID + let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid } + old <- fromMaybe (Exported emptyTree []) + . M.lookup ep . simpleMap + . parseExportLog + <$> Annex.Branch.get exportLog + let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) } + Annex.Branch.change exportLog $ + buildExportLog + . changeMapLog c ep new + . parseExportLog + recordExportTreeish newtree + +-- Grade a tree ref into the git-annex branch. This is done +-- to ensure that it's available later, when getting exported files +-- from the remote. Since that could happen in another clone of the +-- repository, the tree has to be kept available, even if it +-- doesn't end up being merged into the master branch. +recordExportTreeish :: Git.Ref -> Annex () +recordExportTreeish t = + Annex.Branch.rememberTreeish t (asTopFilePath "export.tree") + +-- | Record that an export to a special remote is under way. +-- -- This is called before an export begins uploading new files to the -- remote, but after it's cleaned up any files that need to be deleted -- from the old treeish. @@ -96,12 +125,9 @@ -- newTreeish. This way, when multiple repositories are exporting to -- the same special remote, there's no conflict as long as they move -- forward in lock-step. --- --- Also, the newTreeish is grafted into the git-annex branch. This is done --- to ensure that it's available later. -recordExport :: UUID -> ExportChange -> Annex () -recordExport remoteuuid ec = do - c <- liftIO currentVectorClock +recordExportUnderway :: UUID -> ExportChange -> Annex () +recordExportUnderway remoteuuid ec = do + c <- currentVectorClock u <- getUUID let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid } let exported = Exported (newTreeish ec) [] @@ -115,25 +141,16 @@ | u == exportFrom ep || remoteuuid /= exportTo ep || t `notElem` oldTreeish ec = le | otherwise = LogEntry c (exported { exportedTreeish = newTreeish ec }) --- | Record the beginning of an export, to allow cleaning up from --- interrupted exports. +-- Record information about the export to the git-annex branch. -- --- This is called before any changes are made to the remote. -recordExportBeginning :: UUID -> Git.Ref -> Annex () -recordExportBeginning remoteuuid newtree = do - c <- liftIO currentVectorClock - u <- getUUID - let ep = ExportParticipants { exportFrom = u, exportTo = remoteuuid } - old <- fromMaybe (Exported emptyTree []) - . M.lookup ep . simpleMap - . parseExportLog - <$> Annex.Branch.get exportLog - let new = old { incompleteExportedTreeish = nub (newtree:incompleteExportedTreeish old) } - Annex.Branch.change exportLog $ - buildExportLog - . changeMapLog c ep new - . parseExportLog - Annex.Branch.rememberTreeish newtree (asTopFilePath "export.tree") +-- This is equivilant to recordExportBeginning followed by +-- recordExportUnderway, but without the ability to clean up from +-- interrupted exports. +recordExport :: UUID -> Git.Ref -> ExportChange -> Annex () +recordExport remoteuuid tree ec = do + when (oldTreeish ec /= [tree]) $ + recordExportTreeish tree + recordExportUnderway remoteuuid ec parseExportLog :: L.ByteString -> MapLog ExportParticipants Exported parseExportLog = parseMapLog exportParticipantsParser exportedParser diff --git a/Logs/Group.hs b/Logs/Group.hs --- a/Logs/Group.hs +++ b/Logs/Group.hs @@ -38,7 +38,7 @@ groupChange :: UUID -> (S.Set Group -> S.Set Group) -> Annex () groupChange uuid@(UUID _) modifier = do curr <- lookupGroups uuid - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change groupLog $ buildLogOld buildGroup . changeLog c uuid (modifier curr) . parseLogOld parseGroup diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -16,6 +16,7 @@ module Logs.Location ( LogStatus(..), logStatus, + logStatusAfter, logChange, loggedLocations, loggedLocationsHistorical, @@ -47,6 +48,16 @@ logStatus key s = do u <- getUUID logChange key u s + +{- Run an action that gets the content of a key, and update the log + - when it succeeds. -} +logStatusAfter :: Key -> Annex Bool -> Annex Bool +logStatusAfter key a = ifM a + ( do + logStatus key InfoPresent + return True + , return False + ) {- Log a change in the presence of a key's value in a repository. -} logChange :: Key -> UUID -> LogStatus -> Annex () diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -103,7 +103,7 @@ addMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> MetaData -> Annex () addMetaData' getlogfile k metadata = - addMetaDataClocked' getlogfile k metadata =<< liftIO currentVectorClock + addMetaDataClocked' getlogfile k metadata =<< currentVectorClock {- Reusing the same VectorClock when making changes to the metadata - of multiple keys is a nice optimisation. The same metadata lines diff --git a/Logs/Multicast.hs b/Logs/Multicast.hs --- a/Logs/Multicast.hs +++ b/Logs/Multicast.hs @@ -25,7 +25,7 @@ recordFingerprint :: Fingerprint -> UUID -> Annex () recordFingerprint fp uuid = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change multicastLog $ buildLogOld buildFindgerPrint . changeLog c uuid fp diff --git a/Logs/PreferredContent/Raw.hs b/Logs/PreferredContent/Raw.hs --- a/Logs/PreferredContent/Raw.hs +++ b/Logs/PreferredContent/Raw.hs @@ -30,7 +30,7 @@ setLog :: RawFilePath -> UUID -> PreferredContentExpression -> Annex () setLog logfile uuid@(UUID _) val = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change logfile $ buildLogOld buildPreferredContentExpression . changeLog c uuid val @@ -44,7 +44,7 @@ {- Changes the preferred content configuration of a group. -} groupPreferredContentSet :: Group -> PreferredContentExpression -> Annex () groupPreferredContentSet g val = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change groupPreferredContentLog $ buildGroupPreferredContent . changeMapLog c g val diff --git a/Logs/Presence.hs b/Logs/Presence.hs --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -51,7 +51,7 @@ {- Generates a new LogLine with the current time. -} logNow :: LogStatus -> LogInfo -> Annex LogLine logNow s i = do - c <- liftIO currentVectorClock + c <- currentVectorClock return $ LogLine c s i {- Reads a log and returns only the info that is still in effect. -} diff --git a/Logs/Remote.hs b/Logs/Remote.hs --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -32,7 +32,7 @@ {- Adds or updates a remote's config in the log. -} configSet :: UUID -> RemoteConfig -> Annex () configSet u cfg = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change remoteLog $ buildRemoteConfigLog . changeLog c u (removeSameasInherited cfg) diff --git a/Logs/RemoteState.hs b/Logs/RemoteState.hs --- a/Logs/RemoteState.hs +++ b/Logs/RemoteState.hs @@ -26,7 +26,7 @@ setRemoteState :: RemoteStateHandle -> Key -> RemoteState -> Annex () setRemoteState (RemoteStateHandle u) k s = do - c <- liftIO currentVectorClock + c <- currentVectorClock config <- Annex.getGitConfig Annex.Branch.change (remoteStateLogFile config k) $ buildRemoteState . changeLog c u s . parseRemoteState diff --git a/Logs/Schedule.hs b/Logs/Schedule.hs --- a/Logs/Schedule.hs +++ b/Logs/Schedule.hs @@ -32,7 +32,7 @@ scheduleSet :: UUID -> [ScheduledActivity] -> Annex () scheduleSet uuid@(UUID _) activities = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change scheduleLog $ buildLogOld byteString . changeLog c uuid (encodeBS val) diff --git a/Logs/SingleValue.hs b/Logs/SingleValue.hs --- a/Logs/SingleValue.hs +++ b/Logs/SingleValue.hs @@ -33,6 +33,6 @@ setLog :: (SingleValueSerializable v) => RawFilePath -> v -> Annex () setLog f v = do - c <- liftIO currentVectorClock + c <- currentVectorClock let ent = LogEntry c v Annex.Branch.change f $ \_old -> buildLog (S.singleton ent) diff --git a/Logs/Trust.hs b/Logs/Trust.hs --- a/Logs/Trust.hs +++ b/Logs/Trust.hs @@ -1,6 +1,6 @@ {- git-annex trust log - - - Copyright 2010-2012 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -64,20 +64,15 @@ {- Loads the map, updating the cache, -} trustMapLoad :: Annex TrustMap trustMapLoad = do - overrides <- Annex.getState Annex.forcetrust + forceoverrides <- Annex.getState Annex.forcetrust l <- remoteList - -- Exports are not trusted, since they are not key/value stores. - -- This does not apply to appendonly exports, which are key/value - -- stores. - let untrustworthy r = pure (not (Types.Remote.appendonly r)) - <&&> Types.Remote.isExportSupported r - exports <- filterM untrustworthy l - let exportoverrides = M.fromList $ - map (\r -> (Types.Remote.uuid r, UnTrusted)) exports + let untrustoverrides = M.fromList $ + map (\r -> (Types.Remote.uuid r, UnTrusted)) + (filter Types.Remote.untrustworthy l) logged <- trustMapRaw let configured = M.fromList $ mapMaybe configuredtrust l - let m = M.unionWith min exportoverrides $ - M.union overrides $ + let m = M.unionWith min untrustoverrides $ + M.union forceoverrides $ M.union configured logged Annex.changeState $ \s -> s { Annex.trustmap = Just m } return m diff --git a/Logs/Trust/Basic.hs b/Logs/Trust/Basic.hs --- a/Logs/Trust/Basic.hs +++ b/Logs/Trust/Basic.hs @@ -22,7 +22,7 @@ {- Changes the trust level for a uuid in the trustLog. -} trustSet :: UUID -> TrustLevel -> Annex () trustSet uuid@(UUID _) level = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change trustLog $ buildLogOld buildTrustLevel . changeLog c uuid level . diff --git a/Logs/UUID.hs b/Logs/UUID.hs --- a/Logs/UUID.hs +++ b/Logs/UUID.hs @@ -31,7 +31,7 @@ {- Records a description for a uuid in the log. -} describeUUID :: UUID -> UUIDDesc -> Annex () describeUUID uuid desc = do - c <- liftIO currentVectorClock + c <- currentVectorClock Annex.Branch.change uuidLog $ buildLogOld buildUUIDDesc . changeLog c uuid desc . parseUUIDLog diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -285,9 +285,10 @@ commandProgressDisabled :: Annex Bool commandProgressDisabled = withMessageState $ \s -> return $ case outputType s of + NormalOutput -> concurrentOutputEnabled s QuietOutput -> True JSONOutput _ -> True - NormalOutput -> concurrentOutputEnabled s + SerializedOutput _ _ -> True jsonOutputEnabled :: Annex Bool jsonOutputEnabled = withMessageState $ \s -> return $ @@ -313,8 +314,20 @@ where goconcurrent = withMessageState $ \s -> do let l = promptLock s + let (run, cleanup) = case outputType s of + SerializedOutput h hr -> + ( \a -> do + liftIO $ outputSerialized h BeginPrompt + liftIO $ waitOutputSerializedResponse hr ReadyPrompt + a + , liftIO $ outputSerialized h EndPrompt + ) + _ -> + ( hideRegionsWhile s + , noop + ) return $ \a -> debugLocks $ bracketIO (takeMVar l) - (putMVar l) - (const $ hideRegionsWhile s a) + (\v -> putMVar l v >> cleanup) + (const $ run a) diff --git a/Messages/Concurrent.hs b/Messages/Concurrent.hs --- a/Messages/Concurrent.hs +++ b/Messages/Concurrent.hs @@ -98,10 +98,14 @@ Regions.closeConsoleRegion r {- The progress region is displayed inline with the current console region. -} -withProgressRegion :: (Regions.ConsoleRegion -> Annex a) -> Annex a -withProgressRegion a = do - parent <- consoleRegion <$> Annex.getState Annex.output +withProgressRegion + :: (MonadIO m, MonadMask m) + => MessageState + -> (Regions.ConsoleRegion -> m a) -> m a +withProgressRegion st a = Regions.withConsoleRegion (maybe Regions.Linear Regions.InLine parent) a + where + parent = consoleRegion st instance Regions.LiftRegion Annex where liftRegion = liftIO . atomically diff --git a/Messages/Internal.hs b/Messages/Internal.hs --- a/Messages/Internal.hs +++ b/Messages/Internal.hs @@ -1,6 +1,6 @@ {- git-annex output messages, including concurrent output to display regions - - - Copyright 2010-2018 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -29,25 +29,32 @@ | otherwise -> liftIO $ flushed $ S.putStr msg JSONOutput _ -> void $ jsonoutputter jsonbuilder s QuietOutput -> q + SerializedOutput h _ -> do + liftIO $ outputSerialized h $ OutputMessage msg + void $ jsonoutputter jsonbuilder s -- Buffer changes to JSON until end is reached and then emit it. bufferJSON :: JSONBuilder -> MessageState -> Annex Bool bufferJSON jsonbuilder s = case outputType s of - JSONOutput jsonoptions - | endjson -> do + JSONOutput _ -> go (flushed . JSON.emit) + SerializedOutput h _ -> go (outputSerialized h . JSONObject . JSON.encode) + _ -> return False + where + go emitter + | endjson = do Annex.changeState $ \st -> st { Annex.output = s { jsonBuffer = Nothing } } - maybe noop (liftIO . flushed . JSON.emit . JSON.finalize jsonoptions) json + maybe noop (liftIO . emitter . JSON.finalize) json return True - | otherwise -> do + | otherwise = do Annex.changeState $ \st -> st { Annex.output = s { jsonBuffer = json } } return True - _ -> return False - where + (json, endjson) = case jsonbuilder i of Nothing -> (jsonBuffer s, False) (Just (j, e)) -> (Just j, e) + i = case jsonBuffer s of Nothing -> Nothing Just b -> Just (b, False) @@ -55,11 +62,14 @@ -- Immediately output JSON. outputJSON :: JSONBuilder -> MessageState -> Annex Bool outputJSON jsonbuilder s = case outputType s of - JSONOutput _ -> do - maybe noop (liftIO . flushed . JSON.emit) + JSONOutput _ -> go (flushed . JSON.emit) + SerializedOutput h _ -> go (outputSerialized h . JSONObject . JSON.encode) + _ -> return False + where + go emitter = do + maybe noop (liftIO . emitter) (fst <$> jsonbuilder Nothing) return True - _ -> return False outputError :: String -> Annex () outputError msg = withMessageState $ \s -> case (outputType s, jsonBuffer s) of @@ -67,6 +77,8 @@ let jb' = Just (JSON.addErrorMessage (lines msg) jb) in Annex.changeState $ \st -> st { Annex.output = s { jsonBuffer = jb' } } + (SerializedOutput h _, _) -> + liftIO $ outputSerialized h $ OutputError msg _ | concurrentOutputEnabled s -> concurrentMessage s True msg go | otherwise -> go @@ -81,3 +93,12 @@ flushed :: IO () -> IO () flushed a = a >> hFlush stdout + +outputSerialized :: (SerializedOutput -> IO ()) -> SerializedOutput -> IO () +outputSerialized = id + +-- | Wait for the specified response. +waitOutputSerializedResponse :: (IO (Maybe SerializedOutputResponse)) -> SerializedOutputResponse -> IO () +waitOutputSerializedResponse getr r = tryIO getr >>= \case + Right (Just r') | r' == r -> return () + v -> error $ "serialized output protocol error; expected " ++ show r ++ " got " ++ show v diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -11,6 +11,8 @@ JSONBuilder, JSONChunk(..), emit, + emit', + encode, none, start, end, @@ -38,7 +40,6 @@ import Data.Monoid import Prelude -import Types.Messages import Types.Command (SeekInput(..)) import Key import Utility.Metered @@ -52,9 +53,12 @@ emitLock = unsafePerformIO $ newMVar () emit :: Object -> IO () -emit o = do +emit = emit' . encode + +emit' :: L.ByteString -> IO () +emit' b = do takeMVar emitLock - L.hPut stdout (encode o) + L.hPut stdout b putStr "\n" putMVar emitLock () @@ -82,12 +86,10 @@ end b (Just (o, _)) = Just (HM.insert "success" (toJSON' b) o, True) end _ Nothing = Nothing -finalize :: JSONOptions -> Object -> Object -finalize jsonoptions o - -- Always include error-messages field, even if empty, - -- to make the json be self-documenting. - | jsonErrorMessages jsonoptions = addErrorMessage [] o - | otherwise = o +-- Always include error-messages field, even if empty, +-- to make the json be self-documenting. +finalize :: Object -> Object +finalize o = addErrorMessage [] o addErrorMessage :: [String] -> Object -> Object addErrorMessage msg o = @@ -132,7 +134,7 @@ -- Show JSON formatted progress, including the current state of the JSON -- object for the action being performed. -progress :: Maybe Object -> Maybe Integer -> BytesProcessed -> IO () +progress :: Maybe Object -> Maybe TotalSize -> BytesProcessed -> IO () progress maction msize bytesprocessed = case j of Object o -> emit $ case maction of @@ -142,7 +144,7 @@ where n = fromBytesProcessed bytesprocessed :: Integer j = case msize of - Just size -> object + Just (TotalSize size) -> object [ "byte-progress" .= n , "percent-progress" .= showPercentage 2 (percentage size n) , "total-size" .= size diff --git a/Messages/Progress.hs b/Messages/Progress.hs --- a/Messages/Progress.hs +++ b/Messages/Progress.hs @@ -1,6 +1,6 @@ {- git-annex progress output - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -20,27 +20,30 @@ import Utility.InodeCache import qualified Messages.JSON as JSON import Messages.Concurrent +import Messages.Internal import qualified System.Console.Regions as Regions import qualified System.Console.Concurrent as Console +import Control.Monad.IO.Class (MonadIO) +import Data.IORef {- Class of things from which a size can be gotten to display a progress - meter. -} class MeterSize t where - getMeterSize :: t -> Annex (Maybe FileSize) + getMeterSize :: t -> Annex (Maybe TotalSize) instance MeterSize t => MeterSize (Maybe t) where getMeterSize Nothing = pure Nothing getMeterSize (Just t) = getMeterSize t instance MeterSize FileSize where - getMeterSize = pure . Just + getMeterSize = pure . Just . TotalSize instance MeterSize Key where - getMeterSize = pure . fromKey keySize + getMeterSize = pure . fmap TotalSize . fromKey keySize instance MeterSize InodeCache where - getMeterSize = pure . Just . inodeCacheFileSize + getMeterSize = pure . Just . TotalSize . inodeCacheFileSize instance MeterSize KeySource where getMeterSize = maybe (pure Nothing) getMeterSize . inodeCache @@ -53,48 +56,85 @@ instance MeterSize KeySizer where getMeterSize (KeySizer k getsrcfile) = case fromKey keySize k of - Just sz -> return (Just sz) + Just sz -> return (Just (TotalSize sz)) Nothing -> do srcfile <- getsrcfile case srcfile of Nothing -> return Nothing - Just f -> catchMaybeIO $ liftIO $ getFileSize f + Just f -> catchMaybeIO $ liftIO $ + TotalSize <$> getFileSize f {- Shows a progress meter while performing an action. - The action is passed the meter and a callback to use to update the meter. --} -metered :: MeterSize sizer => Maybe MeterUpdate -> sizer -> (Meter -> MeterUpdate -> Annex a) -> Annex a -metered othermeter sizer a = withMessageState $ \st -> - flip go st =<< getMeterSize sizer +metered + :: MeterSize sizer + => Maybe MeterUpdate + -> sizer + -> (Meter -> MeterUpdate -> Annex a) + -> Annex a +metered othermeter sizer a = withMessageState $ \st -> do + sz <- getMeterSize sizer + metered' st othermeter sz showOutput a + +metered' + :: (Monad m, MonadIO m, MonadMask m) + => MessageState + -> Maybe MeterUpdate + -> Maybe TotalSize + -> m () + -- ^ this should run showOutput + -> (Meter -> MeterUpdate -> m a) + -> m a +metered' st othermeter msize showoutput a = go st where - go _ (MessageState { outputType = QuietOutput }) = nometer - go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do - showOutput + go (MessageState { outputType = QuietOutput }) = nometer + go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = False }) = do + showoutput meter <- liftIO $ mkMeter msize $ displayMeterHandle stdout bandwidthMeter - m <- liftIO $ rateLimitMeterUpdate 0.2 meter $ + m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $ updateMeter meter r <- a meter (combinemeter m) liftIO $ clearMeterHandle meter stdout return r - go msize (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = - withProgressRegion $ \r -> do + go (MessageState { outputType = NormalOutput, concurrentOutputEnabled = True }) = + withProgressRegion st $ \r -> do meter <- liftIO $ mkMeter msize $ \_ msize' old new -> let s = bandwidthMeter msize' old new in Regions.setConsoleRegion r ('\n' : s) - m <- liftIO $ rateLimitMeterUpdate 0.2 meter $ + m <- liftIO $ rateLimitMeterUpdate consoleratelimit meter $ updateMeter meter a meter (combinemeter m) - go msize (MessageState { outputType = JSONOutput jsonoptions }) + go (MessageState { outputType = JSONOutput jsonoptions }) | jsonProgress jsonoptions = do - buf <- withMessageState $ return . jsonBuffer - meter <- liftIO $ mkMeter msize $ \_ msize' _old (new, _now) -> - JSON.progress buf msize' new - m <- liftIO $ rateLimitMeterUpdate 0.1 meter $ + let buf = jsonBuffer st + meter <- liftIO $ mkMeter msize $ \_ msize' _old new -> + JSON.progress buf msize' (meterBytesProcessed new) + m <- liftIO $ rateLimitMeterUpdate jsonratelimit meter $ updateMeter meter a meter (combinemeter m) | otherwise = nometer - + go (MessageState { outputType = SerializedOutput h _ }) = do + liftIO $ outputSerialized h BeginProgressMeter + case msize of + Just sz -> liftIO $ outputSerialized h $ UpdateProgressMeterTotalSize sz + Nothing -> noop + szv <- liftIO $ newIORef msize + meter <- liftIO $ mkMeter msize $ \_ msize' _old new -> do + case msize' of + Just sz | msize' /= msize -> do + psz <- readIORef szv + when (msize' /= psz) $ do + writeIORef szv msize' + outputSerialized h $ UpdateProgressMeterTotalSize sz + _ -> noop + outputSerialized h $ UpdateProgressMeter $ + meterBytesProcessed new + m <- liftIO $ rateLimitMeterUpdate minratelimit meter $ + updateMeter meter + a meter (combinemeter m) + `finally` (liftIO $ outputSerialized h EndProgressMeter) nometer = do dummymeter <- liftIO $ mkMeter Nothing $ \_ _ _ _ -> return () @@ -103,6 +143,12 @@ combinemeter m = case othermeter of Nothing -> m Just om -> combineMeterUpdate m om + + consoleratelimit = 0.2 + + jsonratelimit = 0.1 + + minratelimit = min consoleratelimit jsonratelimit {- Poll file size to display meter. -} meteredFile :: FilePath -> Maybe MeterUpdate -> Key -> Annex a -> Annex a diff --git a/Messages/Serialized.hs b/Messages/Serialized.hs new file mode 100644 --- /dev/null +++ b/Messages/Serialized.hs @@ -0,0 +1,108 @@ +{- serialized output + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes #-} + +module Messages.Serialized ( + relaySerializedOutput, + outputSerialized, + waitOutputSerializedResponse, +) where + +import Common +import Annex +import Types.Messages +import Messages +import Messages.Internal +import Messages.Progress +import qualified Messages.JSON as JSON +import Utility.Metered (BytesProcessed, setMeterTotalSize) + +import Control.Monad.IO.Class (MonadIO) + +-- | Relay serialized output from a child process to the console. +relaySerializedOutput + :: (Monad m, MonadIO m, MonadMask m) + => m (Either SerializedOutput r) + -- ^ Get next serialized output, or final value to return. + -> (SerializedOutputResponse -> m ()) + -- ^ Send response to child process. + -> (Maybe BytesProcessed -> m ()) + -- ^ When a progress meter is running, is updated with + -- progress meter values sent by the process. + -- When a progress meter is stopped, Nothing is sent. + -> (forall a. Annex a -> m a) + -- ^ Run an annex action in the monad. Will not be used with + -- actions that block for a long time. + -> m r +relaySerializedOutput getso sendsor meterreport runannex = go Nothing + where + go st = loop st >>= \case + Right r -> return r + Left st' -> go st' + + loop st = getso >>= \case + Right r -> return (Right r) + Left (OutputMessage msg) -> do + runannex $ outputMessage' + (\_ _ -> return False) + id + msg + loop st + Left (OutputError msg) -> do + runannex $ outputError msg + loop st + Left (JSONObject b) -> do + runannex $ withMessageState $ \s -> case outputType s of + JSONOutput _ -> liftIO $ flushed $ JSON.emit' b + SerializedOutput h _ -> liftIO $ + outputSerialized h $ JSONObject b + _ -> q + loop st + Left BeginProgressMeter -> do + ost <- runannex (Annex.getState Annex.output) + -- Display a progress meter while running, until + -- the meter ends or a final value is returned. + metered' ost Nothing Nothing (runannex showOutput) + (\meter meterupdate -> loop (Just (meter, meterupdate))) + >>= \case + Right r -> return (Right r) + -- Continue processing serialized + -- output after the progress meter + -- is done. + Left _st' -> loop Nothing + Left EndProgressMeter -> do + meterreport Nothing + return (Left st) + Left (UpdateProgressMeter n) -> do + case st of + Just (_, meterupdate) -> do + meterreport (Just n) + liftIO $ meterupdate n + Nothing -> noop + loop st + Left (UpdateProgressMeterTotalSize sz) -> do + case st of + Just (meter, _) -> liftIO $ + setMeterTotalSize meter sz + Nothing -> noop + loop st + Left BeginPrompt -> do + prompter <- runannex mkPrompter + v <- prompter $ do + sendsor ReadyPrompt + -- Continue processing serialized output + -- until EndPrompt or a final value is + -- returned. (EndPrompt is all that + -- ought to be sent while in a prompt + -- really, but if something else did get + -- sent, display it just in case.) + loop st + case v of + Right r -> return (Right r) + Left st' -> loop st' + Left EndPrompt -> return (Left st) diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -75,8 +75,8 @@ let rsp = RetrievalAllKeysSecure v <- tryNonAsync $ do let runtransfer ti = - Right <$> transfer download k af (\p -> - getViaTmp rsp DefaultVerify k af $ \tmp -> + Right <$> transfer download' k af (\p -> + logStatusAfter k $ getViaTmp rsp DefaultVerify k af $ \tmp -> storefile (fromRawFilePath tmp) o l getb validitycheck p ti) let fallback = return $ Left $ ProtoFailureMessage "transfer already in progress, or unable to take transfer lock" @@ -172,6 +172,14 @@ runner validitycheck >>= \case Right (Just Valid) -> return (rightsize, UnVerified) + Right (Just Invalid) | l == 0 -> + -- Special case, for when + -- content was not + -- available to send, + -- which is indicated by + -- sending 0 bytes and + -- Invalid. + return (False, UnVerified) _ -> do -- Invalid, or old protocol -- version. Validity is not diff --git a/P2P/Protocol.hs b/P2P/Protocol.hs --- a/P2P/Protocol.hs +++ b/P2P/Protocol.hs @@ -2,7 +2,7 @@ - - See doc/design/p2p_protocol.mdwn - - - Copyright 2016-2018 Joey Hess + - Copyright 2016-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -53,6 +53,9 @@ maxProtocolVersion :: ProtocolVersion maxProtocolVersion = ProtocolVersion 1 +newtype ProtoAssociatedFile = ProtoAssociatedFile AssociatedFile + deriving (Show) + -- | Service as used by the connect message in gitremote-helpers(1) data Service = UploadPack | ReceivePack deriving (Show) @@ -75,8 +78,8 @@ | LOCKCONTENT Key | UNLOCKCONTENT | REMOVE Key - | GET Offset AssociatedFile Key - | PUT AssociatedFile Key + | GET Offset ProtoAssociatedFile Key + | PUT ProtoAssociatedFile Key | PUT_FROM Offset | ALREADY_HAVE | SUCCESS @@ -154,7 +157,7 @@ deserialize "git-receive-pack" = Just ReceivePack deserialize _ = Nothing --- | Since AssociatedFile is not the last thing in a protocol line, +-- | Since ProtoAssociatedFile is not the last thing in a protocol line, -- its serialization cannot contain any whitespace. This is handled -- by replacing whitespace with '%' (and '%' with '%%') -- @@ -162,11 +165,11 @@ -- to avoid any unusual characters that might cause problems when it's -- displayed to the user. -- --- These mungings are ok, because an AssociatedFile is only ever displayed +-- These mungings are ok, because a ProtoAssociatedFile is only ever displayed -- to the user and does not need to match a file on disk. -instance Proto.Serializable AssociatedFile where - serialize (AssociatedFile Nothing) = "" - serialize (AssociatedFile (Just af)) = +instance Proto.Serializable ProtoAssociatedFile where + serialize (ProtoAssociatedFile (AssociatedFile Nothing)) = "" + serialize (ProtoAssociatedFile (AssociatedFile (Just af))) = decodeBS' $ toInternalGitPath $ encodeBS' $ concatMap esc $ fromRawFilePath af where esc '%' = "%%" @@ -175,9 +178,10 @@ | otherwise = [c] deserialize s = case fromRawFilePath $ fromInternalGitPath $ toRawFilePath $ deesc [] s of - [] -> Just (AssociatedFile Nothing) + [] -> Just $ ProtoAssociatedFile $ AssociatedFile Nothing f - | isRelative f -> Just $ AssociatedFile $ Just $ toRawFilePath f + | isRelative f -> Just $ ProtoAssociatedFile $ + AssociatedFile $ Just $ toRawFilePath f | otherwise -> Nothing where deesc b [] = reverse b @@ -277,7 +281,7 @@ -- present, runs the protocol action with False. | WaitRefChange (ChangedRefs -> c) -- ^ Waits for one or more git refs to change and returns them.a - | UpdateMeterTotalSize Meter Integer c + | UpdateMeterTotalSize Meter TotalSize c -- ^ Updates the total size of a Meter, for cases where the size is -- not known until the data is being received. | RunValidityCheck (Annex Validity) (Validity -> c) @@ -349,14 +353,15 @@ get :: FilePath -> Key -> AssociatedFile -> Meter -> MeterUpdate -> Proto (Bool, Verification) get dest key af m p = - receiveContent (Just m) p sizer storer (\offset -> GET offset af key) + receiveContent (Just m) p sizer storer $ \offset -> + GET offset (ProtoAssociatedFile af) key where sizer = fileSize dest storer = storeContentTo dest put :: Key -> AssociatedFile -> MeterUpdate -> Proto Bool put key af p = do - net $ sendMessage (PUT af key) + net $ sendMessage (PUT (ProtoAssociatedFile af) key) r <- net receiveMessage case r of Just (PUT_FROM offset) -> sendContent key af offset p @@ -461,14 +466,14 @@ ServeReadOnly -> do readonlyerror return ServerContinue - handler (PUT af key) = case servermode of + handler (PUT (ProtoAssociatedFile af) key) = case servermode of ServeReadWrite -> handleput af key ServeAppendOnly -> handleput af key ServeReadOnly -> do readonlyerror return ServerContinue - handler (GET offset key af) = do - void $ sendContent af key offset nullMeterUpdate + handler (GET offset (ProtoAssociatedFile af) key) = do + void $ sendContent key af offset nullMeterUpdate -- setPresent not called because the peer may have -- requested the data but not permanently stored it. return ServerContinue @@ -508,13 +513,15 @@ sendContent :: Key -> AssociatedFile -> Offset -> MeterUpdate -> Proto Bool sendContent key af offset@(Offset n) p = go =<< local (contentSize key) where - go Nothing = sender (Len 0) L.empty (return Valid) go (Just (Len totallen)) = do let len = totallen - n if len <= 0 then sender (Len 0) L.empty (return Valid) else local $ readContent key af offset $ sender (Len len) + -- Content not available to send. Indicate this by sending + -- empty data and indlicate it's invalid. + go Nothing = sender (Len 0) L.empty (return Invalid) sender len content validitycheck = do let p' = offsetMeterUpdate p (toBytesProcessed n) net $ sendMessage (DATA len) @@ -541,7 +548,7 @@ Just (DATA len@(Len l)) -> do local $ case mm of Nothing -> return () - Just m -> updateMeterTotalSize m (n+l) + Just m -> updateMeterTotalSize m (TotalSize (n+l)) ver <- net getProtocolVersion let validitycheck = if ver >= ProtocolVersion 1 then net receiveMessage >>= \case diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -70,6 +70,7 @@ import Types.Remote import qualified Annex import Annex.UUID +import Annex.Action import Logs.UUID import Logs.Trust import Logs.Location hiding (logStatus) @@ -81,21 +82,6 @@ import Config.DynamicConfig import Git.Types (RemoteName, ConfigKey(..), fromConfigValue) import Utility.Aeson - -{- Runs an action that may throw exceptions, catching and displaying them. -} -action :: Annex () -> Annex Bool -action a = tryNonAsync a >>= \case - Right () -> return True - Left e -> do - warning (show e) - return False - -verifiedAction :: Annex Verification -> Annex (Bool, Verification) -verifiedAction a = tryNonAsync a >>= \case - Right v -> return (True, v) - Left e -> do - warning (show e) - return (False, UnVerified) {- Map from UUIDs of Remotes to a calculated value. -} remoteMap :: (Remote -> v) -> Annex (M.Map UUID v) diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -46,6 +46,7 @@ , setup = adbSetup , exportSupported = exportIsSupported , importSupported = importIsSupported + , thirdPartyPopulated = False } androiddirectoryField :: RemoteConfigField @@ -75,6 +76,7 @@ { storeExport = storeExportM serial adir , retrieveExport = retrieveExportM serial adir , removeExport = removeExportM serial adir + , versionedExport = False , checkPresentExport = checkPresentExportM this serial adir , removeExportDirectory = Just $ removeExportDirectoryM serial adir , renameExport = renameExportM serial adir @@ -99,6 +101,7 @@ , availability = LocallyAvailable , readonly = False , appendonly = False + , untrustworthy = False , mkUnavailable = return Nothing , getInfo = return [ ("androidserial", fromAndroidSerial serial) @@ -286,8 +289,11 @@ ] listImportableContentsM :: AndroidSerial -> AndroidPath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) -listImportableContentsM serial adir = - process <$> adbShell serial +listImportableContentsM serial adir = adbfind >>= \case + Just ls -> return $ Just $ ImportableContents (mapMaybe mk ls) [] + Nothing -> giveup "adb find failed" + where + adbfind = adbShell serial [ Param "find" -- trailing slash is needed, or android's find command -- won't recurse into the directory @@ -297,9 +303,6 @@ , Param "-c", Param statformat , Param "{}", Param "+" ] - where - process Nothing = Nothing - process (Just ls) = Just $ ImportableContents (mapMaybe mk ls) [] statformat = adbStatFormat ++ "\t%n" diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -49,6 +49,7 @@ , setup = error "not supported" , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } -- There is only one bittorrent remote, and it always exists. @@ -85,6 +86,7 @@ , getRepo = return r , readonly = True , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = return Nothing @@ -181,7 +183,7 @@ - torrent file once. -} registerTorrentCleanup :: URLString -> Annex () -registerTorrentCleanup u = Annex.addCleanup (TorrentCleanup u) $ +registerTorrentCleanup u = Annex.addCleanupAction (TorrentCleanup u) $ liftIO . removeWhenExistsWith R.removeLink =<< tmpTorrentFile u {- Downloads the torrent file. (Not its contents.) -} diff --git a/Remote/Borg.hs b/Remote/Borg.hs new file mode 100644 --- /dev/null +++ b/Remote/Borg.hs @@ -0,0 +1,345 @@ +{- Using borg as a remote. + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Remote.Borg (remote) where + +import Annex.Common +import Types.Remote +import Types.Creds +import Types.Import +import qualified Git +import qualified Git.LsTree as LsTree +import Git.Types (toTreeItemType, TreeItemType(..)) +import Git.FilePath +import Config +import Config.Cost +import Annex.Tmp +import Annex.SpecialRemote.Config +import Remote.Helper.Special +import Remote.Helper.ExportImport +import Annex.UUID +import Types.ProposedAccepted +import Utility.Metered +import Logs.Export +import qualified Remote.Helper.ThirdPartyPopulated as ThirdPartyPopulated + +import Data.Either +import Text.Read +import Control.Exception (evaluate) +import Control.DeepSeq +import qualified Data.Map as M +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified System.FilePath.ByteString as P + +type BorgRepo = String + +type BorgArchiveName = S.ByteString + +remote :: RemoteType +remote = RemoteType + { typename = "borg" + , enumerate = const (findSpecialRemotes "borgrepo") + , generate = gen + , configParser = mkRemoteConfigParser + [ optionalStringParser borgrepoField + (FieldDesc "(required) borg repository to use") + , optionalStringParser subdirField + (FieldDesc "limit to a subdirectory of the borg repository") + , yesNoParser appendonlyField (Just False) + (FieldDesc "you will not use borg to delete from the repository") + ] + , setup = borgSetup + , exportSupported = exportUnsupported + , importSupported = importIsSupported + , thirdPartyPopulated = True + } + +borgrepoField :: RemoteConfigField +borgrepoField = Accepted "borgrepo" + +subdirField :: RemoteConfigField +subdirField = Accepted "subdir" + +appendonlyField :: RemoteConfigField +appendonlyField = Accepted "appendonly" + +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) +gen r u rc gc rs = do + c <- parsedRemoteConfig remote rc + cst <- remoteCost gc $ + if borgLocal borgrepo + then nearlyCheapRemoteCost + else expensiveRemoteCost + return $ Just $ Remote + { uuid = u + , cost = cst + , name = Git.repoDescribe r + , storeKey = storeKeyDummy + , retrieveKeyFile = retrieveKeyFileDummy + , retrieveKeyFileCheap = Nothing + -- Borg cryptographically verifies content. + , retrievalSecurityPolicy = RetrievalAllKeysSecure + , removeKey = removeKeyDummy + , lockContent = Nothing + , checkPresent = checkPresentDummy + , checkPresentCheap = borgLocal borgrepo + , exportActions = exportUnsupported + , importActions = ImportActions + { listImportableContents = listImportableContentsM u borgrepo c + , importKey = Just ThirdPartyPopulated.importKey + , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM borgrepo + , checkPresentExportWithContentIdentifier = checkPresentExportWithContentIdentifierM borgrepo + -- This remote is thirdPartyPopulated, so these + -- actions will never be used. + , storeExportWithContentIdentifier = storeExportWithContentIdentifier importUnsupported + , removeExportDirectoryWhenEmpty = removeExportDirectoryWhenEmpty importUnsupported + , removeExportWithContentIdentifier = removeExportWithContentIdentifier importUnsupported + } + , whereisKey = Nothing + , remoteFsck = Nothing + , repairRepo = Nothing + , config = c + , getRepo = return r + , gitconfig = gc + , localpath = if borgLocal borgrepo && not (null borgrepo) + then Just borgrepo + else Nothing + , remotetype = remote + , availability = if borgLocal borgrepo then LocallyAvailable else GloballyAvailable + , readonly = False + , appendonly = False + -- When the user sets the appendonly field, they are + -- promising not to delete content out from under git-annex + -- using borg, so the remote is not untrustworthy. + , untrustworthy = maybe True not $ + getRemoteConfigValue appendonlyField c + , mkUnavailable = return Nothing + , getInfo = return [("repo", borgrepo)] + , claimUrl = Nothing + , checkUrl = Nothing + , remoteStateHandle = rs + } + where + borgrepo = fromMaybe (giveup "missing borgrepo") $ remoteAnnexBorgRepo gc + +borgSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID) +borgSetup _ mu _ c _gc = do + u <- maybe (liftIO genUUID) return mu + + -- verify configuration is sane + let borgrepo = maybe (giveup "Specify borgrepo=") fromProposedAccepted $ + M.lookup borgrepoField c + + -- The borgrepo is stored in git config, as well as this repo's + -- persistant state, so it can vary between hosts. + gitConfigSpecialRemote u c [("borgrepo", borgrepo)] + + return (c, u) + +borgLocal :: BorgRepo -> Bool +borgLocal = notElem ':' + +borgArchive :: BorgRepo -> BorgArchiveName -> String +borgArchive r n = r ++ "::" ++ decodeBS' n + +listImportableContentsM :: UUID -> BorgRepo -> ParsedRemoteConfig -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +listImportableContentsM u borgrepo c = prompt $ do + imported <- getImported u + ls <- withborglist borgrepo Nothing formatarchivelist $ \as -> + forM as $ \archivename -> + case M.lookup archivename imported of + Just getfast -> return $ Left (archivename, getfast) + Nothing -> Right <$> + let archive = borgArchive borgrepo archivename + in withborglist archive subdir formatfilelist $ + liftIO . evaluate . force . parsefilelist archivename + if all isLeft ls && M.null (M.difference imported (M.fromList (lefts ls))) + then return Nothing -- unchanged since last time, avoid work + else Just . mkimportablecontents <$> mapM (either snd pure) ls + where + withborglist what addparam format a = do + let p = proc "borg" $ toCommand $ catMaybes + [ Just (Param "list") + , Just (Param "--format") + , Just (Param format) + , Just (Param what) + , addparam + ] + (Nothing, Just h, Nothing, pid) <- liftIO $ createProcess $ p + { std_out = CreatePipe } + l <- liftIO $ map L.toStrict + . filter (not . L.null) + . L.split 0 + <$> L.hGetContents h + let cleanup = liftIO $ do + hClose h + forceSuccessProcess p pid + a l `finally` cleanup + + formatarchivelist = "{barchive}{NUL}" + + formatfilelist = "{size}{NUL}{path}{NUL}" + + subdir = File <$> getRemoteConfigValue subdirField c + + parsefilelist archivename (bsz:f:rest) = case readMaybe (fromRawFilePath bsz) of + Nothing -> parsefilelist archivename rest + Just sz -> + let loc = genImportLocation archivename f + -- This does a little unncessary work to parse the + -- key, which is then thrown away. But, it lets the + -- file list be shrank down to only the ones that are + -- importable keys, so avoids needing to buffer all + -- the rest of the files in memory. + in case ThirdPartyPopulated.importKey' loc sz of + Just _k -> (loc, (borgContentIdentifier, sz)) + : parsefilelist archivename rest + Nothing -> parsefilelist archivename rest + parsefilelist _ _ = [] + + -- importableHistory is not used for retrieval, so is not + -- populated with old archives. Instead, a tree of archives + -- is constructed, by genImportLocation including the archive + -- name in the ImportLocation. + mkimportablecontents l = ImportableContents + { importableContents = concat l + , importableHistory = [] + } + +-- We do not need a ContentIdentifier in order to retrieve a file from +-- borg; the ImportLocation contains all that's needed. So, this is left +-- empty. +borgContentIdentifier :: ContentIdentifier +borgContentIdentifier = ContentIdentifier mempty + +-- Borg does not allow / in the name of an archive, so the archive +-- name will always be the first directory in the ImportLocation. +-- +-- Paths in a borg archive are always relative, not absolute, so the use of +-- to combine the archive name with the path will always work. +genImportLocation :: BorgArchiveName -> RawFilePath -> ImportLocation +genImportLocation archivename p = + ThirdPartyPopulated.mkThirdPartyImportLocation $ + archivename P. p + +extractImportLocation :: ImportLocation -> (BorgArchiveName, RawFilePath) +extractImportLocation loc = go $ P.splitDirectories $ + ThirdPartyPopulated.fromThirdPartyImportLocation loc + where + go (archivename:rest) = (archivename, P.joinPath rest) + go _ = giveup $ "Unable to parse import location " ++ fromRawFilePath (fromImportLocation loc) + +-- Since the ImportLocation starts with the archive name, a list of all +-- archive names we've already imported can be found by just listing the +-- last imported tree. And the contents of those archives can be retrieved +-- by listing the subtree recursively, which will likely be quite a lot +-- faster than running borg. +getImported :: UUID -> Annex (M.Map BorgArchiveName (Annex [(ImportLocation, (ContentIdentifier, ByteSize))])) +getImported u = M.unions <$> (mapM go . exportedTreeishes =<< getExport u) + where + go t = M.fromList . mapMaybe mk + <$> inRepo (LsTree.lsTreeStrict LsTree.LsTreeNonRecursive t) + + mk ti + | toTreeItemType (LsTree.mode ti) == Just TreeSubtree = Just + ( getTopFilePath (LsTree.file ti) + , getcontents + (getTopFilePath (LsTree.file ti)) + (LsTree.sha ti) + ) + | otherwise = Nothing + + getcontents archivename t = mapMaybe (mkcontents archivename) + <$> inRepo (LsTree.lsTreeStrict LsTree.LsTreeRecursive t) + + mkcontents archivename ti = do + let f = ThirdPartyPopulated.fromThirdPartyImportLocation $ + mkImportLocation $ getTopFilePath $ LsTree.file ti + k <- deserializeKey' (P.takeFileName f) + return + ( genImportLocation archivename f + , + ( borgContentIdentifier + -- defaulting to 0 size is ok, this size + -- only gets used by + -- ThirdPartyPopulated.importKey, + -- which ignores the size when the key + -- does not have a size. + , fromMaybe 0 (fromKey keySize k) + ) + ) + +-- Check if the file is still there in the borg archive. +-- Does not check that the content is unchanged; we assume that +-- the content of files in borg archives does not change, which is normally +-- the case. But archives may be deleted, and files may be deleted. +checkPresentExportWithContentIdentifierM :: BorgRepo -> Key -> ImportLocation -> [ContentIdentifier] -> Annex Bool +checkPresentExportWithContentIdentifierM borgrepo _ loc _ = prompt $ liftIO $ do + let p = proc "borg" $ toCommand + [ Param "list" + , Param "--format" + , Param "1" + , Param (borgArchive borgrepo archivename) + , File (fromRawFilePath archivefile) + ] + -- borg list exits nonzero with an error message if an archive + -- no longer exists. But, the user can delete archives at any + -- time they want. So, hide errors, and if it exists nonzero, + -- check if the borg repository still exists, and only throw an + -- exception if not. + (Nothing, Just h, Nothing, pid) <- withNullHandle $ \nullh -> + createProcess $ p + { std_out = CreatePipe + , std_err = UseHandle nullh + } + ok <- (== "1") <$> hGetContentsStrict h + hClose h + ifM (checkSuccessProcess pid) + ( return ok + , checkrepoexists + ) + where + (archivename, archivefile) = extractImportLocation loc + + checkrepoexists = do + let p = proc "borg" $ toCommand + [ Param "list" + , Param "--format" + , Param "1" + , Param borgrepo + ] + (Nothing, Nothing, Nothing, pid) <- withNullHandle $ \nullh -> + createProcess $ p + { std_out = UseHandle nullh } + ifM (checkSuccessProcess pid) + ( return False -- repo exists, content not in it + , giveup $ "Unable to access borg repository " ++ borgrepo + ) + +retrieveExportWithContentIdentifierM :: BorgRepo -> ImportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key +retrieveExportWithContentIdentifierM borgrepo loc _ dest mkk _ = do + showOutput + prompt $ withOtherTmp $ \othertmp -> liftIO $ do + -- borgrepo could be relative, and borg has to be run + -- in the temp directory to get it to write there + absborgrepo <- fromRawFilePath <$> absPath (toRawFilePath borgrepo) + let p = proc "borg" $ toCommand + [ Param "extract" + , Param (borgArchive absborgrepo archivename) + , File (fromRawFilePath archivefile) + ] + (Nothing, Nothing, Nothing, pid) <- createProcess $ p + { cwd = Just (fromRawFilePath othertmp) } + forceSuccessProcess p pid + -- Filepaths in borg archives are relative, so it's ok to + -- combine with + moveFile (fromRawFilePath othertmp fromRawFilePath archivefile) dest + removeDirectoryRecursive (fromRawFilePath othertmp) + mkk + where + (archivename, archivefile) = extractImportLocation loc diff --git a/Remote/Bup.hs b/Remote/Bup.hs --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -50,6 +50,7 @@ , setup = bupSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } buprepoField :: RemoteConfigField @@ -94,6 +95,7 @@ , availability = if bupLocal buprepo then LocallyAvailable else GloballyAvailable , readonly = False , appendonly = False + , untrustworthy = False , mkUnavailable = return Nothing , getInfo = return [("repo", buprepo)] , claimUrl = Nothing diff --git a/Remote/Ddar.hs b/Remote/Ddar.hs --- a/Remote/Ddar.hs +++ b/Remote/Ddar.hs @@ -45,6 +45,7 @@ , setup = ddarSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } ddarrepoField :: RemoteConfigField @@ -97,6 +98,7 @@ , availability = if ddarLocal ddarrepo then LocallyAvailable else GloballyAvailable , readonly = False , appendonly = False + , untrustworthy = False , mkUnavailable = return Nothing , getInfo = return [("repo", ddarRepoLocation ddarrepo)] , claimUrl = Nothing diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -56,6 +56,7 @@ , setup = directorySetup , exportSupported = exportIsSupported , importSupported = importIsSupported + , thirdPartyPopulated = False } directoryField :: RemoteConfigField @@ -87,6 +88,7 @@ { storeExport = storeExportM dir , retrieveExport = retrieveExportM dir , removeExport = removeExportM dir + , versionedExport = False , checkPresentExport = checkPresentExportM dir -- Not needed because removeExportLocation -- auto-removes empty directories. @@ -113,6 +115,7 @@ , localpath = Just dir' , readonly = False , appendonly = False + , untrustworthy = False , availability = LocallyAvailable , remotetype = remote , mkUnavailable = gen r u rc @@ -337,10 +340,10 @@ in go (upFrom loc') =<< tryIO (removeDirectory p) listImportableContentsM :: RawFilePath -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) -listImportableContentsM dir = catchMaybeIO $ liftIO $ do +listImportableContentsM dir = liftIO $ do l <- dirContentsRecursive (fromRawFilePath dir) l' <- mapM (go . toRawFilePath) l - return $ ImportableContents (catMaybes l') [] + return $ Just $ ImportableContents (catMaybes l') [] where go f = do st <- R.getFileStatus f @@ -369,13 +372,15 @@ | new == Just old = cont | otherwise = giveup "file content has changed" -importKeyM :: RawFilePath -> ExportLocation -> ContentIdentifier -> MeterUpdate -> Annex Key -importKeyM dir loc cid p = do +importKeyM :: RawFilePath -> ExportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) +importKeyM dir loc cid sz p = do backend <- chooseBackend f - k <- fst <$> genKey ks p backend + unsizedk <- fst <$> genKey ks p backend + let k = alterKey unsizedk $ \kd -> kd + { keySize = keySize kd <|> Just sz } currcid <- liftIO $ mkContentIdentifier absf =<< R.getFileStatus absf - guardSameContentIdentifiers (return k) cid currcid + guardSameContentIdentifiers (return (Just k)) cid currcid where f = fromExportLocation loc absf = dir P. f diff --git a/Remote/External.hs b/Remote/External.hs --- a/Remote/External.hs +++ b/Remote/External.hs @@ -53,6 +53,7 @@ , setup = externalSetup , exportSupported = checkExportSupported , importSupported = importUnsupported + , thirdPartyPopulated = False } externaltypeField :: RemoteConfigField @@ -81,7 +82,7 @@ | otherwise = do c <- parsedRemoteConfig remote rc external <- newExternal externaltype (Just u) c (Just gc) (Just rs) - Annex.addCleanup (RemoteCleanup u) $ stopExternal external + Annex.addCleanupAction (RemoteCleanup u) $ stopExternal external cst <- getCost external r gc avail <- getAvailability external r gc exportsupported <- if exportTree c @@ -92,6 +93,7 @@ { storeExport = storeExportM external , retrieveExport = retrieveExportM external , removeExport = removeExportM external + , versionedExport = False , checkPresentExport = checkPresentExportM external , removeExportDirectory = Just $ removeExportDirectoryM external , renameExport = renameExportM external @@ -142,6 +144,7 @@ , gitconfig = gc , readonly = False , appendonly = False + , untrustworthy = False , availability = avail , remotetype = remote { exportSupported = cheapexportsupported } @@ -619,7 +622,8 @@ `onException` store UncheckedExternalAsync if asyncExtensionEnabled extensions then do - relay <- liftIO $ runRelayToExternalAsync external st + annexrunner <- Annex.makeRunner + relay <- liftIO $ runRelayToExternalAsync external st annexrunner st' <- liftIO $ asyncRelayExternalState relay store (ExternalAsync relay) return st' diff --git a/Remote/External/AsyncExtension.hs b/Remote/External/AsyncExtension.hs --- a/Remote/External/AsyncExtension.hs +++ b/Remote/External/AsyncExtension.hs @@ -11,9 +11,10 @@ module Remote.External.AsyncExtension (runRelayToExternalAsync) where import Common +import Annex import Messages import Remote.External.Types -import Utility.SimpleProtocol as Proto +import qualified Utility.SimpleProtocol as Proto import Control.Concurrent.Async import Control.Concurrent.STM @@ -23,13 +24,13 @@ -- | Starts a thread that will handle all communication with the external -- process. The input ExternalState communicates directly with the external -- process. -runRelayToExternalAsync :: External -> ExternalState -> IO ExternalAsyncRelay -runRelayToExternalAsync external st = do +runRelayToExternalAsync :: External -> ExternalState -> (Annex () -> IO ()) -> IO ExternalAsyncRelay +runRelayToExternalAsync external st annexrunner = do jidmap <- newTVarIO M.empty sendq <- newSendQueue nextjid <- newTVarIO (JobId 1) - void $ async $ sendloop st sendq - void $ async $ receiveloop external st jidmap sendq + sender <- async $ sendloop st sendq + receiver <- async $ receiveloop external st jidmap sendq sender annexrunner return $ ExternalAsyncRelay $ do receiveq <- newReceiveQueue jid <- atomically $ do @@ -44,7 +45,7 @@ (toAsyncWrapped msg, jid) , externalReceive = atomically (readTBMChan receiveq) -- This shuts down the whole relay. - , externalShutdown = shutdown external st sendq + , externalShutdown = shutdown external st sendq sender receiver -- These three TMVars are shared amoung all -- ExternalStates that use this relay; they're -- common state about the external process. @@ -65,14 +66,14 @@ newSendQueue :: IO SendQueue newSendQueue = newTBMChanIO 10 -receiveloop :: External -> ExternalState -> JidMap -> SendQueue -> IO () -receiveloop external st jidmap sendq = externalReceive st >>= \case +receiveloop :: External -> ExternalState -> JidMap -> SendQueue -> Async () -> (Annex () -> IO ()) -> IO () +receiveloop external st jidmap sendq sendthread annexrunner = externalReceive st >>= \case Just l -> case parseMessage l :: Maybe AsyncMessage of Just (AsyncMessage jid msg) -> M.lookup jid <$> readTVarIO jidmap >>= \case Just c -> do atomically $ writeTBMChan c msg - receiveloop external st jidmap sendq + receiveloop external st jidmap sendq sendthread annexrunner Nothing -> protoerr "unknown job number" Nothing -> case parseMessage l :: Maybe ExceptionalMessage of Just _ -> do @@ -80,16 +81,17 @@ m <- readTVarIO jidmap forM_ (M.elems m) $ \c -> atomically $ writeTBMChan c l - receiveloop external st jidmap sendq + receiveloop external st jidmap sendq sendthread annexrunner Nothing -> protoerr "unexpected non-async message" Nothing -> closeandshutdown where protoerr s = do - warningIO $ "async external special remote protocol error: " ++ s + annexrunner $ warning $ "async external special remote protocol error: " ++ s closeandshutdown closeandshutdown = do - shutdown external st sendq True + dummy <- async noop + shutdown external st sendq sendthread dummy True m <- atomically $ readTVar jidmap forM_ (M.elems m) (atomically . closeTBMChan) @@ -110,8 +112,15 @@ where wrapjid msg jid = AsyncMessage jid $ unwords $ Proto.formatMessage msg -shutdown :: External -> ExternalState -> SendQueue -> Bool -> IO () -shutdown external st sendq b = do +shutdown :: External -> ExternalState -> SendQueue -> Async () -> Async () -> Bool -> IO () +shutdown external st sendq sendthread receivethread b = do + -- Receive thread is normally blocked reading from a handle. + -- That can block closing the handle, so it needs to be canceled. + cancel receivethread + -- Cleanly shutdown the send thread as well, allowing it to finish + -- writing anything that was buffered. + atomically $ closeTBMChan sendq + wait sendthread r <- atomically $ do r <- tryTakeTMVar (externalAsync external) putTMVar (externalAsync external) @@ -120,4 +129,3 @@ case r of Just (ExternalAsync _) -> externalShutdown st b _ -> noop - atomically $ closeTBMChan sendq diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -78,6 +78,7 @@ , setup = gCryptSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } gitRepoField :: RemoteConfigField @@ -152,6 +153,7 @@ , gitconfig = gc , readonly = Git.repoIsHttp r , appendonly = False + , untrustworthy = False , availability = availabilityCalc r , remotetype = remote , mkUnavailable = return Nothing diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -87,6 +87,7 @@ , setup = gitSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } locationField :: RemoteConfigField @@ -204,6 +205,7 @@ , gitconfig = gc , readonly = Git.repoIsHttp r , appendonly = False + , untrustworthy = False , availability = availabilityCalc r , remotetype = remote , mkUnavailable = unavailable r u rc gc rs @@ -339,7 +341,7 @@ Annex.BranchState.disableUpdate catchNonAsync autoInitialize $ \e -> warning $ "remote " ++ Git.repoDescribe r ++ - " :" ++ show e + ":" ++ show e Annex.getState Annex.repo s <- Annex.new r Annex.eval s $ check `finally` stopCoProcesses @@ -690,7 +692,7 @@ copier <- mkCopier hardlink st params let verify = Annex.Content.RemoteVerify r let rsp = RetrievalAllKeysSecure - res <- Annex.Content.getViaTmp rsp verify key file $ \dest -> + 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) Annex.Content.saveState True @@ -832,7 +834,7 @@ commitOnCleanup :: Git.Repo -> Remote -> State -> Annex a -> Annex a commitOnCleanup repo r st a = go `after` a where - go = Annex.addCleanup (RemoteCleanup $ uuid r) cleanup + go = Annex.addCleanupAction (RemoteCleanup $ uuid r) cleanup cleanup | not $ Git.repoIsUrl repo = onLocalFast st $ doQuietSideAction $ diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -74,6 +74,7 @@ , setup = mySetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } urlField :: RemoteConfigField @@ -132,6 +133,7 @@ , readonly = False -- content cannot be removed from a git-lfs repo , appendonly = True + , untrustworthy = False , mkUnavailable = return Nothing , getInfo = gitRepoInfo (this c cst h) , claimUrl = Nothing diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -48,6 +48,7 @@ , setup = glacierSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } datacenterField :: RemoteConfigField @@ -98,6 +99,7 @@ , localpath = Nothing , readonly = False , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = return Nothing diff --git a/Remote/Helper/Chunked/Legacy.hs b/Remote/Helper/Chunked/Legacy.hs --- a/Remote/Helper/Chunked/Legacy.hs +++ b/Remote/Helper/Chunked/Legacy.hs @@ -85,8 +85,8 @@ - But this is the best that can be done with the storer interface that - writes a whole L.ByteString at a time. -} -storeChunked :: ChunkSize -> [FilePath] -> (FilePath -> L.ByteString -> IO ()) -> L.ByteString -> IO [FilePath] -storeChunked chunksize dests storer content = +storeChunked :: (Annex () -> IO ()) -> ChunkSize -> [FilePath] -> (FilePath -> L.ByteString -> IO ()) -> L.ByteString -> IO [FilePath] +storeChunked annexrunner chunksize dests storer content = either onerr return =<< tryNonAsync (go (Just chunksize) dests) where go _ [] = return [] -- no dests!? @@ -99,7 +99,7 @@ | otherwise = storechunks sz [] dests content onerr e = do - warningIO (show e) + annexrunner $ warning (show e) return [] storechunks _ _ [] _ = return [] -- ran out of dests diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -20,6 +20,7 @@ cipherKey, extractCipher, isEncrypted, + encryptionIsEnabled, describeEncryption, encryptionField, highRandomQualityField @@ -281,6 +282,14 @@ isEncrypted :: ParsedRemoteConfig -> Bool isEncrypted = isJust . extractCipher + +-- Check if encryption is enabled. This can be done before encryption +-- is fully set up yet, so the cipher might not be present yet. +encryptionIsEnabled :: ParsedRemoteConfig -> Bool +encryptionIsEnabled c = case getRemoteConfigValue encryptionField c of + Nothing -> False + Just NoneEncryption -> False + Just _ -> True describeEncryption :: ParsedRemoteConfig -> String describeEncryption c = case extractCipher c of diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -14,7 +14,7 @@ import Types.Key import Types.ProposedAccepted import Backend -import Remote.Helper.Encryptable (isEncrypted) +import Remote.Helper.Encryptable (encryptionIsEnabled) import qualified Database.Export as Export import qualified Database.ContentIdentifier as ContentIdentifier import Annex.Export @@ -39,6 +39,7 @@ , retrieveExport = nope , checkPresentExport = \_ _ -> return False , removeExport = nope + , versionedExport = False , removeExportDirectory = nope , renameExport = \_ _ _ -> return Nothing } @@ -54,7 +55,7 @@ instance HasImportUnsupported (ImportActions Annex) where importUnsupported = ImportActions - { listImportableContents = return Nothing + { listImportableContents = nope , importKey = Nothing , retrieveExportWithContentIdentifier = nope , storeExportWithContentIdentifier = nope @@ -72,7 +73,7 @@ importIsSupported = \_ _ -> return True -- | Prevent or allow exporttree=yes and importtree=yes when --- setting up a new remote, depending on exportSupported and importSupported. +-- setting up a new remote, depending on the remote's capabilities. adjustExportImportRemoteType :: RemoteType -> RemoteType adjustExportImportRemoteType rt = rt { setup = setup' } where @@ -80,10 +81,10 @@ pc <- either giveup return . parseRemoteConfig c =<< configParser rt c let checkconfig supported configured configfield cont = - ifM (supported rt pc gc) + ifM (supported rt pc gc <&&> pure (not (thirdPartyPopulated rt))) ( case st of Init - | configured pc && isEncrypted pc -> + | configured pc && encryptionIsEnabled pc -> giveup $ "cannot enable both encryption and " ++ fromProposedAccepted configfield | otherwise -> cont Enable oldc -> do @@ -97,161 +98,171 @@ ) checkconfig exportSupported exportTree exportTreeField $ checkconfig importSupported importTree importTreeField $ - if importTree pc && not (exportTree pc) - then giveup "cannot enable importtree=yes without also enabling exporttree=yes" - else setup rt st mu cp c gc + setup rt st mu cp c gc --- | Adjust a remote to support exporttree=yes and importree=yes. --- --- Note that all remotes with importree=yes also have exporttree=yes. +-- | Adjust a remote to support exporttree=yes and/or importree=yes. adjustExportImport :: Remote -> RemoteStateHandle -> Annex Remote -adjustExportImport r rs = case getRemoteConfigValue exportTreeField (config r) of - Nothing -> return $ notexport r - Just True -> ifM (isExportSupported r) - ( do - exportdbv <- prepexportdb - r' <- isexport exportdbv - if importTree (config r) - then isimport r' exportdbv - else return r' - , return $ notexport r - ) - Just False -> return $ notexport r - where - notexport r' = notimport r' - { exportActions = exportUnsupported - , remotetype = (remotetype r') - { exportSupported = exportUnsupported - } - } - - notimport r' = r' - { importActions = importUnsupported - , remotetype = (remotetype r') - { importSupported = importUnsupported +adjustExportImport r rs = do + isexport <- pure (exportTree (config r)) + <&&> isExportSupported r + -- When thirdPartyPopulated is True, the remote + -- does not need to be configured with importTree to support + -- imports. + isimport <- pure (importTree (config r) || thirdPartyPopulated (remotetype r)) + <&&> isImportSupported r + let r' = r + { remotetype = (remotetype r) + { exportSupported = if isexport + then exportSupported (remotetype r) + else exportUnsupported + , importSupported = if isimport + then importSupported (remotetype r) + else importUnsupported } } - - isimport r' exportdbv = do - ciddbv <- prepciddb - - let keycids k = do - db <- getciddb ciddbv - liftIO $ ContentIdentifier.getContentIdentifiers db rs k - - let checkpresent k loc = - checkPresentExportWithContentIdentifier - (importActions r') - k loc - =<< keycids k - - return $ r' - { exportActions = (exportActions r') - { storeExport = \f k loc p -> do - db <- getciddb ciddbv - exportdb <- getexportdb exportdbv - oldks <- liftIO $ Export.getExportTreeKey exportdb loc - oldcids <- liftIO $ concat - <$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks - newcid <- storeExportWithContentIdentifier (importActions r') f k loc oldcids p - withExclusiveLock gitAnnexContentIdentifierLock $ do - liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k - liftIO $ ContentIdentifier.flushDbQueue db - recordContentIdentifier rs newcid k - , removeExport = \k loc -> - removeExportWithContentIdentifier (importActions r') k loc - =<< keycids k - , removeExportDirectory = removeExportDirectoryWhenEmpty (importActions r') - -- renameExport is optional, and the - -- remote's implementation may - -- lose modifications to the file - -- (by eg copying and then deleting) - -- so don't use it - , renameExport = \_ _ _ -> return Nothing - , checkPresentExport = checkpresent - } - , checkPresent = if appendonly r' - then checkPresent r' - else \k -> anyM (checkpresent k) - =<< getexportlocs exportdbv k - , getInfo = do - is <- getInfo r' - return (is++[("import", "yes")]) - } + if not isexport && not isimport + then return r' + else adjustExportImport' isexport isimport r' rs - isexport dbv = return $ r - -- Storing a key on an export could be implemented, - -- but it would perform unncessary work - -- when another repository has already stored the - -- key, and the local repository does not know - -- about it. To avoid unnecessary costs, don't do it. - { storeKey = \_ _ _ -> - giveup "remote is configured with exporttree=yes; use `git-annex export` to store content on it" - -- Keys can be retrieved using retrieveExport, - -- but since that retrieves from a path in the - -- remote that another writer could have replaced - -- with content not of the requested key, - -- the content has to be strongly verified. - -- - -- appendonly remotes have a key/value store, - -- so don't need to use retrieveExport. However, - -- fall back to it if retrieveKeyFile fails. +adjustExportImport' :: Bool -> Bool -> Remote -> RemoteStateHandle -> Annex Remote +adjustExportImport' isexport isimport r rs = do + dbv <- prepdbv + ciddbv <- prepciddb + let versioned = versionedExport (exportActions r) + return $ r + { exportActions = if isexport + then if isimport + then exportActionsForImport dbv ciddbv (exportActions r) + else exportActions r + else exportUnsupported + , importActions = if isimport + then importActions r + else importUnsupported + , storeKey = \k af p -> + -- Storing a key on an export could be implemented, + -- but it would perform unncessary work + -- when another repository has already stored the + -- key, and the local repository does not know + -- about it. To avoid unnecessary costs, don't do it. + if thirdpartypopulated + then giveup "remote is not populated by git-annex" + else if isexport + then giveup "remote is configured with exporttree=yes; use `git-annex export` to store content on it" + else if isimport + then giveup "remote is configured with importtree=yes and without exporttree=yes; cannot modify content stored on it" + else storeKey r k af p + , removeKey = \k -> + -- Removing a key from an export would need to + -- change the tree in the export log to not include + -- the file. Otherwise, conflicts when removing + -- files would not be dealt with correctly. + -- There does not seem to be a good use case for + -- removing a key from an export in any case. + if thirdpartypopulated + then giveup "dropping content from this remote is not supported" + else if isexport + then giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove" + else if isimport + then giveup "dropping content from this remote is not supported because it is configured with importtree=yes" + else removeKey r k + , lockContent = if versioned + then lockContent r + else Nothing , retrieveKeyFile = \k af dest p -> - let retrieveexport = retrieveKeyFileFromExport dbv k af dest p - in if appendonly r - then retrieveKeyFile r k af dest p - `catchNonAsync` const retrieveexport - else retrieveexport - , retrieveKeyFileCheap = if appendonly r + if isimport + then supportversionedretrieve k af dest p $ + retrieveKeyFileFromImport dbv ciddbv k af dest p + else if isexport + then supportversionedretrieve k af dest p $ + retrieveKeyFileFromExport dbv k af dest p + else retrieveKeyFile r k af dest p + , retrieveKeyFileCheap = if versioned then retrieveKeyFileCheap r else Nothing - -- Removing a key from an export would need to - -- change the tree in the export log to not include - -- the file. Otherwise, conflicts when removing - -- files would not be dealt with correctly. - -- There does not seem to be a good use case for - -- removing a key from an export in any case. - , removeKey = \_k -> giveup "dropping content from an export is not supported; use `git annex export` to export a tree that lacks the files you want to remove" - -- Can't lock content on exports, since they're - -- not key/value stores, and someone else could - -- change what's exported to a file at any time. - -- - -- (except for appendonly remotes) - , lockContent = if appendonly r - then lockContent r - else Nothing - -- Check if any of the files a key was exported to - -- are present. This doesn't guarantee the export - -- contains the right content, which is why export - -- remotes are untrusted. - -- - -- (but appendonly remotes work the same as any - -- non-export remote) - , checkPresent = if appendonly r - then checkPresent r - else \k -> anyM (checkPresentExport (exportActions r) k) - =<< getexportlocs dbv k + , checkPresent = \k -> if versioned + then checkPresent r k + else if isimport + then anyM (checkPresentImport ciddbv k) + =<< getanyexportlocs dbv k + else if isexport + -- Check if any of the files a key + -- was exported to are present. This + -- doesn't guarantee the export + -- contains the right content, + -- if the remote is an export, + -- or if something else can write + -- to it. Remotes that have such + -- problems are made untrusted, + -- so it's not worried about here. + then anyM (checkPresentExport (exportActions r) k) + =<< getanyexportlocs dbv k + else checkPresent r k -- checkPresent from an export is more expensive -- than otherwise, so not cheap. Also, this -- avoids things that look at checkPresentCheap and -- silently skip non-present files from behaving -- in confusing ways when there's an export - -- conflict. + -- conflict (or an import conflict). , checkPresentCheap = False + -- Export/import remotes can lose content stored on them in + -- many ways. This is not a problem with versioned + -- ones though, since they still allow accessing by Key. + -- And for thirdPartyPopulated, it depends on how the + -- content gets actually stored in the remote, so + -- is not overriddden here. + , untrustworthy = + if versioned || thirdPartyPopulated (remotetype r) + then untrustworthy r + else False + -- git-annex testremote cannot be used to test + -- import/export since it stores keys. , mkUnavailable = return Nothing , getInfo = do - ts <- map fromRef . exportedTreeishes - <$> getExport (uuid r) is <- getInfo r - return (is++[("export", "yes"), ("exportedtree", unwords ts)]) + is' <- if isexport && not thirdpartypopulated + then do + ts <- map fromRef . exportedTreeishes + <$> getExport (uuid r) + return (is++[("exporttree", "yes"), ("exportedtree", unwords ts)]) + else return is + return $ if isimport && not thirdpartypopulated + then (is'++[("importtree", "yes")]) + else is' } + where + thirdpartypopulated = thirdPartyPopulated (remotetype r) + -- exportActions adjusted to use the equivilant import actions, + -- which take ContentIdentifiers into account. + exportActionsForImport dbv ciddbv ea = ea + { storeExport = \f k loc p -> do + db <- getciddb ciddbv + exportdb <- getexportdb dbv + oldks <- liftIO $ Export.getExportTreeKey exportdb loc + oldcids <- liftIO $ concat + <$> mapM (ContentIdentifier.getContentIdentifiers db rs) oldks + newcid <- storeExportWithContentIdentifier (importActions r) f k loc oldcids p + withExclusiveLock gitAnnexContentIdentifierLock $ do + liftIO $ ContentIdentifier.recordContentIdentifier db rs newcid k + liftIO $ ContentIdentifier.flushDbQueue db + recordContentIdentifier rs newcid k + , removeExport = \k loc -> + removeExportWithContentIdentifier (importActions r) k loc + =<< getkeycids ciddbv k + , removeExportDirectory = removeExportDirectoryWhenEmpty (importActions r) + -- renameExport is optional, and the remote's + -- implementation may lose modifications to the file + -- (by eg copying and then deleting) so don't use it + , renameExport = \_ _ _ -> return Nothing + , checkPresentExport = checkPresentImport ciddbv + } + prepciddb = do lcklckv <- liftIO newEmptyTMVarIO dbtv <- liftIO newEmptyTMVarIO return (dbtv, lcklckv) - prepexportdb = do + prepdbv = do lcklckv <- liftIO newEmptyTMVarIO dbv <- liftIO newEmptyTMVarIO exportinconflict <- liftIO $ newTVarIO False @@ -306,20 +317,63 @@ liftIO $ atomically $ writeTVar exportinconflict True - getexportlocs dbv k = do + getanyexportlocs dbv k = do db <- getexportdb dbv liftIO $ Export.getExportTree db k + + getfirstexportloc dbv k = do + getexportlocs dbv k >>= \case + [] -> giveup "unknown export location" + (l:_) -> return l + + getexportlocs dbv k = do + db <- getexportdb dbv + liftIO $ Export.getExportTree db k >>= \case + [] -> ifM (atomically $ readTVar $ getexportinconflict dbv) + ( giveup "unknown export location, likely due to the export conflict" + , return [] + ) + ls -> return ls + + getkeycids ciddbv k = do + db <- getciddb ciddbv + liftIO $ ContentIdentifier.getContentIdentifiers db rs k + -- Keys can be retrieved using retrieveExport, but since that + -- retrieves from a path in the remote that another writer could + -- have replaced with content not of the requested key, the content + -- has to be strongly verified. retrieveKeyFileFromExport dbv k _af dest p = ifM (isVerifiable k) ( do - locs <- getexportlocs dbv k - case locs of - [] -> ifM (liftIO $ atomically $ readTVar $ getexportinconflict dbv) - ( giveup "unknown export location, likely due to the export conflict" - , giveup "unknown export location" - ) - (l:_) -> do - retrieveExport (exportActions r) k l dest p - return UnVerified + l <- getfirstexportloc dbv k + retrieveExport (exportActions r) k l dest p + return MustVerify , giveup $ "exported content cannot be verified due to using the " ++ decodeBS (formatKeyVariety (fromKey keyVariety k)) ++ " backend" ) + + retrieveKeyFileFromImport dbv ciddbv k af dest p = + getkeycids ciddbv k >>= \case + (cid:_) -> do + l <- getfirstexportloc dbv k + void $ retrieveExportWithContentIdentifier (importActions r) l cid dest (pure k) p + return UnVerified + -- In case a content identifier is somehow missing, + -- try this instead. + [] -> if isexport + then retrieveKeyFileFromExport dbv k af dest p + else giveup "no content identifier is recorded, unable to retrieve" + + -- versionedExport remotes have a key/value store, so can use + -- the usual retrieveKeyFile, rather than an import/export + -- variant. However, fall back to that if retrieveKeyFile fails. + supportversionedretrieve k af dest p a + | versionedExport (exportActions r) = + retrieveKeyFile r k af dest p + `catchNonAsync` const a + | otherwise = a + + checkPresentImport ciddbv k loc = + checkPresentExportWithContentIdentifier + (importActions r) + k loc + =<< getkeycids ciddbv k diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -76,7 +76,7 @@ -- So, requiring idempotency is the right approach. run starthook - Annex.addCleanup (StopHook $ uuid r) $ runstop lck + Annex.addCleanupAction (StopHook $ uuid r) $ runstop lck runstop lck = do -- Drop any shared lock we have, and take an -- exclusive lock, without blocking. If the lock diff --git a/Remote/Helper/ThirdPartyPopulated.hs b/Remote/Helper/ThirdPartyPopulated.hs new file mode 100644 --- /dev/null +++ b/Remote/Helper/ThirdPartyPopulated.hs @@ -0,0 +1,86 @@ +{- Helpers for thirdPartyPopulated remotes + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE OverloadedStrings #-} + +module Remote.Helper.ThirdPartyPopulated where + +import Annex.Common +import Types.Remote +import Types.Import +import Crypto (isEncKey) +import Utility.Metered + +import qualified System.FilePath.ByteString as P +import qualified Data.ByteString as S + +-- When a remote is thirdPartyPopulated, the files we want are probably +-- in the .git directory. But, git does not really support .git in paths +-- in a git tree. (Such a tree can be built, but it will lead to problems.) +-- And so anything in .git is prevented from being imported. +-- To work around that, this renames that directory when generating an +-- ImportLocation. +mkThirdPartyImportLocation :: RawFilePath -> ImportLocation +mkThirdPartyImportLocation = + mkImportLocation . P.joinPath . map esc . P.splitDirectories + where + esc ".git" = "dotgit" + esc x + | "dotgit" `S.isSuffixOf` x = "dot" <> x + | otherwise = x + +fromThirdPartyImportLocation :: ImportLocation -> RawFilePath +fromThirdPartyImportLocation = + P.joinPath . map unesc . P.splitDirectories . fromImportLocation + where + unesc "dotgit" = ".git" + unesc x + | "dotgit" `S.isSuffixOf` x = S.drop 3 x + | otherwise = x + +-- When a remote is thirdPartyPopulated, and contains a backup of a +-- git-annex repository or some special remotes, this can be used to +-- find only those ImportLocations that are annex object files. +-- All other ImportLocations are ignored. +importKey :: ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> Annex (Maybe Key) +importKey loc _cid sz _ = return $ importKey' loc sz + +importKey' :: ImportLocation -> ByteSize -> Maybe Key +importKey' loc sz = case deserializeKey' f of + Just k + -- Annex objects always are in a subdirectory with the same + -- name as the filename. If this is not the case for the file + -- that was backed up, it is probably not a valid annex object. + -- Eg, it could be something in annex/bad/, or annex/tmp/. + -- Or it could be a file that only happens to have a name + -- like an annex object. + -- (This does unfortunately prevent recognizing files that are + -- part of special remotes that don't use that layout. The most + -- likely special remote to be in a backup, the directory + -- special remote, does use that layout at least.) + | lastMaybe (P.splitDirectories (P.dropFileName p)) /= Just f -> Nothing + -- Chunked or encrypted keys used in special remotes are not + -- supported. + | isChunkKey k || isEncKey k -> Nothing + -- Check that the size of the key is the same as the size of the + -- file stored in the backup. This is a cheap way to make sure it's + -- probabably the actual content of the file. We don't fully + -- verify the content here because that could be a very + -- expensive operation for a large repository; if the user + -- wants to detect every possible data corruption problem + -- (eg, wrong data read off disk during backup, or the object + -- was corrupt in the git-annex repo and that bad object got + -- backed up), they can fsck the remote. + | otherwise -> case fromKey keySize k of + Just sz' + | sz' == sz -> Just k + | otherwise -> Nothing + Nothing -> Just k + Nothing -> Nothing + where + p = fromImportLocation loc + f = P.takeFileName p diff --git a/Remote/Hook.hs b/Remote/Hook.hs --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -40,6 +40,7 @@ , setup = hookSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } hooktypeField :: RemoteConfigField @@ -79,6 +80,7 @@ , gitconfig = gc , readonly = False , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = gen r u rc diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -41,6 +41,7 @@ , setup = httpAlsoSetup , exportSupported = exportIsSupported , importSupported = importUnsupported + , thirdPartyPopulated = False } urlField :: RemoteConfigField @@ -72,6 +73,7 @@ { storeExport = cannotModify , retrieveExport = retriveExportHttpAlso url , removeExport = cannotModify + , versionedExport = False , checkPresentExport = checkPresentExportHttpAlso url , removeExportDirectory = Nothing , renameExport = cannotModify @@ -86,6 +88,7 @@ , getRepo = return r , readonly = True , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = return Nothing diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -36,6 +36,7 @@ import qualified Remote.Ddar import qualified Remote.GitLFS import qualified Remote.HttpAlso +import qualified Remote.Borg import qualified Remote.Hook import qualified Remote.External @@ -57,6 +58,7 @@ , Remote.Ddar.remote , Remote.GitLFS.remote , Remote.HttpAlso.remote + , Remote.Borg.remote , Remote.Hook.remote , Remote.External.remote ] diff --git a/Remote/P2P.hs b/Remote/P2P.hs --- a/Remote/P2P.hs +++ b/Remote/P2P.hs @@ -41,6 +41,7 @@ , setup = error "P2P remotes are set up using git-annex p2p" , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } chainGen :: P2PAddress -> Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) @@ -73,6 +74,7 @@ , gitconfig = gc , readonly = False , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = return Nothing diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -60,6 +60,7 @@ , setup = rsyncSetup , exportSupported = exportIsSupported , importSupported = importUnsupported + , thirdPartyPopulated = False } shellEscapeField :: RemoteConfigField @@ -100,6 +101,7 @@ { storeExport = storeExportM o , retrieveExport = retrieveExportM o , removeExport = removeExportM o + , versionedExport = False , checkPresentExport = checkPresentExportM o , removeExportDirectory = Just (removeExportDirectoryM o) , renameExport = renameExportM o @@ -116,6 +118,7 @@ else Nothing , readonly = False , appendonly = False + , untrustworthy = False , availability = if islocal then LocallyAvailable else GloballyAvailable , remotetype = remote , mkUnavailable = return Nothing diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -118,6 +118,7 @@ , setup = s3Setup , exportSupported = exportIsSupported , importSupported = importIsSupported + , thirdPartyPopulated = False } bucketField :: RemoteConfigField @@ -209,6 +210,7 @@ { storeExport = storeExportS3 hdl this rs info magic , retrieveExport = retrieveExportS3 hdl this info , removeExport = removeExportS3 hdl this rs info + , versionedExport = versioning info , checkPresentExport = checkPresentExportS3 hdl this info -- S3 does not have directories. , removeExportDirectory = Nothing @@ -231,7 +233,8 @@ , gitconfig = gc , localpath = Nothing , readonly = False - , appendonly = versioning info + , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = gen r u (M.insert hostField (Proposed "!dne!") rc) gc rs @@ -552,12 +555,11 @@ listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) listImportableContentsS3 hv r info = withS3Handle hv $ \case - Nothing -> do - warning $ needS3Creds (uuid r) - return Nothing - Just h -> catchMaybeIO $ liftIO $ runResourceT $ - extractFromResourceT =<< startlist h + Nothing -> giveup $ needS3Creds (uuid r) + Just h -> Just <$> go h where + go h = liftIO $ runResourceT $ extractFromResourceT =<< startlist h + startlist h | versioning info = do rsp <- sendS3Handle h $ @@ -656,7 +658,10 @@ S3.getObject (bucket info) o k <- mkkey case extractContentIdentifier cid o of - Right vid -> setS3VersionID info rs k vid + Right vid -> do + vids <- getS3VersionID rs k + unless (vid `elem` map Just vids) $ + setS3VersionID info rs k vid Left _ -> noop return k Nothing -> giveup $ needS3Creds (uuid r) @@ -1132,7 +1137,7 @@ -- version id involves a request for an object, so this keeps track of what -- the object is. data S3VersionID = S3VersionID S3.Object T.Text - deriving (Show) + deriving (Show, Eq) -- smart constructor mkS3VersionID :: S3.Object -> Maybe T.Text -> Maybe S3VersionID diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -67,6 +67,7 @@ , setup = tahoeSetup , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } scsField :: RemoteConfigField @@ -106,6 +107,7 @@ , localpath = Nothing , readonly = False , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = return Nothing diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -32,6 +32,7 @@ , setup = error "not supported" , exportSupported = exportUnsupported , importSupported = importUnsupported + , thirdPartyPopulated = False } -- There is only one web remote, and it always exists. @@ -71,6 +72,7 @@ , getRepo = return r , readonly = True , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = return Nothing diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -28,6 +28,7 @@ import Types.Remote import Types.Export import qualified Git +import qualified Annex import Config import Config.Cost import Annex.SpecialRemote.Config @@ -56,6 +57,7 @@ , setup = webdavSetup , exportSupported = exportIsSupported , importSupported = importUnsupported + , thirdPartyPopulated = False } urlField :: RemoteConfigField @@ -98,6 +100,7 @@ , retrieveExport = retrieveExportDav hdl , checkPresentExport = checkPresentExportDav hdl this , removeExport = removeExportDav hdl + , versionedExport = False , removeExportDirectory = Just $ removeExportDirectoryDav hdl , renameExport = renameExportDav hdl @@ -112,6 +115,7 @@ , localpath = Nothing , readonly = False , appendonly = False + , untrustworthy = False , availability = GloballyAvailable , remotetype = remote , mkUnavailable = gen r u (M.insert urlField (Proposed "http://!dne!/") rc) gc rs @@ -139,8 +143,9 @@ store :: DavHandleVar -> ChunkConfig -> Storer store hv (LegacyChunks chunksize) = fileStorer $ \k f p -> - withDavHandle hv $ \dav -> liftIO $ - withMeteredFile f p $ storeLegacyChunked chunksize k dav + withDavHandle hv $ \dav -> do + annexrunner <- Annex.makeRunner + liftIO $ withMeteredFile f p $ storeLegacyChunked annexrunner chunksize k dav store hv _ = httpStorer $ \k reqbody -> withDavHandle hv $ \dav -> liftIO $ goDAV dav $ do let tmp = keyTmpLocation k @@ -448,15 +453,15 @@ -- Legacy chunking code, to be removed eventually. -- -storeLegacyChunked :: ChunkSize -> Key -> DavHandle -> L.ByteString -> IO () -storeLegacyChunked chunksize k dav b = +storeLegacyChunked :: (Annex () -> IO ()) -> ChunkSize -> Key -> DavHandle -> L.ByteString -> IO () +storeLegacyChunked annexrunner chunksize k dav b = Legacy.storeChunks k tmp dest storer recorder finalizer where storehttp l b' = void $ goDAV dav $ do maybe noop (void . mkColRecursive) (locationParent l) debugDav $ "putContent " ++ l inLocation l $ putContentM (contentType, b') - storer locs = Legacy.storeChunked chunksize locs storehttp b + storer locs = Legacy.storeChunked annexrunner chunksize locs storehttp b recorder l s = storehttp l (L8.fromString s) finalizer tmp' dest' = goDAV dav $ finalizeStore dav tmp' (fromJust $ locationParent dest') diff --git a/Types/CleanupActions.hs b/Types/CleanupActions.hs --- a/Types/CleanupActions.hs +++ b/Types/CleanupActions.hs @@ -1,6 +1,6 @@ {- Enumeration of cleanup actions - - - Copyright 2014 Joey Hess + - Copyright 2014-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -8,9 +8,10 @@ module Types.CleanupActions where import Types.UUID - import Utility.Url +import System.Process (Pid) + data CleanupAction = RemoteCleanup UUID | StopHook UUID @@ -19,4 +20,8 @@ | AdjustedBranchUpdate | TorrentCleanup URLString | OtherTmpCleanup + deriving (Eq, Ord) + +data SignalAction + = PropagateSignalProcessGroup Pid deriving (Eq, Ord) diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -18,10 +18,13 @@ import qualified Data.Map as M import qualified Data.Set as S --- Information about a file or a key that can be matched on. +-- Information about a file and/or a key that can be matched on. data MatchInfo = MatchingFile FileInfo | MatchingKey Key AssociatedFile + -- ^ This is used when matching a file that may be in another + -- branch. The AssociatedFile is the filename, but it should not be + -- accessed from disk when matching. | MatchingInfo ProvidedInfo | MatchingUserInfo UserProvidedInfo @@ -30,7 +33,11 @@ -- ^ path to a file containing the content, for operations -- that examine it , matchFile :: RawFilePath - -- ^ filepath to match on; may be relative to top of repo or cwd + -- ^ filepath to match on; may be relative to top of repo or cwd, + -- depending on how globs in preferred content expressions + -- are intended to be matched + , matchKey :: Maybe Key + -- ^ provided if a key is already known } data ProvidedInfo = ProvidedInfo diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -41,6 +41,7 @@ import Types.Difference import Types.RefSpec import Types.RepoVersion +import Types.StallDetection import Config.DynamicConfig import Utility.HumanTime import Utility.Gpg (GpgCmd, mkGpgCmd) @@ -116,6 +117,7 @@ , annexRetry :: Maybe Integer , annexForwardRetry :: Maybe Integer , annexRetryDelay :: Maybe Seconds + , annexStallDetection :: Maybe StallDetection , annexAllowedUrlSchemes :: S.Set Scheme , annexAllowedIPAddresses :: String , annexAllowUnverifiedDownloads :: Bool @@ -202,6 +204,9 @@ , annexForwardRetry = getmayberead (annexConfig "forward-retry") , annexRetryDelay = Seconds <$> getmayberead (annexConfig "retrydelay") + , annexStallDetection = + either (const Nothing) Just . parseStallDetection + =<< getmaybe (annexConfig "stalldetection") , annexAllowedUrlSchemes = S.fromList $ map mkScheme $ maybe ["http", "https", "ftp"] words $ getmaybe (annexConfig "security.allowed-url-schemes") @@ -306,6 +311,7 @@ , remoteAnnexRetry :: Maybe Integer , remoteAnnexForwardRetry :: Maybe Integer , remoteAnnexRetryDelay :: Maybe Seconds + , remoteAnnexStallDetection :: Maybe StallDetection , remoteAnnexAllowUnverifiedDownloads :: Bool , remoteAnnexConfigUUID :: Maybe UUID @@ -321,6 +327,7 @@ , remoteAnnexGnupgDecryptOptions :: [String] , remoteAnnexRsyncUrl :: Maybe String , remoteAnnexBupRepo :: Maybe String + , remoteAnnexBorgRepo :: Maybe String , remoteAnnexTahoe :: Maybe FilePath , remoteAnnexBupSplitOptions :: [String] , remoteAnnexDirectory :: Maybe FilePath @@ -369,6 +376,9 @@ , remoteAnnexForwardRetry = getmayberead "forward-retry" , remoteAnnexRetryDelay = Seconds <$> getmayberead "retrydelay" + , remoteAnnexStallDetection = + either (const Nothing) Just . parseStallDetection + =<< getmaybe "stalldetection" , remoteAnnexAllowUnverifiedDownloads = (== Just "ACKTHPPT") $ getmaybe ("security-allow-unverified-downloads") , remoteAnnexConfigUUID = toUUID <$> getmaybe "config-uuid" @@ -382,6 +392,7 @@ , remoteAnnexGnupgDecryptOptions = getoptions "gnupg-decrypt-options" , remoteAnnexRsyncUrl = notempty $ getmaybe "rsyncurl" , remoteAnnexBupRepo = getmaybe "buprepo" + , remoteAnnexBorgRepo = getmaybe "borgrepo" , remoteAnnexTahoe = getmaybe "tahoe" , remoteAnnexBupSplitOptions = getoptions "bup-split-options" , remoteAnnexDirectory = notempty $ getmaybe "directory" diff --git a/Types/Import.hs b/Types/Import.hs --- a/Types/Import.hs +++ b/Types/Import.hs @@ -31,7 +31,14 @@ {- An identifier for content stored on a remote that has been imported into - the repository. It should be reasonably short since it is stored in the - - git-annex branch. -} + - git-annex branch. + - + - Since other things than git-annex can modify files on import remotes, + - and git-annex then be used to import those modifications, the + - ContentIdentifier needs to change when a file gets changed in such a + - way. Device, inode, and size is one example of a good content + - identifier. Or a hash if the remote's interface exposes hashes. + -} newtype ContentIdentifier = ContentIdentifier S.ByteString deriving (Eq, Ord, Show, Generic) @@ -52,6 +59,12 @@ -- ^ Used by remotes that support importing historical versions of -- files that are stored in them. This is equivilant to a git -- commit history. + -- + -- When retrieving a historical version of a file, + -- old ImportLocations from importableHistory are not used; + -- the content is no longer expected to be present at those + -- locations. So, if a remote does not support Key/Value access, + -- it should not populate the importableHistory. } deriving (Show, Generic) diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -11,6 +11,7 @@ KeyData(..), Key, fromKey, + keyData, mkKey, alterKey, isKeyPrefix, @@ -201,7 +202,7 @@ {- A filename may be associated with a Key. -} newtype AssociatedFile = AssociatedFile (Maybe RawFilePath) - deriving (Show, Eq, Ord) + deriving (Show, Read, Eq, Ord) {- There are several different varieties of keys. -} data KeyVariety diff --git a/Types/Messages.hs b/Types/Messages.hs --- a/Types/Messages.hs +++ b/Types/Messages.hs @@ -1,6 +1,6 @@ {- git-annex Messages data types - - - Copyright 2012-2018 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -8,12 +8,20 @@ module Types.Messages where import qualified Utility.Aeson as Aeson +import Utility.Metered import Control.Concurrent import System.Console.Regions (ConsoleRegion) +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L -data OutputType = NormalOutput | QuietOutput | JSONOutput JSONOptions - deriving (Show) +data OutputType + = NormalOutput + | QuietOutput + | JSONOutput JSONOptions + | SerializedOutput + (SerializedOutput -> IO ()) + (IO (Maybe SerializedOutputResponse)) data JSONOptions = JSONOptions { jsonProgress :: Bool @@ -53,3 +61,24 @@ , jsonBuffer = Nothing , promptLock = promptlock } + +-- | When communicating with a child process over a pipe while it is +-- performing some action, this is used to pass back output that the child +-- would normally display to the console. +data SerializedOutput + = OutputMessage S.ByteString + | OutputError String + | BeginProgressMeter + | UpdateProgressMeterTotalSize TotalSize + | UpdateProgressMeter BytesProcessed + | EndProgressMeter + | BeginPrompt + | EndPrompt + | JSONObject L.ByteString + -- ^ This is always sent, it's up to the consumer to decide if it + -- wants to display JSON, or human-readable messages. + deriving (Show) + +data SerializedOutputResponse + = ReadyPrompt + deriving (Eq, Show) diff --git a/Types/RefSpec.hs b/Types/RefSpec.hs --- a/Types/RefSpec.hs +++ b/Types/RefSpec.hs @@ -22,7 +22,7 @@ | RemoveMatching Glob allRefSpec :: RefSpec -allRefSpec = [AddMatching $ compileGlob "*" CaseSensative] +allRefSpec = [AddMatching $ compileGlob "*" CaseSensative (GlobFilePath False)] parseRefSpec :: String -> Either String RefSpec parseRefSpec v = case partitionEithers (map mk $ splitc ':' v) of @@ -31,9 +31,9 @@ where mk ('+':s) | any (`elem` s) "*?" = - Right $ AddMatching $ compileGlob s CaseSensative + Right $ AddMatching $ compileGlob s CaseSensative (GlobFilePath False) | otherwise = Right $ AddRef $ Ref $ encodeBS s - mk ('-':s) = Right $ RemoveMatching $ compileGlob s CaseSensative + mk ('-':s) = Right $ RemoveMatching $ compileGlob s CaseSensative (GlobFilePath False) mk "reflog" = Right AddRefLog mk s = Left $ "bad refspec item \"" ++ s ++ "\" (expected + or - prefix)" diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -67,6 +67,11 @@ , exportSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool -- check if a remote of this type is able to support import , importSupported :: ParsedRemoteConfig -> RemoteGitConfig -> a Bool + -- is a remote of this type not a usual key/value store, + -- or export/import of a tree of files, but instead a collection + -- of files, populated by something outside git-annex, some of + -- which may be annex objects? + , thirdPartyPopulated :: Bool } instance Eq (RemoteTypeA a) where @@ -113,9 +118,9 @@ -- Some remotes can checkPresent without an expensive network -- operation. , checkPresentCheap :: Bool - -- Some remotes support export of trees. + -- Some remotes support export. , exportActions :: ExportActions a - -- Some remotes support import of trees. + -- Some remotes support import. , importActions :: ImportActions a -- Some remotes can provide additional details for whereis. , whereisKey :: Maybe (Key -> a [String]) @@ -136,10 +141,15 @@ -- a Remote can be known to be readonly , readonly :: Bool -- a Remote can allow writes but not have a way to delete content - -- from it. Note that an export remote that supports removeExport - -- to remove a file from the exported tree, but still retains the - -- content in accessible form should set this to True. + -- from it. , appendonly :: Bool + -- Set if a remote cannot be trusted to continue to contain the + -- contents of files stored there. Notably, most export/import + -- remotes are untrustworthy because they are not key/value stores. + -- Since this prevents the user from adjusting a remote's trust + -- level, it's often better not not set it and instead let the user + -- decide. + , untrustworthy :: Bool -- a Remote can be globally available. (Ie, "in the cloud".) , availability :: Availability -- the type of the remote @@ -192,6 +202,7 @@ | MustVerify -- ^ Content likely to have been altered during transfer, -- verify even if verification is normally disabled + deriving (Show) unVerified :: Monad m => m a -> m (a, Verification) unVerified a = do @@ -245,6 +256,10 @@ -- Can throw exception if unable to access remote, or if remote -- refuses to remove the content. , removeExport :: Key -> ExportLocation -> a () + -- Set when the content of a Key stored in the remote to an + -- ExportLocation and then removed with removeExport remains + -- accessible to retrieveKeyFile and checkPresent. + , versionedExport :: Bool -- Removes an exported directory. Typically the directory will be -- empty, but it could possibly contain files or other directories, -- and it's ok to delete those (but not required to). @@ -257,7 +272,9 @@ -- the remote refuses to let the directory be removed. , removeExportDirectory :: Maybe (ExportDirectory -> a ()) -- Checks if anything is exported to the remote at the specified - -- ExportLocation. + -- ExportLocation. It may check the size or other characteristics + -- of the Key, but does not need to guarantee that the content on + -- the remote is the same as the Key's content. -- Throws an exception if the remote cannot be accessed. , checkPresentExport :: Key -> ExportLocation -> a Bool -- Renames an already exported file. @@ -275,9 +292,13 @@ -- -- May also find old versions of files that are still stored in the -- remote. + -- + -- Throws exception on failure to access the remote. + -- May return Nothing when the remote is unchanged since last time. { listImportableContents :: a (Maybe (ImportableContents (ContentIdentifier, ByteSize))) - -- Imports a file from the remote, without downloading it, - -- by generating a Key (of any type). + -- Generates a Key (of any type) for the file stored on the + -- remote at the ImportLocation. Does not download the file + -- from the remote. -- -- May update the progress meter if it needs to perform an -- expensive operation, such as hashing a local file. @@ -286,8 +307,13 @@ -- bearing in mind that the file on the remote may have changed -- since the ContentIdentifier was generated. -- - -- Throws exception on failure. - , importKey :: Maybe (ExportLocation -> ContentIdentifier -> MeterUpdate -> a Key) + -- When the remote is thirdPartyPopulated, this should check if the + -- file stored on the remote is the content of an annex object, + -- and return its Key, or Nothing if it is not. Should not + -- otherwise return Nothing. + -- + -- Throws exception on failure to access the remote. + , importKey :: Maybe (ImportLocation -> ContentIdentifier -> ByteSize -> MeterUpdate -> a (Maybe Key)) -- Retrieves a file from the remote. Ensures that the file -- it retrieves has the requested ContentIdentifier. -- diff --git a/Types/StallDetection.hs b/Types/StallDetection.hs new file mode 100644 --- /dev/null +++ b/Types/StallDetection.hs @@ -0,0 +1,29 @@ +{- types for stall detection + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.StallDetection where + +import Utility.DataUnits +import Utility.HumanTime +import Utility.Misc + +-- Unless the given number of bytes have been sent over the given +-- amount of time, there's a stall. +data StallDetection = StallDetection ByteSize Duration + deriving (Show) + +-- Parse eg, "0KiB/60s" +parseStallDetection :: String -> Either String StallDetection +parseStallDetection s = + let (bs, ds) = separate (== '/') s + in do + b <- maybe + (Left $ "Unable to parse stall detection amount " ++ bs) + Right + (readSize dataUnits bs) + d <- parseDuration ds + return (StallDetection b d) diff --git a/Types/Transferrer.hs b/Types/Transferrer.hs new file mode 100644 --- /dev/null +++ b/Types/Transferrer.hs @@ -0,0 +1,159 @@ +{- protocol used by "git-annex transferrer" + - + - Copyright 2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.Transferrer where + +import Annex.Common +import Types.Messages +import Git.Types (RemoteName) +import qualified Utility.SimpleProtocol as Proto +import Utility.Format +import Utility.Metered (TotalSize(..)) + +import Data.Char + +-- Sent to start a transfer. +data TransferRequest + = UploadRequest TransferRemote Key TransferAssociatedFile + | DownloadRequest TransferRemote Key TransferAssociatedFile + | AssistantUploadRequest TransferRemote Key TransferAssociatedFile + | AssistantDownloadRequest TransferRemote Key TransferAssociatedFile + deriving (Show) + +transferRequestRemote :: TransferRequest -> TransferRemote +transferRequestRemote (UploadRequest r _ _) = r +transferRequestRemote (DownloadRequest r _ _) = r +transferRequestRemote (AssistantUploadRequest r _ _) = r +transferRequestRemote (AssistantDownloadRequest r _ _) = r + +data TransferRemote + = TransferRemoteUUID UUID + | TransferRemoteName RemoteName + deriving (Show, Eq) + +newtype TransferAssociatedFile = TransferAssociatedFile AssociatedFile + deriving (Show) + +data TransferResponse + = TransferOutput SerializedOutput + -- ^ any number may be sent before TransferResult + | TransferResult Bool + deriving (Show) + +data TransferSerializedOutputResponse = TransferSerializedOutputResponse SerializedOutputResponse + deriving (Show) + +instance Proto.Sendable TransferRequest where + formatMessage (UploadRequest r kd af) = + [ "u" + , Proto.serialize r + , Proto.serialize kd + , Proto.serialize af + ] + formatMessage (DownloadRequest r kd af) = + [ "d" + , Proto.serialize r + , Proto.serialize kd + , Proto.serialize af + ] + formatMessage (AssistantUploadRequest r kd af) = + [ "au" + , Proto.serialize r + , Proto.serialize kd + , Proto.serialize af + ] + formatMessage (AssistantDownloadRequest r kd af) = + [ "ad" + , Proto.serialize r + , Proto.serialize kd + , Proto.serialize af + ] + +instance Proto.Receivable TransferRequest where + parseCommand "u" = Proto.parse3 UploadRequest + parseCommand "d" = Proto.parse3 DownloadRequest + parseCommand "au" = Proto.parse3 AssistantUploadRequest + parseCommand "ad" = Proto.parse3 AssistantDownloadRequest + parseCommand _ = Proto.parseFail + +instance Proto.Sendable TransferResponse where + formatMessage (TransferOutput (OutputMessage m)) = + ["om", Proto.serialize (encode_c (decodeBS m))] + formatMessage (TransferOutput (OutputError e)) = + ["oe", Proto.serialize (encode_c e)] + formatMessage (TransferOutput BeginProgressMeter) = + ["opb"] + formatMessage (TransferOutput (UpdateProgressMeterTotalSize (TotalSize sz))) = + ["ops", Proto.serialize sz] + formatMessage (TransferOutput (UpdateProgressMeter n)) = + ["op", Proto.serialize n] + formatMessage (TransferOutput EndProgressMeter) = + ["ope"] + formatMessage (TransferOutput BeginPrompt) = + ["oprb"] + formatMessage (TransferOutput EndPrompt) = + ["opre"] + formatMessage (TransferOutput (JSONObject b)) = + ["oj", Proto.serialize (encode_c (decodeBL b))] + formatMessage (TransferResult True) = + ["t"] + formatMessage (TransferResult False) = + ["f"] + +instance Proto.Receivable TransferResponse where + parseCommand "om" = Proto.parse1 $ + TransferOutput . OutputMessage . encodeBS . decode_c + parseCommand "oe" = Proto.parse1 $ + TransferOutput . OutputError . decode_c + parseCommand "opb" = Proto.parse0 $ + TransferOutput BeginProgressMeter + parseCommand "ops" = Proto.parse1 $ + TransferOutput . UpdateProgressMeterTotalSize . TotalSize + parseCommand "op" = Proto.parse1 $ + TransferOutput . UpdateProgressMeter + parseCommand "ope" = Proto.parse0 $ + TransferOutput EndProgressMeter + parseCommand "oprb" = Proto.parse0 $ + TransferOutput BeginPrompt + parseCommand "opre" = Proto.parse0 $ + TransferOutput EndPrompt + parseCommand "oj" = Proto.parse1 $ + TransferOutput . JSONObject . encodeBL . decode_c + parseCommand "t" = Proto.parse0 $ + TransferResult True + parseCommand "f" = Proto.parse0 $ + TransferResult False + parseCommand _ = Proto.parseFail + +instance Proto.Sendable TransferSerializedOutputResponse where + formatMessage (TransferSerializedOutputResponse ReadyPrompt) = ["opr"] + +instance Proto.Receivable TransferSerializedOutputResponse where + parseCommand "opr" = Proto.parse0 (TransferSerializedOutputResponse ReadyPrompt) + parseCommand _ = Proto.parseFail + +instance Proto.Serializable TransferRemote where + serialize (TransferRemoteUUID u) = 'u':fromUUID u + -- A remote name could contain whitespace or newlines, which needs + -- to be escaped for the protocol. Use C-style encoding. + serialize (TransferRemoteName r) = 'r':encode_c' isSpace r + + deserialize ('u':u) = Just (TransferRemoteUUID (toUUID u)) + deserialize ('r':r) = Just (TransferRemoteName (decode_c r)) + deserialize _ = Nothing + +instance Proto.Serializable TransferAssociatedFile where + -- Comes last, so whitespace is ok. But, in case the filename + -- contains eg a newline, escape it. Use C-style encoding. + serialize (TransferAssociatedFile (AssociatedFile (Just f))) = + encode_c (fromRawFilePath f) + serialize (TransferAssociatedFile (AssociatedFile Nothing)) = "" + + deserialize "" = Just $ TransferAssociatedFile $ + AssociatedFile Nothing + deserialize s = Just $ TransferAssociatedFile $ + AssociatedFile $ Just $ toRawFilePath $ decode_c s diff --git a/Types/TransferrerPool.hs b/Types/TransferrerPool.hs new file mode 100644 --- /dev/null +++ b/Types/TransferrerPool.hs @@ -0,0 +1,59 @@ +{- A pool of "git-annex transfer" processes available for use + - + - Copyright 2013-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.TransferrerPool where + +import Common + +import Control.Concurrent.STM hiding (check) + +type TransferrerPool = TVar [TransferrerPoolItem] + +type CheckTransferrer = IO Bool +type MkCheckTransferrer = IO (IO Bool) + +{- Each item in the pool may have a transferrer running, and has an + - IO action that can be used to check if it's still ok to use the + - transferrer. -} +data TransferrerPoolItem = TransferrerPoolItem (Maybe Transferrer) CheckTransferrer + +data Transferrer = Transferrer + { transferrerRead :: Handle + , transferrerWrite :: Handle + , transferrerHandle :: ProcessHandle + , transferrerShutdown :: IO () + -- ^ Closes the FDs and waits for the process to exit. + -- Should be used when the transferrer is in between transfers, + -- as otherwise it may not shutdown promptly. + } + +newTransferrerPool :: IO TransferrerPool +newTransferrerPool = newTVarIO [] + +popTransferrerPool :: TransferrerPool -> STM (Maybe TransferrerPoolItem, Int) +popTransferrerPool p = do + l <- readTVar p + case l of + [] -> return (Nothing, 0) + (i:is) -> do + writeTVar p is + return $ (Just i, length is) + +pushTransferrerPool :: TransferrerPool -> TransferrerPoolItem -> STM () +pushTransferrerPool p i = do + l <- readTVar p + let l' = i:l + writeTVar p l' + +{- Note that making a CheckTransferrer may allocate resources, + - such as a NotificationHandle, so it's important that the returned + - TransferrerPoolItem is pushed into the pool, and not left to be + - garbage collected. -} +mkTransferrerPoolItem :: MkCheckTransferrer -> Transferrer -> IO TransferrerPoolItem +mkTransferrerPoolItem mkcheck t = do + check <- mkcheck + return $ TransferrerPoolItem (Just t) check diff --git a/Types/VectorClock.hs b/Types/VectorClock.hs new file mode 100644 --- /dev/null +++ b/Types/VectorClock.hs @@ -0,0 +1,29 @@ +{- git-annex vector clocks + - + - We don't have a way yet to keep true distributed vector clocks. + - The next best thing is a timestamp. + - + - Copyright 2017-2020 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module Types.VectorClock where + +import Data.Time.Clock.POSIX +import Control.Applicative +import Prelude + +import Utility.QuickCheck + +-- | Some very old logs did not have any time stamp at all; +-- Unknown is used for those. +data VectorClock = Unknown | VectorClock POSIXTime + deriving (Eq, Ord, Show) + +-- Unknown is oldest. +prop_VectorClock_sane :: Bool +prop_VectorClock_sane = Unknown < VectorClock 1 + +instance Arbitrary VectorClock where + arbitrary = VectorClock <$> arbitrary diff --git a/Upgrade.hs b/Upgrade.hs --- a/Upgrade.hs +++ b/Upgrade.hs @@ -103,10 +103,9 @@ -- upgrading a git repo other than the current repo. upgraderemote = do rp <- fromRawFilePath <$> fromRepo Git.repoPath - gitAnnexChildProcess - [ "upgrade" - , "--quiet" - , "--autoonly" + gitAnnexChildProcess "upgrade" + [ Param "--quiet" + , Param "--autoonly" ] (\p -> p { cwd = Just rp }) (\_ _ _ pid -> waitForProcess pid >>= return . \case diff --git a/Utility/Batch.hs b/Utility/Batch.hs --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -10,6 +10,7 @@ module Utility.Batch ( batch, BatchCommandMaker, + nonBatchCommandMaker, getBatchCommandMaker, toBatchCommand, batchCommand, @@ -49,6 +50,9 @@ {- Makes a command be run by whichever of nice, ionice, and nocache - are available in the path. -} type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam]) + +nonBatchCommandMaker :: BatchCommandMaker +nonBatchCommandMaker = id getBatchCommandMaker :: IO BatchCommandMaker getBatchCommandMaker = do diff --git a/Utility/Format.hs b/Utility/Format.hs --- a/Utility/Format.hs +++ b/Utility/Format.hs @@ -12,6 +12,7 @@ formatContainsVar, decode_c, encode_c, + encode_c', prop_encode_c_decode_c_roundtrip ) where @@ -52,7 +53,7 @@ where expand (Const s) = s expand (Var name j esc) - | esc = justify j $ encode_c_strict $ getvar name + | esc = justify j $ encode_c' isSpace $ getvar name | otherwise = justify j $ getvar name getvar name = fromMaybe "" $ M.lookup name vars justify UnJustified s = s @@ -162,10 +163,7 @@ encode_c :: String -> FormatString encode_c = encode_c' (const False) -{- Encodes more strictly, including whitespace. -} -encode_c_strict :: String -> FormatString -encode_c_strict = encode_c' isSpace - +{- Encodes special characters, as well as any matching the predicate. -} encode_c' :: (Char -> Bool) -> String -> FormatString encode_c' p = concatMap echar where @@ -183,8 +181,8 @@ | ord c < 0x20 = e_asc c -- low ascii | ord c >= 256 = e_utf c -- unicode | ord c > 0x7E = e_asc c -- high ascii - | p c = e_asc c -- unprintable ascii - | otherwise = [c] -- printable ascii + | p c = e_asc c + | otherwise = [c] -- unicode character is decomposed to individual Word8s, -- and each is shown in octal e_utf c = showoctal =<< (Codec.Binary.UTF8.String.encode [c] :: [Word8]) diff --git a/Utility/Glob.hs b/Utility/Glob.hs --- a/Utility/Glob.hs +++ b/Utility/Glob.hs @@ -1,15 +1,17 @@ -{-# LANGUAGE PackageImports #-} - {- file globbing - - - Copyright 2014 Joey Hess + - Copyright 2014-2020 Joey Hess - - License: BSD-2-clause -} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} + module Utility.Glob ( Glob, GlobCase(..), + GlobFilePath(..), compileGlob, matchGlob ) where @@ -24,26 +26,42 @@ data GlobCase = CaseSensative | CaseInsensative +-- Is the glob being used to match filenames? +-- +-- When matching filenames, +-- a single path separator (eg /) in the glob will match any +-- number of path separators in the filename. +-- And on Windows, both / and \ are used as path separators, so compile +-- the glob to a regexp that matches either path separator. +newtype GlobFilePath = GlobFilePath Bool + {- Compiles a glob to a regex, that can be repeatedly used. -} -compileGlob :: String -> GlobCase -> Glob -compileGlob glob globcase = Glob $ +compileGlob :: String -> GlobCase -> GlobFilePath -> Glob +compileGlob glob globcase globfilepath = Glob $ case compile (defaultCompOpt {caseSensitive = casesentitive}) defaultExecOpt regex of Right r -> r Left _ -> giveup $ "failed to compile regex: " ++ regex where - regex = '^' : wildToRegex glob ++ "$" + regex = '^' : wildToRegex globfilepath glob ++ "$" casesentitive = case globcase of CaseSensative -> True CaseInsensative -> False -wildToRegex :: String -> String -wildToRegex = concat . go +wildToRegex :: GlobFilePath -> String -> String +wildToRegex (GlobFilePath globfile) = concat . go where go [] = [] go ('*':xs) = ".*" : go xs go ('?':xs) = "." : go xs go ('[':'!':xs) = "[^" : inpat xs go ('[':xs) = "[" : inpat xs +#ifdef mingw32_HOST_OS + go ('/':xs) | globfile = "[/\\]+" : go xs + go ('\\':xs) | globfile = "[/\\]+" : go xs +#else + go ('/':xs) | globfile = "[/]+" : go xs + go ('\\':xs) | globfile = "[\\]+" : go xs +#endif go (x:xs) | isDigit x || isAlpha x = [x] : go xs | otherwise = esc x : go xs diff --git a/Utility/HumanTime.hs b/Utility/HumanTime.hs --- a/Utility/HumanTime.hs +++ b/Utility/HumanTime.hs @@ -45,7 +45,9 @@ {- Parses a human-input time duration, of the form "5h", "1m", "5h1m", etc -} parseDuration :: String -> Either String Duration -parseDuration d = maybe parsefail (Right . Duration) $ go 0 d +parseDuration d + | null d = parsefail + | otherwise = maybe parsefail (Right . Duration) $ go 0 d where go n [] = return n go n s = do diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -9,6 +9,7 @@ module Utility.Metered ( MeterUpdate, + MeterState(..), nullMeterUpdate, combineMeterUpdate, TotalSize(..), @@ -77,7 +78,7 @@ {- Total number of bytes processed so far. -} newtype BytesProcessed = BytesProcessed Integer - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Read) class AsBytesProcessed a where toBytesProcessed :: a -> BytesProcessed @@ -169,8 +170,9 @@ c <- S.hGet h (nextchunksize (fromBytesProcessed sofar)) if S.null c then do - hClose h - return $ L.empty + when (wantsize /= Just 0) $ + hClose h + return L.empty else do let !sofar' = addBytesProcessed sofar (S.length c) meterupdate sofar' @@ -240,6 +242,7 @@ type ProgressParser = String -> (Maybe BytesProcessed, Maybe TotalSize, String) newtype TotalSize = TotalSize Integer + deriving (Show, Eq) {- Runs a command and runs a ProgressParser on its output, in order - to update a meter. @@ -279,8 +282,8 @@ let s = decodeBS b let (mbytes, mtotalsize, buf') = progressparser (buf++s) sendtotalsize' <- case (sendtotalsize, mtotalsize) of - (Just meter, Just (TotalSize n)) -> do - setMeterTotalSize meter n + (Just meter, Just t) -> do + setMeterTotalSize meter t return Nothing _ -> return sendtotalsize case mbytes of @@ -366,7 +369,7 @@ return $ mu lastupdate where mu lastupdate n@(BytesProcessed i) = readMVar totalsizev >>= \case - Just t | i >= t -> meterupdate n + Just (TotalSize t) | i >= t -> meterupdate n _ -> do now <- getPOSIXTime prev <- takeMVar lastupdate @@ -376,33 +379,39 @@ meterupdate n else putMVar lastupdate prev -data Meter = Meter (MVar (Maybe Integer)) (MVar MeterState) (MVar String) DisplayMeter +data Meter = Meter (MVar (Maybe TotalSize)) (MVar MeterState) (MVar String) DisplayMeter -type MeterState = (BytesProcessed, POSIXTime) +data MeterState = MeterState + { meterBytesProcessed :: BytesProcessed + , meterTimeStamp :: POSIXTime + } deriving (Show) -type DisplayMeter = MVar String -> Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> IO () +type DisplayMeter = MVar String -> Maybe TotalSize -> MeterState -> MeterState -> IO () -type RenderMeter = Maybe Integer -> (BytesProcessed, POSIXTime) -> (BytesProcessed, POSIXTime) -> String +type RenderMeter = Maybe TotalSize -> MeterState -> MeterState -> String -- | Make a meter. Pass the total size, if it's known. -mkMeter :: Maybe Integer -> DisplayMeter -> IO Meter -mkMeter totalsize displaymeter = Meter - <$> newMVar totalsize - <*> ((\t -> newMVar (zeroBytesProcessed, t)) =<< getPOSIXTime) - <*> newMVar "" - <*> pure displaymeter +mkMeter :: Maybe TotalSize -> DisplayMeter -> IO Meter +mkMeter totalsize displaymeter = do + ts <- getPOSIXTime + Meter + <$> newMVar totalsize + <*> newMVar (MeterState zeroBytesProcessed ts) + <*> newMVar "" + <*> pure displaymeter -setMeterTotalSize :: Meter -> Integer -> IO () +setMeterTotalSize :: Meter -> TotalSize -> IO () setMeterTotalSize (Meter totalsizev _ _ _) = void . swapMVar totalsizev . Just -- | Updates the meter, displaying it if necessary. updateMeter :: Meter -> MeterUpdate updateMeter (Meter totalsizev sv bv displaymeter) new = do now <- getPOSIXTime - (old, before) <- swapMVar sv (new, now) - when (old /= new) $ do + let curms = MeterState new now + oldms <- swapMVar sv curms + when (meterBytesProcessed oldms /= new) $ do totalsize <- readMVar totalsizev - displaymeter bv totalsize (old, before) (new, now) + displaymeter bv totalsize oldms curms -- | Display meter to a Handle. displayMeterHandle :: Handle -> RenderMeter -> DisplayMeter @@ -427,7 +436,7 @@ -- or when total size is not known: -- 1.3 MiB 300 KiB/s bandwidthMeter :: RenderMeter -bandwidthMeter mtotalsize (BytesProcessed old, before) (BytesProcessed new, now) = +bandwidthMeter mtotalsize (MeterState (BytesProcessed old) before) (MeterState (BytesProcessed new) now) = unwords $ catMaybes [ Just percentamount -- Pad enough for max width: "100% xxxx.xx KiB xxxx KiB/s" @@ -438,7 +447,7 @@ where amount = roughSize' memoryUnits True 2 new percentamount = case mtotalsize of - Just totalsize -> + Just (TotalSize totalsize) -> let p = showPercentage 0 $ percentage totalsize (min new totalsize) in p ++ replicate (6 - length p) ' ' ++ amount @@ -450,7 +459,7 @@ transferred = max 0 (new - old) duration = max 0 (now - before) estimatedcompletion = case mtotalsize of - Just totalsize + Just (TotalSize totalsize) | bytespersecond > 0 -> Just $ fromDuration $ Duration $ (totalsize - new) `div` bytespersecond diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -34,7 +34,7 @@ ) where import qualified Utility.Process.Shim -import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess) +import Utility.Process.Shim as X (CreateProcess(..), ProcessHandle, StdStream(..), CmdSpec(..), proc, getPid, getProcessExitCode, shell, terminateProcess, interruptProcessGroupOf) import Utility.Misc import Utility.Exception import Utility.Monad diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs --- a/Utility/SimpleProtocol.hs +++ b/Utility/SimpleProtocol.hs @@ -1,6 +1,6 @@ {- Simple line-based protocols. - - - Copyright 2013-2016 Joey Hess + - Copyright 2013-2020 Joey Hess - - License: BSD-2-clause -} @@ -19,12 +19,15 @@ parse1, parse2, parse3, + parse4, + parse5, dupIoHandles, getProtocolLine, ) where import Data.Char import GHC.IO.Handle +import Text.Read import Common @@ -52,11 +55,15 @@ serialize = id deserialize = Just +instance Serializable Integer where + serialize = show + deserialize = readMaybe + instance Serializable ExitCode where serialize ExitSuccess = "0" serialize (ExitFailure n) = show n deserialize "0" = Just ExitSuccess - deserialize s = ExitFailure <$> readish s + deserialize s = ExitFailure <$> readMaybe s {- Parsing the parameters of messages. Using the right parseN ensures - that the string is split into exactly the requested number of words, @@ -85,6 +92,21 @@ where (p1, rest) = splitWord s (p2, p3) = splitWord rest + +parse4 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4) => (p1 -> p2 -> p3 -> p4 -> a) -> Parser a +parse4 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 + where + (p1, rest) = splitWord s + (p2, rest') = splitWord rest + (p3, p4) = splitWord rest' + +parse5 :: (Serializable p1, Serializable p2, Serializable p3, Serializable p4, Serializable p5) => (p1 -> p2 -> p3 -> p4 -> p5 -> a) -> Parser a +parse5 mk s = mk <$> deserialize p1 <*> deserialize p2 <*> deserialize p3 <*> deserialize p4 <*> deserialize p5 + where + (p1, rest) = splitWord s + (p2, rest') = splitWord rest + (p3, rest'') = splitWord rest' + (p4, p5) = splitWord rest'' splitWord :: String -> (String, String) splitWord = separate isSpace diff --git a/doc/git-annex-export.mdwn b/doc/git-annex-export.mdwn --- a/doc/git-annex-export.mdwn +++ b/doc/git-annex-export.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex export - export content to a remote +git-annex export - export a tree of files to a special remote # SYNOPSIS diff --git a/doc/git-annex-import.mdwn b/doc/git-annex-import.mdwn --- a/doc/git-annex-import.mdwn +++ b/doc/git-annex-import.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex import - add a tree of files to the repository +git-annex import - import files from a special remote # SYNOPSIS diff --git a/doc/git-annex-sync.mdwn b/doc/git-annex-sync.mdwn --- a/doc/git-annex-sync.mdwn +++ b/doc/git-annex-sync.mdwn @@ -113,7 +113,7 @@ import changes from the remote, merge them into the branch, and export any changes that have been committed to the branch back to the remote. With --no-content, imports will only be made from special remotes that - support importing without transferting files, and no exports will be done. + support importing without transferring files, and no exports will be done. See [[git-annex-import]](1) and [[git-annex-export]](1) for details about how importing and exporting work. diff --git a/doc/git-annex-transferkeys.mdwn b/doc/git-annex-transferkeys.mdwn --- a/doc/git-annex-transferkeys.mdwn +++ b/doc/git-annex-transferkeys.mdwn @@ -1,6 +1,6 @@ # NAME -git-annex transferkeys - transfers keys +git-annex transferkeys - transfers keys (deprecated) # SYNOPSIS @@ -8,19 +8,17 @@ # DESCRIPTION -This plumbing-level command is used by the assistant to transfer data. +This plumbing-level command is used to transfer data, by the assistant +in git-annex version 8.20201127 and older. It is still included only +to prevent breakage during upgrades. + It is a long-running process, which is fed instructions about the keys to transfer using an internal stdio protocol, which is intentionally not documented (as it may change at any time). -It's normal to have a transferkeys process running when the assistant is -running. - # SEE ALSO [[git-annex]](1) - -[[git-annex-assistant]](1) # AUTHOR diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -631,9 +631,15 @@ See [[git-annex-transferkey]](1) for details. +* `transferrer` + + Used internally by git-annex to transfer content. + + See [[git-annex-transferrer]](1) for details. + * `transferkeys` - Used internally by the assistant. + Used internally by old versions of the assistant. See [[git-annex-transferkey]](1) for details. @@ -831,7 +837,12 @@ # CONFIGURATION Like other git commands, git-annex is configured via `.git/config`. +These settings, as well as relevant git config settings, are +the ones git-annex uses. +(Some of these settings can also be set, across all clones of the +repository, using [[git-annex-config]]. See its man page for a list.) + * `annex.uuid` A unique UUID for this repository (automatically set). @@ -908,7 +919,7 @@ Used to configure which files are large enough to be added to the annex. It is an expression that matches the large files, eg - "include=*.mp3 or largerthan(500kb)" + "`include=*.mp3 or largerthan(500kb)`" See [[git-annex-matching-expression]](1) for details on the syntax. Overrides any annex.largefiles attributes in `.gitattributes` files. @@ -1392,6 +1403,31 @@ When making multiple retries of the same transfer, the delay doubles after each retry. (default 1) +* `remote..annex-stalldetecton`, `annex.stalldetection` + + This lets stalled or too-slow transfers be detected, and dealt with, so + rather than getting stuck, git-annex will cancel the stalled operation. + When this happens, the transfer will be considered to have failed, so + settings like annex.retry will control what it does next. + + The value specifies how much data git-annex should expect to see + flowing, minimum, when it's not stalled, over a given period of time. + The format is "$amount/$timeperiod". + + For example, to detect outright stalls where no data has been transferred + after 30 seconds: `git config annex.stalldetection "0/30s"` + + Or, if you have a remote on a USB drive that is normally capable of + several megabytes per second, but has bad sectors where it gets + stuck for a long time, you could use: + `git config remote.usbdrive.annex-stalldetection "1MB/1m"` + + This is not enabled by default, because it can make git-annex use + more resources. To be able to cancel stalls, git-annex has to run + transfers in separate processes (one per concurrent job). So it + may need to open more connections to a remote than usual, or + the communication with those processes may make it a bit slower. + * `remote..annex-checkuuid` This only affects remotes that have their url pointing to a directory on @@ -1503,6 +1539,12 @@ Used by bup special remotes, this configures the location of the bup repository to use. Normally this is automatically + set up by `git annex initremote`, but you can change it if needed. + +* `remote..annex-borgrepo` + + Used by borg special remotes, this configures + the location of the borg repository to use. Normally this is automatically set up by `git annex initremote`, but you can change it if needed. * `remote..annex-ddarrepo` diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 8.20201127 +Version: 8.20201129 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -479,7 +479,6 @@ Assistant.Threads.Watcher Assistant.TransferQueue Assistant.TransferSlots - Assistant.TransferrerPool Assistant.Types.Alert Assistant.Types.BranchChange Assistant.Types.Changes @@ -495,7 +494,6 @@ Assistant.Types.ThreadedMonad Assistant.Types.TransferQueue Assistant.Types.TransferSlots - Assistant.Types.TransferrerPool Assistant.Types.UrlRenderer Assistant.Unused Assistant.Upgrade @@ -666,11 +664,13 @@ Annex.TaggedPush Annex.Tmp Annex.Transfer + Annex.TransferrerPool Annex.UntrustedFilePath Annex.UpdateInstead Annex.UUID Annex.Url Annex.VectorClock + Annex.VectorClock.Utility Annex.VariantFile Annex.Version Annex.View @@ -795,6 +795,7 @@ Command.Test Command.TestRemote Command.TransferInfo + Command.Transferrer Command.TransferKey Command.TransferKeys Command.Trust @@ -931,6 +932,7 @@ Messages.Internal Messages.JSON Messages.Progress + Messages.Serialized P2P.Address P2P.Annex P2P.Auth @@ -939,6 +941,7 @@ Remote Remote.Adb Remote.BitTorrent + Remote.Borg Remote.Bup Remote.Ddar Remote.Directory @@ -961,6 +964,7 @@ Remote.Helper.Messages Remote.Helper.P2P Remote.Helper.ReadOnly + Remote.Helper.ThirdPartyPopulated Remote.Helper.Special Remote.Helper.Ssh Remote.HttpAlso @@ -1023,12 +1027,16 @@ Types.RepoVersion Types.ScheduledActivity Types.StandardGroups + Types.StallDetection Types.StoreRetrieve Types.Test Types.Transfer + Types.Transferrer + Types.TransferrerPool Types.TrustLevel Types.UUID Types.UrlContents + Types.VectorClock Types.View Types.WorkerPool Upgrade diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -25,7 +25,6 @@ - sandi-0.5 - torrent-10000.1.1 - bencode-0.6.1.1 -- network-3.1.0.1 explicit-setup-deps: git-annex: true -resolver: lts-16.16 +resolver: lts-16.27