diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -31,6 +31,7 @@ overrideGitConfig, changeGitRepo, adjustGitRepo, + addGitConfigOverride, getRemoteGitConfig, withCurrentState, changeDirectory, @@ -151,6 +152,7 @@ , cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment)) , cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) , urloptions :: Maybe UrlOptions + , insmudgecleanfilter :: Bool } newState :: GitConfig -> Git.Repo -> IO AnnexState @@ -209,6 +211,7 @@ , cachedcurrentbranch = Nothing , cachedgitenv = Nothing , urloptions = Nothing + , insmudgecleanfilter = False } {- Makes an Annex state object for the specified git repo. @@ -335,6 +338,21 @@ adjustGitRepo a = do changeState $ \s -> s { repoadjustment = \r -> repoadjustment s r >>= a } 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, + - 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) } + where + -- Remove any prior occurrance of the setting to avoid + -- building up many of them when the adjustment is run repeatedly, + -- and add the setting to the end. + go [] = [Param "-c", Param v] + go (Param "-c": Param v':rest) | v' == v = go rest + go (c:rest) = c : go rest {- Changing the git Repo data also involves re-extracting its GitConfig. -} changeGitRepo :: Git.Repo -> Annex () diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -230,6 +230,7 @@ else commitIndex jl branchref merge_desc commitrefs ) addMergedRefs tomerge + invalidateCache stagejournalwhen dirty jl a | dirty = stageJournal jl a | otherwise = withIndex a @@ -242,11 +243,15 @@ - - Returns an empty string if the file doesn't exist yet. -} get :: RawFilePath -> Annex L.ByteString -get file = do - st <- update - if journalIgnorable st - then getRef fullname file - else getLocal file +get file = getCache file >>= \case + Just content -> return content + Nothing -> do + st <- update + content <- if journalIgnorable st + then getRef fullname file + else getLocal file + setCache file content + return content {- Like get, but does not merge the branch, so the info returned may not - reflect changes in remotes. @@ -301,6 +306,11 @@ set jl f c = do journalChanged setJournalFile jl f c + -- Could cache the new content, but it would involve + -- evaluating a Journalable Builder twice, which is not very + -- efficient. Instead, assume that it's not common to need to read + -- a log file immediately after writing it. + invalidateCache {- Commit message used when making a commit of whatever data has changed - to the git-annex brach. -} diff --git a/Annex/BranchState.hs b/Annex/BranchState.hs --- a/Annex/BranchState.hs +++ b/Annex/BranchState.hs @@ -1,6 +1,6 @@ {- git-annex branch state management - - - Runtime state about the git-annex branch. + - Runtime state about the git-annex branch, and a small cache. - - Copyright 2011-2020 Joey Hess - @@ -12,7 +12,10 @@ import Annex.Common import Types.BranchState import qualified Annex +import Logs +import qualified Data.ByteString.Lazy as L + getState :: Annex BranchState getState = Annex.getState Annex.branchstate @@ -45,7 +48,7 @@ let stf = \st' -> st' { branchUpdated = True , journalIgnorable = journalstaged - && not (journalNeverIgnorable st') + && not (needInteractiveAccess st') } changeState stf return (stf st) @@ -76,7 +79,29 @@ - and needs to always notice changes made to the journal by other - processes, this disables optimisations that avoid normally reading the - journal. + - + - It also avoids using the cache, so changes committed by other processes + - will be seen. -} -enableInteractiveJournalAccess :: Annex () -enableInteractiveJournalAccess = changeState $ - \s -> s { journalNeverIgnorable = True } +enableInteractiveBranchAccess :: Annex () +enableInteractiveBranchAccess = changeState $ + \s -> s { needInteractiveAccess = True } + +setCache :: RawFilePath -> L.ByteString -> Annex () +setCache file content = changeState $ \s -> s + { cachedFileContents = add (cachedFileContents s) } + where + add l + | length l < logFilesToCache = (file, content) : l + | otherwise = (file, content) : Prelude.init l + +getCache :: RawFilePath -> Annex (Maybe L.ByteString) +getCache file = (\st -> go (cachedFileContents st) st) <$> getState + where + go [] _ = Nothing + go ((f,c):rest) state + | f == file && not (needInteractiveAccess state) = Just c + | otherwise = go rest state + +invalidateCache :: Annex () +invalidateCache = changeState $ \s -> s { cachedFileContents = [] } diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -82,6 +82,8 @@ return $ st' -- each thread has its own repoqueue { Annex.repoqueue = Nothing + -- no errors from this thread yet + , Annex.errcounter = 0 } {- Merges the passed AnnexState into the current Annex state. diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -20,6 +20,7 @@ getViaTmp, getViaTmpFromDisk, checkDiskSpaceToGet, + checkSecureHashes, prepTmp, withTmp, checkDiskSpace, @@ -335,7 +336,7 @@ checkallowed a = case rsp of RetrievalAllKeysSecure -> a RetrievalVerifiableKeysSecure - | isVerifiable (fromKey keyVariety key) -> a + | Backend.isVerifiable key -> a | otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) ( a , warnUnverifiableInsecure key >> return False @@ -359,7 +360,7 @@ verifyKeyContent rsp v verification k f = case (rsp, verification) of (_, Verified) -> return True (RetrievalVerifiableKeysSecure, _) - | isVerifiable (fromKey keyVariety k) -> verify + | Backend.isVerifiable k -> verify | otherwise -> ifM (annexAllowUnverifiedDownloads <$> Annex.getGitConfig) ( verify , warnUnverifiableInsecure k >> return False @@ -473,7 +474,7 @@ - case. May also throw exceptions in some cases. -} moveAnnex :: Key -> FilePath -> Annex Bool -moveAnnex key src = ifM (checkSecureHashes key) +moveAnnex key src = ifM (checkSecureHashes' key) ( do withObjectLoc key storeobject return True @@ -496,22 +497,27 @@ dest' = fromRawFilePath dest alreadyhave = liftIO $ removeFile src -checkSecureHashes :: Key -> Annex Bool +checkSecureHashes :: Key -> Annex (Maybe String) checkSecureHashes key - | cryptographicallySecure (fromKey keyVariety key) = return True + | Backend.isCryptographicallySecure key = return Nothing | otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig) - ( do - warning $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key to annex objects" - return False - , return True + ( return $ Just $ "annex.securehashesonly blocked adding " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key" + , return Nothing ) +checkSecureHashes' :: Key -> Annex Bool +checkSecureHashes' key = checkSecureHashes key >>= \case + Nothing -> return True + Just msg -> do + warning $ msg ++ "to annex objects" + return False + data LinkAnnexResult = LinkAnnexOk | LinkAnnexFailed | LinkAnnexNoop {- Populates the annex object file by hard linking or copying a source - file to it. -} linkToAnnex :: Key -> FilePath -> Maybe InodeCache -> Annex LinkAnnexResult -linkToAnnex key src srcic = ifM (checkSecureHashes key) +linkToAnnex key src srcic = ifM (checkSecureHashes' key) ( do dest <- fromRawFilePath <$> calcRepo (gitAnnexLocation key) modifyContent dest $ linkAnnex To key src srcic dest Nothing diff --git a/Annex/GitOverlay.hs b/Annex/GitOverlay.hs --- a/Annex/GitOverlay.hs +++ b/Annex/GitOverlay.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.GitOverlay ( module Annex.GitOverlay, AltIndexFile(..), @@ -20,11 +22,13 @@ import Git.Env import qualified Annex import qualified Annex.Queue +#ifndef mingw32_HOST_OS import qualified Utility.LockFile.PidLock as PidF import qualified Utility.LockPool.PidLock as PidP import Utility.LockPool (dropLock) import Utility.Env -import Annex.LockPool.PosixOrPid (pidLockFile) +import Config +#endif {- Runs an action using a different git index file. -} withIndexFile :: AltIndexFile -> (FilePath -> Annex a) -> Annex a @@ -145,6 +149,7 @@ - when git-annex is used without pid locking. -} runsGitAnnexChildProcess :: Annex a -> Annex a +#ifndef mingw32_HOST_OS runsGitAnnexChildProcess a = pidLockFile >>= \case Nothing -> a Just pidlock -> bracket (setup pidlock) cleanup (go pidlock) @@ -168,8 +173,12 @@ Nothing -> Nothing in g { Git.gitEnv = e' } withAltRepo addenv rmenv (const a) +#else +runsGitAnnexChildProcess a = a +#endif runsGitAnnexChildProcess' :: Git.Repo -> (Git.Repo -> IO a) -> Annex a +#ifndef mingw32_HOST_OS runsGitAnnexChildProcess' r a = pidLockFile >>= \case Nothing -> liftIO $ a r Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock) @@ -184,3 +193,6 @@ v <- PidF.pidLockEnv pidlock r' <- addGitEnv r v "1" a r' +#else +runsGitAnnexChildProcess' r a = liftIO $ a r +#endif diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -1,6 +1,6 @@ {- git-annex import from remotes - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -12,7 +12,7 @@ ImportCommitConfig(..), buildImportCommit, buildImportTrees, - downloadImport, + importKeys, filterImportableContents, makeImportMatcher, listImportableContents, @@ -34,6 +34,7 @@ import Annex.Content import Annex.Export import Annex.RemoteTrackingBranch +import Annex.HashObject import Command import Backend import Types.Key @@ -93,7 +94,7 @@ :: Remote -> ImportTreeConfig -> ImportCommitConfig - -> ImportableContents Key + -> ImportableContents (Either Sha Key) -> Annex (Maybe Ref) buildImportCommit remote importtreeconfig importcommitconfig importable = case importCommitTracking importcommitconfig of @@ -246,7 +247,7 @@ buildImportTrees :: Ref -> Maybe TopFilePath - -> ImportableContents Key + -> ImportableContents (Either Sha Key) -> Annex (History Sha) buildImportTrees basetree msubdir importable = History <$> (buildtree (importableContents importable) =<< Annex.gitRepo) @@ -265,49 +266,71 @@ Just subdir -> liftIO $ graftTree' importtree subdir basetree repo hdl - mktreeitem (loc, k) = do - let lf = fromImportLocation loc - let treepath = asTopFilePath lf - let topf = asTopFilePath $ + mktreeitem (loc, v) = case v of + Right k -> do + relf <- fromRepo $ fromTopFilePath topf + symlink <- calcRepo $ gitAnnexLink (fromRawFilePath relf) k + linksha <- hashSymlink symlink + return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha + Left sha -> + return $ TreeItem treepath (fromTreeItemType TreeFile) sha + where + lf = fromImportLocation loc + treepath = asTopFilePath lf + topf = asTopFilePath $ maybe lf (\sd -> getTopFilePath sd P. lf) msubdir - relf <- fromRepo $ fromTopFilePath topf - symlink <- calcRepo $ gitAnnexLink (fromRawFilePath relf) k - linksha <- hashSymlink symlink - return $ TreeItem treepath (fromTreeItemType TreeSymlink) linksha -{- Downloads all new ContentIdentifiers as needed to generate Keys. +{- Downloads all new ContentIdentifiers, or when importcontent is False, + - generates Keys without downloading. + - + - Generates either a Key or a git Sha, depending on annex.largefiles. + - But when importcontent is False, it cannot match on annex.largefiles + - (or generate a git Sha), so always generates Keys. + - - Supports concurrency when enabled. - - - If any download fails, the whole thing fails with Nothing, + - If it fails on any file, the whole thing fails with Nothing, - but it will resume where it left off. + - + - Note that, when a ContentIdentifier has been imported before, + - generates the same thing that was imported before, so annex.largefiles + - is not reapplied. -} -downloadImport :: Remote -> ImportTreeConfig -> ImportableContents (ContentIdentifier, ByteSize) -> Annex (Maybe (ImportableContents Key)) -downloadImport remote importtreeconfig importablecontents = do +importKeys + :: Remote + -> ImportTreeConfig + -> Bool + -> ImportableContents (ContentIdentifier, ByteSize) + -> Annex (Maybe (ImportableContents (Either Sha Key))) +importKeys remote importtreeconfig importcontent importablecontents = do + when (not importcontent && isNothing (Remote.importKey ia)) $ + giveup "This remote does not support importing without downloading content." -- This map is used to remember content identifiers that - -- were just downloaded, before they have necessarily been + -- were just imported, before they have necessarily been -- stored in the database. This way, if the same content -- identifier appears multiple times in the -- importablecontents (eg when it has a history), - -- they will only be downloaded once. + -- they will only be imported once. cidmap <- liftIO $ newTVarIO M.empty -- When concurrency is enabled, this set is needed to - -- avoid two threads both downloading the same content identifier. - downloading <- liftIO $ newTVarIO S.empty + -- avoid two threads both importing the same content identifier. + importing <- liftIO $ newTVarIO S.empty withExclusiveLock gitAnnexContentIdentifierLock $ bracket CIDDb.openDb CIDDb.closeDb $ \db -> do CIDDb.needsUpdateFromLog db >>= maybe noop (CIDDb.updateFromLog db) - go False cidmap downloading importablecontents db + go False cidmap importing importablecontents db where - go oldversion cidmap downloading (ImportableContents l h) db = do + go oldversion cidmap importing (ImportableContents l h) db = do + largematcher <- largeFilesMatcher jobs <- forM l $ \i -> - startdownload cidmap downloading db i oldversion + startimport cidmap importing db i oldversion largematcher l' <- liftIO $ forM jobs $ either pure (atomically . takeTMVar) if any isNothing l' then return Nothing else do - h' <- mapM (\ic -> go True cidmap downloading ic db) h + h' <- mapM (\ic -> go True cidmap importing ic db) h if any isNothing h' then return Nothing else return $ Just $ @@ -315,25 +338,35 @@ (catMaybes l') (catMaybes h') - waitstart downloading cid = liftIO $ atomically $ do - s <- readTVar downloading + waitstart importing cid = liftIO $ atomically $ do + s <- readTVar importing if S.member cid s then retry - else writeTVar downloading $ S.insert cid s + else writeTVar importing $ S.insert cid s - signaldone downloading cid = liftIO $ atomically $ do - s <- readTVar downloading - writeTVar downloading $ S.delete cid s + signaldone importing cid = liftIO $ atomically $ do + s <- readTVar importing + writeTVar importing $ S.delete cid s - startdownload cidmap downloading db i@(loc, (cid, _sz)) oldversion = getcidkey cidmap db cid >>= \case - (k:_) -> return $ Left $ Just (loc, k) + startimport cidmap importing db i@(loc, (cid, _sz)) oldversion largematcher = getcidkey cidmap db cid >>= \case + (k:ks) -> + -- If the same content was imported before + -- yeilding multiple different keys, it's not clear + -- which is best to use this time, so pick the + -- first in the list. But, if any of them is a + -- git sha, use it, because the content must + -- be included in the git repo then. + let v = case mapMaybe keyGitSha (k:ks) of + (sha:_) -> Left sha + [] -> Right k + in return $ Left $ Just (loc, v) [] -> do job <- liftIO $ newEmptyTMVarIO let ai = ActionItemOther (Just (fromRawFilePath (fromImportLocation loc))) - let downloadaction = starting ("import " ++ Remote.name remote) ai $ do + let importaction = starting ("import " ++ Remote.name remote) ai $ do when oldversion $ showNote "old version" - tryNonAsync (download cidmap db i) >>= \case + tryNonAsync (importordownload cidmap db i largematcher) >>= \case Left e -> next $ do warning (show e) liftIO $ atomically $ @@ -344,22 +377,55 @@ putTMVar job r return True commandAction $ bracket_ - (waitstart downloading cid) - (signaldone downloading cid) - downloadaction + (waitstart importing cid) + (signaldone importing cid) + importaction return (Right job) - download cidmap db (loc, (cid, sz)) = do + importordownload + | not importcontent = doimport + | otherwise = dodownload + + doimport cidmap db (loc, (cid, sz)) _largematcher = + case Remote.importKey ia of + Nothing -> error "internal" -- checked earlier + Just a -> do + let importer p = do + unsizedk <- a loc cid 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 + return (Right k) + Just msg -> giveup (msg ++ " to import") + let runimport p = tryNonAsync (importer p) >>= \case + Right k -> return $ Just (loc, k) + Left e -> do + warning (show e) + return Nothing + metered Nothing sz $ + const runimport + + dodownload cidmap db (loc, (cid, sz)) largematcher = do let downloader tmpfile p = do - k <- Remote.retrieveExportWithContentIdentifier ia loc cid tmpfile (mkkey loc tmpfile) p - ok <- moveAnnex k tmpfile - return (k, ok) + k <- Remote.retrieveExportWithContentIdentifier ia loc cid tmpfile (mkkey loc tmpfile largematcher) p + case keyGitSha k of + Nothing -> do + ok <- moveAnnex k tmpfile + when ok $ do + recordcidkey cidmap db cid k + logStatus k InfoPresent + logChange k (Remote.uuid remote) InfoPresent + return (Right k, ok) + Just sha -> do + recordcidkey cidmap db cid k + return (Left sha, True) let rundownload tmpfile p = tryNonAsync (downloader tmpfile p) >>= \case - Right (k, True) -> do - recordcidkey cidmap db cid k - logStatus k InfoPresent - logChange k (Remote.uuid remote) InfoPresent - return $ Just (loc, k) + Right (v, True) -> return $ Just (loc, v) Right (_, False) -> return Nothing Left e -> do warning (show e) @@ -369,18 +435,28 @@ metered Nothing tmpkey $ const (rundownload tmpfile) where - ia = Remote.importActions remote tmpkey = importKey cid sz + + ia = Remote.importActions remote - mkkey loc tmpfile = do + mkkey loc tmpfile largematcher = do f <- fromRepo $ fromTopFilePath $ locworktreefilename loc - backend <- chooseBackend (fromRawFilePath f) - let ks = KeySource - { keyFilename = f - , contentLocation = toRawFilePath tmpfile - , inodeCache = Nothing + matcher <- largematcher (fromRawFilePath f) + let mi = MatchingFile FileInfo + { matchFile = f + , currFile = toRawFilePath tmpfile } - fst <$> genKey ks nullMeterUpdate backend + islargefile <- checkMatcher' matcher mi mempty + if islargefile + then do + backend <- chooseBackend (fromRawFilePath f) + let ks = KeySource + { keyFilename = f + , contentLocation = toRawFilePath tmpfile + , inodeCache = Nothing + } + fst <$> genKey ks nullMeterUpdate backend + else gitShaKey <$> hashFile tmpfile locworktreefilename loc = asTopFilePath $ case importtreeconfig of ImportTree -> fromImportLocation loc diff --git a/Annex/Link.hs b/Annex/Link.hs --- a/Annex/Link.hs +++ b/Annex/Link.hs @@ -177,12 +177,18 @@ restagePointerFile :: Restage -> RawFilePath -> InodeCache -> Annex () restagePointerFile (Restage False) f _ = toplevelWarning True $ unableToRestage $ Just $ fromRawFilePath f -restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> do - -- update-index is documented as picky about "./file" and it - -- fails on "../../repo/path/file" when cwd is not in the repo - -- being acted on. Avoid these problems with an absolute path. - absf <- liftIO $ absPath $ fromRawFilePath f - Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)] +restagePointerFile (Restage True) f orig = withTSDelta $ \tsd -> + -- Avoid refreshing the index if run by the + -- smudge clean filter, because git uses that when + -- it's already refreshing the index, probably because + -- this very action is running. Running it again would likely + -- deadlock. + unlessM (Annex.getState Annex.insmudgecleanfilter) $ do + -- update-index is documented as picky about "./file" and it + -- fails on "../../repo/path/file" when cwd is not in the repo + -- being acted on. Avoid these problems with an absolute path. + absf <- liftIO $ absPath $ fromRawFilePath f + Annex.Queue.addInternalAction runner [(absf, isunmodified tsd)] where isunmodified tsd = genInodeCache f tsd >>= return . \case Nothing -> False diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -551,7 +551,7 @@ {- Sanitizes a String that will be used as part of a Key's keyName, - dealing with characters that cause problems. - - - This is used when a new Key is initially being generated, eg by getKey. + - This is used when a new Key is initially being generated, eg by genKey. - Unlike keyFile and fileKey, it does not need to be a reversable - escaping. Also, it's ok to change this to add more problematic - characters later. Unlike changing keyFile, which could result in the diff --git a/Annex/LockPool/PosixOrPid.hs b/Annex/LockPool/PosixOrPid.hs --- a/Annex/LockPool/PosixOrPid.hs +++ b/Annex/LockPool/PosixOrPid.hs @@ -18,12 +18,10 @@ LockStatus(..), getLockStatus, checkSaneLock, - pidLockFile, ) where import Common import Types -import Annex.Locations import qualified Annex import qualified Utility.LockPool.Posix as Posix import qualified Utility.LockPool.PidLock as Pid @@ -32,6 +30,7 @@ import Utility.LockFile.Posix (openLockFile) import Utility.LockPool.STM (LockFile) import Utility.LockFile.LockStatus +import Config (pidLockFile) import System.Posix @@ -62,12 +61,6 @@ checkSaneLock :: LockFile -> LockHandle -> Annex Bool checkSaneLock f h = H.checkSaneLock f h `pidLockCheck` flip Pid.checkSaneLock h - -pidLockFile :: Annex (Maybe FilePath) -pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig) - ( Just <$> Annex.fromRepo gitAnnexPidLockFile - , pure Nothing - ) pidLockCheck :: IO a -> (LockFile -> IO a) -> Annex a pidLockCheck posixcheck pidcheck = debugLocks $ diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -124,28 +124,29 @@ -> Annex a -- action to perform when unable to drop -> Annex a verifyEnoughCopiesToDrop nolocmsg key removallock need skip preverified tocheck dropaction nodropaction = - helper [] [] preverified (nub tocheck) + helper [] [] preverified (nub tocheck) [] where - helper bad missing have [] = + helper bad missing have [] lockunsupported = liftIO (mkSafeDropProof need have removallock) >>= \case Right proof -> dropaction proof Left stillhave -> do - notEnoughCopies key need stillhave (skip++missing) bad nolocmsg + notEnoughCopies key need stillhave (skip++missing) bad nolocmsg lockunsupported nodropaction - helper bad missing have (c:cs) + helper bad missing have (c:cs) lockunsupported | isSafeDrop need have removallock = liftIO (mkSafeDropProof need have removallock) >>= \case Right proof -> dropaction proof - Left stillhave -> helper bad missing stillhave (c:cs) + Left stillhave -> helper bad missing stillhave (c:cs) lockunsupported | otherwise = case c of UnVerifiedHere -> lockContentShared key contverified UnVerifiedRemote r -> checkremote r contverified $ - Remote.hasKey r key >>= \case - Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs - Left _ -> helper (r:bad) missing have cs - Right False -> helper bad (Remote.uuid r:missing) have cs + let lockunsupported' = r : lockunsupported + in Remote.hasKey r key >>= \case + Right True -> helper bad missing (mkVerifiedCopy RecentlyVerifiedCopy r : have) cs lockunsupported' + Left _ -> helper (r:bad) missing have cs lockunsupported' + Right False -> helper bad (Remote.uuid r:missing) have cs lockunsupported' where - contverified vc = helper bad missing (vc : have) cs + contverified vc = helper bad missing (vc : have) cs lockunsupported checkremote r cont fallback = case Remote.lockContent r of Just lockcontent -> do @@ -176,8 +177,8 @@ instance Exception DropException -notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> Annex () -notEnoughCopies key need have skip bad nolocmsg = do +notEnoughCopies :: Key -> NumCopies -> [VerifiedCopy] -> [UUID] -> [Remote] -> String -> [Remote] -> Annex () +notEnoughCopies key need have skip bad nolocmsg lockunsupported = do showNote "unsafe" if length have < fromNumCopies need then showLongNote $ @@ -185,8 +186,12 @@ show (length have) ++ " out of " ++ show (fromNumCopies need) ++ " necessary copies" else do - showLongNote "Unable to lock down 1 copy of file that is required to safely drop it." - showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)" + showLongNote $ "Unable to lock down 1 copy of file that is required to safely drop it." + if null lockunsupported + then showLongNote "(This could have happened because of a concurrent drop, or because a remote has too old a version of git-annex-shell installed.)" + else showLongNote $ "These remotes do not support locking: " + ++ Remote.listRemoteNames lockunsupported + Remote.showTriedRemotes bad Remote.showLocations True key (map toUUID have++skip) nolocmsg diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -14,7 +14,6 @@ import Annex.Common import Annex.SpecialRemote.Config -import Remote (remoteTypes) import Types.Remote (RemoteConfig, SetupStage(..), typename, setup) import Types.GitConfig import Types.ProposedAccepted diff --git a/Annex/SpecialRemote/Config.hs b/Annex/SpecialRemote/Config.hs --- a/Annex/SpecialRemote/Config.hs +++ b/Annex/SpecialRemote/Config.hs @@ -11,7 +11,7 @@ module Annex.SpecialRemote.Config where import Common -import Types.Remote (RemoteConfigField, RemoteConfig, configParser) +import Types.Remote (configParser) import Types import Types.UUID import Types.ProposedAccepted diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -33,6 +33,7 @@ import Types.Concurrency import Types.WorkerPool import Annex.WorkerPool +import Backend (isCryptographicallySecure) import Control.Concurrent import qualified Data.Map.Strict as M @@ -177,7 +178,7 @@ -} checkSecureHashes :: Observable v => Transfer -> Annex v -> Annex v checkSecureHashes t a - | cryptographicallySecure variety = a + | isCryptographicallySecure (transferKey t) = a | otherwise = ifM (annexSecureHashesOnly <$> Annex.getGitConfig) ( do warning $ "annex.securehashesonly blocked transfer of " ++ decodeBS (formatKeyVariety variety) ++ " key" diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -6,6 +6,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE CPP #-} + module Annex.Url ( withUrlOptions, withUrlOptionsPromptingCreds, @@ -34,7 +36,11 @@ import qualified Annex import qualified Utility.Url as U import Utility.IPAddress +#ifdef WITH_HTTP_CLIENT_RESTRICTED +import Network.HTTP.Client.Restricted +#else import Utility.HttpManagerRestricted +#endif import Utility.Metered import Git.Credential import qualified BuildInfo diff --git a/Annex/View.hs b/Annex/View.hs --- a/Annex/View.hs +++ b/Annex/View.hs @@ -293,7 +293,7 @@ , all hasfields (viewedFiles view viewedFileFromReference f metadata) ] where - view = View (Git.Ref "master") $ + view = View (Git.Ref "foo") $ map (\(mf, mv) -> ViewComponent mf (FilterValues $ S.filter (not . B.null . fromMetaValue) mv) visible) (fromMetaData metadata) visiblefields = sort (map viewField $ filter viewVisible (viewComponents view)) @@ -345,13 +345,13 @@ applyView' :: MkViewedFile -> (FilePath -> MetaData) -> View -> Annex Git.Branch applyView' mkviewedfile getfilemetadata view = do top <- fromRepo Git.repoPath - (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] + (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top] liftIO . nukeFile =<< fromRepo gitAnnexViewIndex viewg <- withViewIndex gitRepo withUpdateIndex viewg $ \uh -> do forM_ l $ \(f, sha, mode) -> do topf <- inRepo (toTopFilePath f) - go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f + go uh topf sha (toTreeItemType mode) =<< lookupKey f liftIO $ void clean genViewBranch view where @@ -365,7 +365,7 @@ f' <- fromRawFilePath <$> fromRepo (fromTopFilePath $ asTopFilePath $ toRawFilePath fv) stagesymlink uh f' =<< calcRepo (gitAnnexLink f' k) - go uh topf (Just sha) (Just treeitemtype) Nothing + go uh topf sha (Just treeitemtype) Nothing | "." `B.isPrefixOf` getTopFilePath topf = liftIO $ Git.UpdateIndex.streamUpdateIndex' uh $ pureStreamer $ updateIndexLine sha treeitemtype topf diff --git a/Annex/WorkTree.hs b/Annex/WorkTree.hs --- a/Annex/WorkTree.hs +++ b/Annex/WorkTree.hs @@ -35,8 +35,8 @@ - When in an adjusted branch that may have hidden the file, looks for a - pointer to a key in the original branch. -} -lookupFile :: RawFilePath -> Annex (Maybe Key) -lookupFile = lookupFile' catkeyfile +lookupKey :: RawFilePath -> Annex (Maybe Key) +lookupKey = lookupKey' catkeyfile where catkeyfile file = ifM (liftIO $ doesFileExist $ fromRawFilePath file) @@ -44,8 +44,8 @@ , catKeyFileHidden file =<< getCurrentBranch ) -lookupFileNotHidden :: RawFilePath -> Annex (Maybe Key) -lookupFileNotHidden = lookupFile' catkeyfile +lookupKeyNotHidden :: RawFilePath -> Annex (Maybe Key) +lookupKeyNotHidden = lookupKey' catkeyfile where catkeyfile file = ifM (liftIO $ doesFileExist $ fromRawFilePath file) @@ -53,8 +53,8 @@ , return Nothing ) -lookupFile' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key) -lookupFile' catkeyfile file = isAnnexLink file >>= \case +lookupKey' :: (RawFilePath -> Annex (Maybe Key)) -> RawFilePath -> Annex (Maybe Key) +lookupKey' catkeyfile file = isAnnexLink file >>= \case Just key -> return (Just key) Nothing -> catkeyfile file @@ -64,7 +64,7 @@ whenAnnexed a file = ifAnnexed file (a file) (return Nothing) ifAnnexed :: RawFilePath -> (Key -> Annex a) -> Annex a -> Annex a -ifAnnexed file yes no = maybe no yes =<< lookupFile file +ifAnnexed file yes no = maybe no yes =<< lookupKey file {- Find all unlocked files and update the keys database for them. - diff --git a/Assistant.hs b/Assistant.hs --- a/Assistant.hs +++ b/Assistant.hs @@ -72,7 +72,7 @@ startDaemon :: Bool -> Bool -> Maybe Duration -> Maybe String -> Maybe HostName -> Maybe (Maybe Handle -> Maybe Handle -> String -> FilePath -> IO ()) -> Annex () startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = do Annex.changeState $ \s -> s { Annex.daemon = True } - enableInteractiveJournalAccess + enableInteractiveBranchAccess pidfile <- fromRepo gitAnnexPidFile logfile <- fromRepo gitAnnexLogFile liftIO $ debugM desc $ "logging to " ++ logfile diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -145,7 +145,7 @@ (unwanted', ts) <- maybe (return (unwanted, [])) (findtransfers f unwanted) - =<< liftAnnex (lookupFile f) + =<< liftAnnex (lookupKey f) mapM_ (enqueue f) ts {- Delay for a short time to avoid using too much CPU. -} diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -289,7 +289,7 @@ onAddSymlink :: Handler onAddSymlink file filestatus = unlessIgnored file $ do linktarget <- liftIO (catchMaybeIO $ readSymbolicLink file) - kv <- liftAnnex (lookupFile (toRawFilePath file)) + kv <- liftAnnex (lookupKey (toRawFilePath file)) onAddSymlink' linktarget kv file filestatus onAddSymlink' :: Maybe String -> Maybe Key -> Handler diff --git a/Backend.hs b/Backend.hs --- a/Backend.hs +++ b/Backend.hs @@ -1,6 +1,6 @@ {- git-annex key/value backends - - - Copyright 2010-2017 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,6 +14,8 @@ lookupBackendVariety, maybeLookupBackendVariety, isStableKey, + isCryptographicallySecure, + isVerifiable, ) where import Annex.Common @@ -54,7 +56,7 @@ genKey :: KeySource -> MeterUpdate -> Maybe Backend -> Annex (Key, Backend) genKey source meterupdate preferredbackend = do b <- maybe defaultBackend return preferredbackend - case B.getKey b of + case B.genKey b of Just a -> do k <- a source meterupdate return (makesane k, b) @@ -100,4 +102,12 @@ isStableKey :: Key -> Bool isStableKey k = maybe False (`B.isStableKey` k) + (maybeLookupBackendVariety (fromKey keyVariety k)) + +isCryptographicallySecure :: Key -> Bool +isCryptographicallySecure k = maybe False (`B.isCryptographicallySecure` k) + (maybeLookupBackendVariety (fromKey keyVariety k)) + +isVerifiable :: Key -> Bool +isVerifiable k = maybe False (isJust . B.verifyKeyContent) (maybeLookupBackendVariety (fromKey keyVariety k)) diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -41,6 +41,17 @@ | Blake2sHash HashSize | Blake2spHash HashSize +cryptographicallySecure :: Hash -> Bool +cryptographicallySecure (SHA2Hash _) = True +cryptographicallySecure (SHA3Hash _) = True +cryptographicallySecure (SkeinHash _) = True +cryptographicallySecure (Blake2bHash _) = True +cryptographicallySecure (Blake2bpHash _) = True +cryptographicallySecure (Blake2sHash _) = True +cryptographicallySecure (Blake2spHash _) = True +cryptographicallySecure SHA1Hash = False +cryptographicallySecure MD5Hash = False + {- Order is slightly significant; want SHA256 first, and more general - sizes earlier. -} hashes :: [Hash] @@ -63,17 +74,18 @@ genBackend :: Hash -> Backend genBackend hash = Backend { backendVariety = hashKeyVariety hash (HasExt False) - , getKey = Just (keyValue hash) + , genKey = Just (keyValue hash) , verifyKeyContent = Just $ checkKeyChecksum hash , canUpgradeKey = Just needsUpgrade , fastMigrate = Just trivialMigrate , isStableKey = const True + , isCryptographicallySecure = const (cryptographicallySecure hash) } genBackendE :: Hash -> Backend genBackendE hash = (genBackend hash) { backendVariety = hashKeyVariety hash (HasExt True) - , getKey = Just (keyValueE hash) + , genKey = Just (keyValueE hash) } hashKeyVariety :: Hash -> HasExt -> KeyVariety @@ -296,10 +308,10 @@ testKeyBackend :: Backend testKeyBackend = let b = genBackendE (SHA2Hash (HashSize 256)) - gk = case getKey b of + gk = case genKey b of Nothing -> Nothing Just f -> Just (\ks p -> addE <$> f ks p) - in b { getKey = gk } + in b { genKey = gk } where addE k = alterKey k $ \d -> d { keyName = keyName d <> longext diff --git a/Backend/URL.hs b/Backend/URL.hs --- a/Backend/URL.hs +++ b/Backend/URL.hs @@ -21,13 +21,14 @@ backend :: Backend backend = Backend { backendVariety = URLKey - , getKey = Nothing + , genKey = Nothing , verifyKeyContent = Nothing , canUpgradeKey = Nothing , fastMigrate = Nothing -- The content of an url can change at any time, so URL keys are -- not stable. , isStableKey = const False + , isCryptographicallySecure = const False } {- Every unique url has a corresponding key. -} diff --git a/Backend/WORM.hs b/Backend/WORM.hs --- a/Backend/WORM.hs +++ b/Backend/WORM.hs @@ -24,11 +24,12 @@ backend :: Backend backend = Backend { backendVariety = WORMKey - , getKey = Just keyValue + , genKey = Just keyValue , verifyKeyContent = Nothing , canUpgradeKey = Just needsUpgrade - , fastMigrate = Just removeSpaces + , fastMigrate = Just removeProblemChars , isStableKey = const True + , isCryptographicallySecure = const False } {- The key includes the file size, modification time, and the @@ -48,12 +49,13 @@ , keyMtime = Just $ modificationTime stat } -{- Old WORM keys could contain spaces, and can be upgraded to remove them. -} +{- Old WORM keys could contain spaces and carriage returns, + - and can be upgraded to remove them. -} needsUpgrade :: Key -> Bool -needsUpgrade key = ' ' `S8.elem` fromKey keyName key +needsUpgrade key = any (`S8.elem` fromKey keyName key) [' ', '\r'] -removeSpaces :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key) -removeSpaces oldkey newbackend _ +removeProblemChars :: Key -> Backend -> AssociatedFile -> Annex (Maybe Key) +removeProblemChars oldkey newbackend _ | migratable = return $ Just $ alterKey oldkey $ \d -> d { keyName = encodeBS $ reSanitizeKeyName $ decodeBS $ keyName d } | otherwise = return Nothing diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,46 @@ +git-annex (8.20200720) upstream; urgency=medium + + * import: Added --no-content option, which avoids downloading files + from a special remote. Currently only supported by the directory + special remote. + * Honor annex.largefiles when importing a tree from a special remote. + (Except for when --no-content is used.) + * Fix a deadlock that could occur after git-annex got an unlocked + file, causing the command to hang indefinitely. Known to happen on + vfat filesystems, possibly others. + * Build with the http-client-restricted and git-lfs libraries when + available, otherwise use the vendored copy as before. + * testremote: Fix over-allocation of resources and bad caching, + including starting up a large number of external special remote processes. + (Regression introduced in version 8.20200501) + * test: Fix some test cases that assumed git's default branch name. + * importfeed: Added some additional --template variables: + itempubyear, itempubmonth, itempubday, itempubhour, + itempubminute, itempubsecond. + * Made several special remotes support locking content on them, + which allows dropping from other special remotes in some situations + where it was not possible before. Supported special remotes: + S3 (with versioning=yes), git-lfs, tahoe + * Fix reversion that broke passing annex.* and remote.*.annex-* + git configs with -c. (Since version 8.20200330.) + * Bring back git-annex branch read cache. This speeds up some operations, + eg git-annex sync --content --all gets 20% faster. + * Fix a recently introduced bug that could cause a "fork: resource exhausted" + after getting several thousand files. + * Sped up the --all option by 2x to 16x by using git cat-file --buffer. + Thanks to Lukey for finding this optimisation. + * Sped up seeking for annexed files to operate on by a factor of nearly 2x. + * Sped up sync --content by 2x and other commands like fsck --fast and + whereis by around 50%, by using git cat-file --buffer. + * importfeed: Made checking known urls step around 15% faster. + * fsck: Detect if WORM keys contain a carriage return, and recommend + upgrading the key. (git-annex could have maybe created such keys back + in 2013). + * When on an adjust --hide-missing branch, fix handling of files that + have been deleted but the deletion is not yet staged. + + -- Joey Hess Mon, 20 Jul 2020 14:40:51 -0400 + git-annex (8.20200617) upstream; urgency=medium * Added annex.skipunknown git config, that can be set to false to change diff --git a/COPYRIGHT b/COPYRIGHT --- a/COPYRIGHT +++ b/COPYRIGHT @@ -10,8 +10,12 @@ © 2014 Sören Brunk License: AGPL-3+ -Files: doc/special_remotes/external/* +Files: doc/special_remotes/external/* Copyright: © 2013 Joey Hess +License: GPL-3+ + +Files: doc/design/external_backend_protocol/git-annex-backend-XFOO +Copyright: © 2020 Joey Hess License: GPL-3+ Files: Remote/Ddar.hs diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -43,6 +43,9 @@ commandActions :: [CommandStart] -> Annex () commandActions = mapM_ commandAction +commandAction' :: (a -> b -> CommandStart) -> a -> b -> Annex () +commandAction' start a b = commandAction $ start a b + {- Runs one of the actions needed to perform a command. - Individual actions can fail without stopping the whole command, - including by throwing non-async exceptions. diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -80,7 +80,7 @@ batchLines :: BatchFormat -> Annex [String] batchLines fmt = do - enableInteractiveJournalAccess + enableInteractiveBranchAccess liftIO $ splitter <$> getContents where splitter = case fmt of diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -94,11 +94,7 @@ where setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ NumCopies n } setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } - setgitconfig v = Annex.adjustGitRepo $ \r -> - if Param v `elem` gitGlobalOpts r - then return r - else Git.Config.store (encodeBS' v) Git.Config.ConfigList $ - r { gitGlobalOpts = gitGlobalOpts r ++ [Param "-c", Param v] } + setgitconfig v = Annex.addGitConfigOverride v setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } {- Parser that accepts all non-option params. -} diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -9,6 +9,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE TupleSections #-} + module CmdLine.Seek where import Annex.Common @@ -19,38 +21,55 @@ import qualified Git.Command import qualified Git.LsFiles as LsFiles import qualified Git.LsTree as LsTree +import qualified Git.Types as Git +import qualified Git.Ref import Git.FilePath import qualified Limit import CmdLine.GitAnnex.Options -import Logs.Location +import Logs import Logs.Unused import Types.Transfer import Logs.Transfer import Remote.List import qualified Remote import Annex.CatFile +import Git.CatFile import Annex.CurrentBranch import Annex.Content +import Annex.Link import Annex.InodeSentinal +import Annex.Concurrent +import qualified Annex.Branch +import qualified Annex.BranchState import qualified Database.Keys import qualified Utility.RawFilePath as R +import Utility.Tuple -withFilesInGit :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek -withFilesInGit ww a l = seekActions $ prepFiltered a $ - seekHelper ww LsFiles.inRepo l +import Control.Concurrent.Async +import System.Posix.Types -withFilesInGitNonRecursive :: WarnUnmatchWhen -> String -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek -withFilesInGitNonRecursive ww needforce a l = ifM (Annex.getState Annex.force) - ( withFilesInGit ww a l +data AnnexedFileSeeker = AnnexedFileSeeker + { seekAction :: RawFilePath -> Key -> CommandSeek + , checkContentPresent :: Maybe Bool + , usesLocationLog :: Bool + } + +withFilesInGitAnnex :: WarnUnmatchWhen -> AnnexedFileSeeker -> [WorkTreeItem] -> CommandSeek +withFilesInGitAnnex ww a l = seekFilteredKeys a $ + seekHelper fst3 ww LsFiles.inRepoDetails l + +withFilesInGitAnnexNonRecursive :: WarnUnmatchWhen -> String -> AnnexedFileSeeker -> [WorkTreeItem] -> CommandSeek +withFilesInGitAnnexNonRecursive ww needforce a l = ifM (Annex.getState Annex.force) + ( withFilesInGitAnnex ww a l , if null l then giveup needforce - else seekActions $ prepFiltered a (getfiles [] l) + else seekFilteredKeys a (getfiles [] l) ) where getfiles c [] = return (reverse c) getfiles c ((WorkTreeItem p):ps) = do os <- seekOptions ww - (fs, cleanup) <- inRepo $ LsFiles.inRepo os [toRawFilePath p] + (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p] case fs of [f] -> do void $ liftIO $ cleanup @@ -68,8 +87,8 @@ g <- gitRepo liftIO $ Git.Command.leaveZombie <$> LsFiles.notInRepo [] force (map (\(WorkTreeItem f) -> toRawFilePath f) l) g - go fs = seekActions $ prepFiltered a $ - return $ concat $ segmentPaths (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs + go fs = seekFiltered a $ + return $ concat $ segmentPaths id (map (\(WorkTreeItem f) -> toRawFilePath f) l) fs withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do @@ -91,34 +110,29 @@ } withWords :: ([String] -> CommandSeek) -> CmdParams -> CommandSeek -withWords a params = seekActions $ return [a params] +withWords a params = a params withStrings :: (String -> CommandSeek) -> CmdParams -> CommandSeek -withStrings a params = seekActions $ return $ map a params +withStrings a params = sequence_ $ map a params withPairs :: ((String, String) -> CommandSeek) -> CmdParams -> CommandSeek -withPairs a params = seekActions $ return $ map a $ pairs [] params +withPairs a params = sequence_ $ map a $ pairs [] params where pairs c [] = reverse c pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = giveup "expected pairs" withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek -withFilesToBeCommitted a l = seekActions $ prepFiltered a $ - seekHelper WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l - -isOldUnlocked :: RawFilePath -> Annex Bool -isOldUnlocked f = liftIO (notSymlink f) <&&> - (isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f) +withFilesToBeCommitted a l = seekFiltered a $ + seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l {- unlocked pointer files that are staged, and whose content has not been - modified-} withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek -withUnmodifiedUnlockedPointers ww a l = seekActions $ - prepFiltered a unlockedfiles +withUnmodifiedUnlockedPointers ww a l = seekFiltered a unlockedfiles where unlockedfiles = filterM isUnmodifiedUnlocked - =<< seekHelper ww (const LsFiles.typeChangedStaged) l + =<< seekHelper id ww (const LsFiles.typeChangedStaged) l isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case @@ -127,11 +141,11 @@ {- Finds files that may be modified. -} withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> [WorkTreeItem] -> CommandSeek -withFilesMaybeModified ww a params = seekActions $ - prepFiltered a $ seekHelper ww LsFiles.modified params +withFilesMaybeModified ww a params = seekFiltered a $ + seekHelper id ww LsFiles.modified params withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek -withKeys a l = seekActions $ return $ map (a . parse) l +withKeys a l = sequence_ $ map (a . parse) l where parse p = fromMaybe (giveup "bad key") $ deserializeKey p @@ -180,26 +194,52 @@ giveup "Cannot use --auto in a bare repository" case (null params, ko) of (True, Nothing) - | bare -> noauto $ runkeyaction finishCheck loggedKeys + | bare -> noauto runallkeys | otherwise -> fallbackaction params (False, Nothing) -> fallbackaction params - (True, Just WantAllKeys) -> noauto $ runkeyaction finishCheck loggedKeys - (True, Just WantUnusedKeys) -> noauto $ runkeyaction (pure . Just) unusedKeys' + (True, Just WantAllKeys) -> noauto runallkeys + (True, Just WantUnusedKeys) -> noauto $ runkeyaction unusedKeys' (True, Just WantFailedTransfers) -> noauto runfailedtransfers - (True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (pure . Just) (return [k]) - (True, Just WantIncompleteKeys) -> noauto $ runkeyaction (pure . Just) incompletekeys + (True, Just (WantSpecificKey k)) -> noauto $ runkeyaction (return [k]) + (True, Just WantIncompleteKeys) -> noauto $ runkeyaction incompletekeys (True, Just (WantBranchKeys bs)) -> noauto $ runbranchkeys bs (False, Just _) -> giveup "Can only specify one of file names, --all, --branch, --unused, --failed, --key, or --incomplete" where noauto a | auto = giveup "Cannot use --auto with --all or --branch or --unused or --key or --incomplete" | otherwise = a + incompletekeys = staleKeysPrune gitAnnexTmpObjectDir True - runkeyaction checker getks = do + + -- List all location log files on the git-annex branch, + -- and use those to get keys. Pass through cat-file + -- to get the contents of the location logs, and pre-cache + -- those. This significantly speeds up typical operations + -- that need to look at the location log for each key. + runallkeys = do keyaction <- mkkeyaction + config <- Annex.getGitConfig + g <- Annex.gitRepo + + void Annex.Branch.update + (l, cleanup) <- inRepo $ LsTree.lsTree + LsTree.LsTreeRecursive + Annex.Branch.fullname + let getk f = fmap (,f) (locationLogFileKey config f) + let go reader = liftIO reader >>= \case + Nothing -> return () + Just ((k, f), content) -> do + maybe noop (Annex.BranchState.setCache f) content + keyaction (k, mkActionItem k) + go reader + catObjectStreamLsTree l (getk . getTopFilePath . LsTree.file) g go + liftIO $ void cleanup + + runkeyaction getks = do + keyaction <- mkkeyaction ks <- getks - forM_ ks $ checker >=> maybe noop - (\k -> keyaction (k, mkActionItem k)) + forM_ ks $ \k -> keyaction (k, mkActionItem k) + runbranchkeys bs = do keyaction <- mkkeyaction forM_ bs $ \b -> do @@ -211,6 +251,7 @@ in keyaction (k, bfp) unlessM (liftIO cleanup) $ error ("git ls-tree " ++ Git.fromRef b ++ " failed") + runfailedtransfers = do keyaction <- mkkeyaction rs <- remoteList @@ -218,23 +259,123 @@ forM_ ts $ \(t, i) -> keyaction (transferKey t, mkActionItem (t, i)) -prepFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex [CommandSeek] -prepFiltered a fs = do +seekFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex () +seekFiltered a fs = do matcher <- Limit.getMatcher - map (process matcher) <$> fs + sequence_ =<< (map (process matcher) <$> fs) where process matcher f = whenM (matcher $ MatchingFile $ FileInfo f f) $ a f -seekActions :: Annex [CommandSeek] -> Annex () -seekActions gen = sequence_ =<< gen +-- This is significantly faster than using lookupKey after seekFiltered, +-- because of the way data is streamed through git cat-file. +-- +-- It can also precache location logs using the same efficient streaming. +seekFilteredKeys :: AnnexedFileSeeker -> Annex [(RawFilePath, Git.Sha, FileMode)] -> Annex () +seekFilteredKeys seeker listfs = do + g <- Annex.gitRepo + matcher <- Limit.getMatcher + config <- Annex.getGitConfig + -- Run here, not in the async, because it could throw an exception + -- The list should be built lazily. + l <- listfs + catObjectMetaDataStream g $ \mdfeeder mdcloser mdreader -> + catObjectStream g $ \ofeeder ocloser oreader -> do + processertid <- liftIO . async =<< forkState + (process matcher ofeeder mdfeeder mdcloser False l) + mdprocessertid <- liftIO . async =<< forkState + (mdprocess matcher mdreader ofeeder ocloser) + if usesLocationLog seeker + then catObjectStream g $ \lfeeder lcloser lreader -> do + precachertid <- liftIO . async =<< forkState + (precacher config oreader lfeeder lcloser) + precachefinisher lreader + join (liftIO (wait precachertid)) + else finisher oreader + join (liftIO (wait mdprocessertid)) + join (liftIO (wait processertid)) + where + checkpresence k cont = case checkContentPresent seeker of + Just v -> do + present <- inAnnex k + when (present == v) cont + Nothing -> cont -seekHelper :: WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([RawFilePath], IO Bool)) -> [WorkTreeItem] -> Annex [RawFilePath] -seekHelper ww a l = do + finisher oreader = liftIO oreader >>= \case + Just (f, content) -> do + case parseLinkTargetOrPointerLazy =<< content of + Just k -> checkpresence k $ + seekAction seeker f k + Nothing -> noop + finisher oreader + Nothing -> return () + + precachefinisher lreader = liftIO lreader >>= \case + Just ((logf, f, k), logcontent) -> do + maybe noop (Annex.BranchState.setCache logf) logcontent + seekAction seeker f k + precachefinisher lreader + Nothing -> return () + + precacher config oreader lfeeder lcloser = liftIO oreader >>= \case + Just (f, content) -> do + case parseLinkTargetOrPointerLazy =<< content of + Just k -> checkpresence k $ + let logf = locationLogFile config k + ref = Git.Ref.branchFileRef Annex.Branch.fullname logf + in liftIO $ lfeeder ((logf, f, k), ref) + Nothing -> noop + precacher config oreader lfeeder lcloser + Nothing -> liftIO $ void lcloser + + feedmatches matcher ofeeder f sha = + whenM (matcher $ MatchingFile $ FileInfo f f) $ + liftIO $ ofeeder (f, sha) + + process matcher ofeeder mdfeeder mdcloser seenpointer ((f, sha, mode):rest) = + case Git.toTreeItemType mode of + Just Git.TreeSymlink -> do + whenM (exists f) $ + -- Once a pointer file has been seen, + -- symlinks have to be sent via the + -- metadata processor too. That is slightly + -- slower, but preserves the requested + -- file order. + if seenpointer + then liftIO $ mdfeeder (f, sha) + else feedmatches matcher ofeeder f sha + process matcher ofeeder mdfeeder mdcloser seenpointer rest + Just Git.TreeSubmodule -> + process matcher ofeeder mdfeeder mdcloser seenpointer rest + -- Might be a pointer file, might be other + -- file in git, possibly large. Avoid catting + -- large files by first looking up the size. + Just _ -> do + whenM (exists f) $ + liftIO $ mdfeeder (f, sha) + process matcher ofeeder mdfeeder mdcloser True rest + Nothing -> + process matcher ofeeder mdfeeder mdcloser seenpointer rest + process _ _ _ mdcloser _ [] = liftIO $ void mdcloser + + -- Check if files exist, because a deleted file will still be + -- listed by ls-tree, but should not be processed. + exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p) + + mdprocess matcher mdreader ofeeder ocloser = liftIO mdreader >>= \case + Just (f, Just (sha, size, _type)) + | size < maxPointerSz -> do + feedmatches matcher ofeeder f sha + mdprocess matcher mdreader ofeeder ocloser + Just _ -> mdprocess matcher mdreader ofeeder ocloser + Nothing -> liftIO $ void ocloser + +seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> [WorkTreeItem] -> Annex [a] +seekHelper c ww a l = do os <- seekOptions ww inRepo $ \g -> concat . concat <$> forM (segmentXargsOrdered l') - (runSegmentPaths (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath) + (runSegmentPaths c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath) where l' = map (\(WorkTreeItem f) -> f) l diff --git a/Command/Config.hs b/Command/Config.hs --- a/Command/Config.hs +++ b/Command/Config.hs @@ -13,7 +13,7 @@ import Logs.Config import Config import Types.GitConfig (globalConfigs) -import Git.Types (ConfigKey(..), fromConfigValue) +import Git.Types (fromConfigValue) import qualified Data.ByteString.Char8 as S8 diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -45,13 +45,19 @@ seek :: CopyOptions -> CommandSeek seek o = startConcurrency commandStages $ do - let go = whenAnnexed $ start o + let go = start o + let seeker = AnnexedFileSeeker + { seekAction = commandAction' go + , checkContentPresent = Nothing + , usesLocationLog = False + } case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . Command.Move.startKey (fromToOptions o) Command.Move.RemoveNever) - (withFilesInGit ww $ commandAction . go) + (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (copyFiles o) where ww = WarnUnmatchLsFiles diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -54,14 +54,21 @@ seek :: DropOptions -> CommandSeek seek o = startConcurrency commandStages $ case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . startKeys o) - (withFilesInGit ww (commandAction . go)) + (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (dropFiles o) where - go = whenAnnexed $ start o + go = start o ww = WarnUnmatchLsFiles + + seeker = AnnexedFileSeeker + { seekAction = commandAction' go + , checkContentPresent = Nothing + , usesLocationLog = False + } start :: DropOptions -> RawFilePath -> Key -> CommandStart start o file key = start' o key afile ai diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -200,7 +200,7 @@ mapdiff a oldtreesha newtreesha = do (diff, cleanup) <- inRepo $ Git.DiffTree.diffTreeRecursive oldtreesha newtreesha - seekActions $ pure $ map a diff + sequence_ $ map a diff void $ liftIO cleanup -- Map of old and new filenames for each changed ExportKey in a diff. diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -13,7 +13,6 @@ import qualified Data.ByteString.Char8 as S8 import Command -import Annex.Content import Limit import Types.Key import Git.FilePath @@ -55,23 +54,31 @@ seek :: FindOptions -> CommandSeek seek o = case batchOption o of - NoBatch -> withKeyOptions (keyOptions o) False - (commandAction . startKeys o) - (withFilesInGit ww (commandAction . go)) - =<< workTreeItems ww (findThese o) - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + NoBatch -> do + islimited <- limited + let seeker = AnnexedFileSeeker + { seekAction = commandAction' go + -- only files with content present are shown, unless + -- the user has requested others via a limit + , checkContentPresent = if islimited + then Nothing + else Just True + , usesLocationLog = False + } + withKeyOptions (keyOptions o) False + (commandAction . startKeys o) + (withFilesInGitAnnex ww seeker) + =<< workTreeItems ww (findThese o) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) where - go = whenAnnexed $ start o + go = start o ww = WarnUnmatchLsFiles --- only files inAnnex are shown, unless the user has requested --- others via a limit start :: FindOptions -> RawFilePath -> Key -> CommandStart -start o file key = - stopUnless (limited <||> inAnnex key) $ - startingCustomOutput key $ do - showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key - next $ return True +start o file key = startingCustomOutput key $ do + showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key + next $ return True startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -31,12 +31,15 @@ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = unlessM crippledFileSystem $ do - withFilesInGit ww - (commandAction . (whenAnnexed $ start FixAll)) - =<< workTreeItems ww ps +seek ps = unlessM crippledFileSystem $ + withFilesInGitAnnex ww seeker =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles + seeker = AnnexedFileSeeker + { seekAction = commandAction' (start FixAll) + , checkContentPresent = Nothing + , usesLocationLog = False + } data FixWhat = FixSymlinks | FixAll diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -84,7 +84,7 @@ Nothing -> giveup $ "bad key/url " ++ s perform :: Key -> FilePath -> CommandPerform -perform key file = lookupFileNotHidden (toRawFilePath file) >>= \case +perform key file = lookupKeyNotHidden (toRawFilePath file) >>= \case Nothing -> ifM (liftIO $ doesFileExist file) ( hasothercontent , do diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -92,9 +92,14 @@ u <- maybe getUUID (pure . Remote.uuid) from checkDeadRepo u i <- prepIncremental u (incrementalOpt o) + let seeker = AnnexedFileSeeker + { seekAction = commandAction' (start from i) + , checkContentPresent = Nothing + , usesLocationLog = True + } withKeyOptions (keyOptions o) False (\kai -> commandAction . startKey from i kai =<< getNumCopies) - (withFilesInGit ww $ commandAction . (whenAnnexed (start from i))) + (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (fsckFiles o) cleanupIncremental i void $ tryIO $ recordActivity Fsck u @@ -256,7 +261,7 @@ - insecure hash is present. This should only be able to happen - if the repository already contained the content before the - config was set. -} - when (present && not (cryptographicallySecure (fromKey keyVariety key))) $ + when (present && not (Backend.isCryptographicallySecure key)) $ whenM (annexSecureHashesOnly <$> Annex.getGitConfig) $ warning $ "** Despite annex.securehashesonly being set, " ++ obj ++ " has content present in the annex using an insecure " ++ decodeBS (formatKeyVariety (fromKey keyVariety key)) ++ " key" diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -40,12 +40,18 @@ seek :: GetOptions -> CommandSeek seek o = startConcurrency downloadStages $ do from <- maybe (pure Nothing) (Just <$$> getParsed) (getFrom o) - let go = whenAnnexed $ start o from + let go = start o from + let seeker = AnnexedFileSeeker + { seekAction = commandAction' go + , checkContentPresent = Just False + , usesLocationLog = True + } case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) (autoMode o) (commandAction . startKeys from) - (withFilesInGit ww (commandAction . go)) + (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (getFiles o) where ww = WarnUnmatchLsFiles diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2012-2019 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -17,6 +17,7 @@ import qualified Types.Remote as Remote import qualified Git.Ref import Utility.CopyFile +import Utility.OptParse import Backend import Types.KeySource import Annex.CheckIgnore @@ -53,12 +54,16 @@ { importFromRemote :: DeferredParse Remote , importToBranch :: Branch , importToSubDir :: Maybe FilePath + , importContent :: Bool } optParser :: CmdParamsDesc -> Parser ImportOptions optParser desc = do ps <- cmdParams desc mfromremote <- optional $ parseRemoteOption <$> parseFromOption + content <- invertableSwitch "content" True + ( help "do not get contents of imported files" + ) dupmode <- fromMaybe Default <$> optional duplicateModeParser return $ case mfromremote of Nothing -> LocalImportOptions ps dupmode @@ -68,6 +73,7 @@ in RemoteImportOptions r (Ref (encodeBS' branch)) (if null subdir then Nothing else Just subdir) + content _ -> giveup "expected BRANCH[:SUBDIR]" data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates | ReinjectDuplicates @@ -114,7 +120,7 @@ (pure Nothing) (Just <$$> inRepo . toTopFilePath . toRawFilePath) (importToSubDir o) - seekRemote r (importToBranch o) subdir + seekRemote r (importToBranch o) subdir (importContent o) startLocal :: AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart startLocal addunlockedmatcher largematcher mode (srcfile, destfile) = @@ -258,8 +264,8 @@ verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck (const yes) no -seekRemote :: Remote -> Branch -> Maybe TopFilePath -> CommandSeek -seekRemote remote branch msubdir = do +seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CommandSeek +seekRemote remote branch msubdir importcontent = do importtreeconfig <- case msubdir of Nothing -> return ImportTree Just subdir -> @@ -279,7 +285,7 @@ void $ includeCommandAction (listContents remote importabletvar) liftIO (atomically (readTVar importabletvar)) >>= \case Nothing -> return () - Just importable -> downloadImport remote importtreeconfig importable >>= \case + Just importable -> importKeys remote importtreeconfig importcontent importable >>= \case Nothing -> warning $ concat [ "Failed to import some files from " , Remote.name remote @@ -307,7 +313,7 @@ liftIO $ atomically $ writeTVar tvar (Just importable') return True -commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents Key -> CommandStart +commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents (Either Sha Key) -> CommandStart commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = starting "update" (ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)) $ do importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -1,11 +1,12 @@ {- git-annex command - - - Copyright 2013-2017 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Command.ImportFeed where @@ -16,8 +17,11 @@ import qualified Data.Map as M import Data.Time.Clock import Data.Time.Format +import Data.Time.Calendar +import Data.Time.LocalTime import qualified Data.Text as T import System.Log.Logger +import Control.Concurrent.Async import Command import qualified Annex @@ -41,6 +45,10 @@ import Annex.FileMatcher import Command.AddUrl (addWorkTree) import Annex.UntrustedFilePath +import qualified Git.Ref +import qualified Annex.Branch +import Logs +import Git.CatFile (catObjectStream) cmd :: Command cmd = notBareRepo $ @@ -117,7 +125,7 @@ ( ret S.empty S.empty , do showStart "importfeed" "checking known urls" - (is, us) <- unzip <$> (mapM knownItems =<< knownUrls) + (is, us) <- unzip <$> knownItems showEndOk ret (S.fromList us) (S.fromList (concat is)) ) @@ -125,13 +133,33 @@ tmpl = Utility.Format.gen $ fromMaybe defaultTemplate opttemplate ret us is = return $ Cache us is tmpl -knownItems :: (Key, URLString) -> Annex ([ItemId], URLString) -knownItems (k, u) = do - itemids <- S.toList . S.filter (/= noneValue) - . S.map (decodeBS . fromMetaValue) - . currentMetaDataValues itemIdField - <$> getCurrentMetaData k - return (itemids, u) +knownItems :: Annex [([ItemId], URLString)] +knownItems = do + g <- Annex.gitRepo + config <- Annex.getGitConfig + catObjectStream g $ \catfeeder catcloser catreader -> do + rt <- liftIO $ async $ reader catreader [] + withKnownUrls (feeder config catfeeder catcloser) + liftIO (wait rt) + where + feeder config catfeeder catcloser urlreader = urlreader >>= \case + Just (k, us) -> do + forM_ us $ \u -> + let logf = metaDataLogFile config k + ref = Git.Ref.branchFileRef Annex.Branch.fullname logf + in liftIO $ catfeeder (u, ref) + feeder config catfeeder catcloser urlreader + Nothing -> liftIO catcloser + + reader catreader c = catreader >>= \case + Just (u, Just mdc) -> + let !itemids = S.toList $ S.filter (/= noneValue) $ + S.map (decodeBS . fromMetaValue) $ + currentMetaDataValues itemIdField $ + parseCurrentMetaData mdc + in reader catreader ((itemids,u):c) + Just (u, Nothing) -> reader catreader (([],u):c) + Nothing -> return c findDownloads :: URLString -> Feed -> [ToDownload] findDownloads u f = catMaybes $ map mk (feedItems f) @@ -141,8 +169,8 @@ Just $ ToDownload f u i $ Enclosure $ T.unpack enclosureurl Nothing -> case getItemLink i of - Just link -> Just $ ToDownload f u i $ - MediaLink $ T.unpack link + Just l -> Just $ ToDownload f u i $ + MediaLink $ T.unpack l Nothing -> Nothing {- Feeds change, so a feed download cannot be resumed. -} @@ -313,15 +341,43 @@ feedFile tmpl i extension = Utility.Format.format tmpl $ M.map sanitizeFilePath $ M.fromList $ extractFields i ++ [ ("extension", extension) - , extractField "itempubdate" [pubdate $ item i] + , extractField "itempubdate" [itempubdate] + , extractField "itempubyear" [itempubyear] + , extractField "itempubmonth" [itempubmonth] + , extractField "itempubday" [itempubday] + , extractField "itempubhour" [itempubhour] + , extractField "itempubminute" [itempubminute] + , extractField "itempubsecond" [itempubsecond] ] where - pubdate itm = case getItemPublishDate itm :: Maybe (Maybe UTCTime) of - Just (Just d) -> Just $ - formatTime defaultTimeLocale "%F" d + itm = item i + + pubdate = case getItemPublishDate itm :: Maybe (Maybe UTCTime) of + Just (Just d) -> Just d + _ -> Nothing + + itempubdate = case pubdate of + Just pd -> Just $ + formatTime defaultTimeLocale "%F" pd -- if date cannot be parsed, use the raw string - _ -> replace "/" "-" . T.unpack + Nothing-> replace "/" "-" . T.unpack <$> getItemPublishDateString itm + + (itempubyear, itempubmonth, itempubday) = case pubdate of + Nothing -> (Nothing, Nothing, Nothing) + Just pd -> + let (y, m, d) = toGregorian (utctDay pd) + in (Just (show y), Just (show m), Just (show d)) + + (itempubhour, itempubminute, itempubsecond) = case pubdate of + Nothing -> (Nothing, Nothing, Nothing) + Just pd -> + let tod = timeToTimeOfDay (utctDayTime pd) + in ( Just (show (todHour tod)) + , Just (show (todMin tod)) + -- avoid fractional seconds + , Just (takeWhile (/= '.') (show (todSec tod))) + ) extractMetaData :: ToDownload -> MetaData extractMetaData i = case getItemPublishDate (item i) :: Maybe (Maybe UTCTime) of diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -30,7 +30,6 @@ import Logs.Trust import Logs.Location import Annex.NumCopies -import Remote import Git.Config (boolConfig) import qualified Git.LsTree as LsTree import Utility.Percentage @@ -319,11 +318,11 @@ repo_list :: TrustLevel -> Stat repo_list level = stat n $ nojson $ lift $ do us <- filter (/= NoUUID) . M.keys - <$> (M.union <$> (M.map fromUUIDDesc <$> uuidDescMap) <*> remoteMap Remote.name) + <$> (M.union <$> (M.map fromUUIDDesc <$> uuidDescMap) <*> Remote.remoteMap Remote.name) rs <- fst <$> trustPartition level us countRepoList (length rs) -- This also handles json display. - <$> prettyPrintUUIDs n rs + <$> Remote.prettyPrintUUIDs n rs where n = showTrustLevel level ++ " repositories" @@ -497,9 +496,9 @@ . M.toList <$> cachedRepoData let maxlen = maximum (map (length . snd) l) - descm <- lift uuidDescriptions + descm <- lift Remote.uuidDescriptions -- This also handles json display. - s <- lift $ prettyPrintUUIDsWith (Just "size") desc descm (Just . show) $ + s <- lift $ Remote.prettyPrintUUIDsWith (Just "size") desc descm (Just . show) $ map (\(u, sz) -> (u, Just $ mkdisp sz maxlen)) l return $ countRepoList (length l) s where diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -14,7 +14,6 @@ import Command import Annex.SpecialRemote import qualified Remote -import qualified Logs.Remote import qualified Types.Remote as R import Types.RemoteConfig import Annex.UUID diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -38,8 +38,12 @@ | otherwise -> commandAction stop _ -> do let s = S.fromList ts - withFilesInGit ww - (commandAction . (whenAnnexed (start s))) + let seeker = AnnexedFileSeeker + { seekAction = commandAction' (start s) + , checkContentPresent = Nothing + , usesLocationLog = False + } + withFilesInGitAnnex ww seeker =<< workTreeItems ww (inprogressFiles o) where ww = WarnUnmatchLsFiles diff --git a/Command/List.hs b/Command/List.hs --- a/Command/List.hs +++ b/Command/List.hs @@ -44,8 +44,12 @@ seek o = do list <- getList o printHeader list - withFilesInGit ww (commandAction . (whenAnnexed $ start list)) - =<< workTreeItems ww (listThese o) + let seeker = AnnexedFileSeeker + { seekAction = commandAction' (start list) + , checkContentPresent = Nothing + , usesLocationLog = True + } + withFilesInGitAnnex ww seeker =<< workTreeItems ww (listThese o) where ww = WarnUnmatchLsFiles diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -8,7 +8,6 @@ module Command.Lock where import Command -import qualified Annex.Queue import qualified Annex import Annex.Content import Annex.Link @@ -29,14 +28,17 @@ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = do - l <- workTreeItems ww ps - withFilesInGit ww (commandAction . (whenAnnexed startNew)) l +seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles + seeker = AnnexedFileSeeker + { seekAction = commandAction' start + , checkContentPresent = Nothing + , usesLocationLog = False + } -startNew :: RawFilePath -> Key -> CommandStart -startNew file key = ifM (isJust <$> isAnnexLink file) +start :: RawFilePath -> Key -> CommandStart +start file key = ifM (isJust <$> isAnnexLink file) ( stop , starting "lock" (mkActionItem (key, file)) $ go =<< liftIO (isPointerFile file) @@ -53,14 +55,14 @@ , errorModified ) ) - cont = performNew file key + cont = perform file key -performNew :: RawFilePath -> Key -> CommandPerform -performNew file key = do +perform :: RawFilePath -> Key -> CommandPerform +perform file key = do lockdown =<< calcRepo (gitAnnexLocation key) addLink (fromRawFilePath file) key =<< withTSDelta (liftIO . genInodeCache file) - next $ cleanupNew file key + next $ cleanup file key where lockdown obj = do ifM (isUnmodified key obj) @@ -96,22 +98,10 @@ lostcontent = logStatus key InfoMissing -cleanupNew :: RawFilePath -> Key -> CommandCleanup -cleanupNew file key = do +cleanup :: RawFilePath -> Key -> CommandCleanup +cleanup file key = do Database.Keys.removeAssociatedFile key =<< inRepo (toTopFilePath file) return True - -startOld :: RawFilePath -> CommandStart -startOld file = do - unlessM (Annex.getState Annex.force) - errorModified - starting "lock" (ActionItemWorkTreeFile file) $ - performOld file - -performOld :: RawFilePath -> CommandPerform -performOld file = do - Annex.Queue.addCommand "checkout" [Param "--"] [fromRawFilePath file] - next $ return True errorModified :: a errorModified = giveup "Locking this file would discard any changes you have made to it. Use 'git annex add' to stage your changes. (Or, use --force to override)" diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -85,9 +85,15 @@ m <- Remote.uuidDescriptions zone <- liftIO getCurrentTimeZone let outputter = mkOutputter m zone o + let seeker = AnnexedFileSeeker + { seekAction = commandAction' (start o outputter) + , checkContentPresent = Nothing + -- the way this uses the location log would not be helped + -- by precaching the current value + , usesLocationLog = False + } case (logFiles o, allOption o) of - (fs, False) -> withFilesInGit ww - (commandAction . (whenAnnexed $ start o outputter)) + (fs, False) -> withFilesInGitAnnex ww seeker =<< workTreeItems ww fs ([], True) -> commandAction (startAll o outputter) (_, True) -> giveup "Cannot specify both files and --all" diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -76,14 +76,19 @@ NoBatch -> do c <- liftIO currentVectorClock let ww = WarnUnmatchLsFiles - let seeker = case getSet o of - Get _ -> withFilesInGit ww - GetAll -> withFilesInGit ww - Set _ -> withFilesInGitNonRecursive ww + let seeker = AnnexedFileSeeker + { seekAction = commandAction' (start c o) + , checkContentPresent = Nothing + , usesLocationLog = False + } + let seekaction = case getSet o of + Get _ -> withFilesInGitAnnex ww + GetAll -> withFilesInGitAnnex ww + Set _ -> withFilesInGitAnnexNonRecursive ww "Not recursively setting metadata. Use --force to do that." withKeyOptions (keyOptions o) False (commandAction . startKeys c o) - (seeker (commandAction . (whenAnnexed (start c o)))) + (seekaction seeker) =<< workTreeItems ww (forFiles o) Batch fmt -> withMessageState $ \s -> case outputType s of JSONOutput _ -> ifM limited @@ -168,7 +173,7 @@ startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart startBatch (i, (MetaData m)) = case i of Left f -> do - mk <- lookupFile f + mk <- lookupKey f case mk of Just k -> go k (mkActionItem (k, AssociatedFile (Just f))) Nothing -> giveup $ "not an annexed file: " ++ fromRawFilePath f diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -26,10 +26,14 @@ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek = withFilesInGit ww (commandAction . (whenAnnexed start)) - <=< workTreeItems ww +seek = withFilesInGitAnnex ww seeker <=< workTreeItems ww where ww = WarnUnmatchLsFiles + seeker = AnnexedFileSeeker + { seekAction = commandAction' start + , checkContentPresent = Nothing + , usesLocationLog = False + } start :: RawFilePath -> Key -> CommandStart start file key = do diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -44,13 +44,18 @@ seek o = startConcurrency stages $ withKeyOptions (keyOptions o) False (commandAction . startKey o (AssociatedFile Nothing)) - (withFilesInGit ww (commandAction . (whenAnnexed $ start o))) + (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (mirrorFiles o) where stages = case fromToOptions o of FromRemote _ -> downloadStages ToRemote _ -> commandStages ww = WarnUnmatchLsFiles + seeker = AnnexedFileSeeker + { seekAction = commandAction' (start o) + , checkContentPresent = Nothing + , usesLocationLog = False + } start :: MirrorOptions -> RawFilePath -> Key -> CommandStart start o file k = startKey o afile (k, ai) diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -55,12 +55,18 @@ seek :: MoveOptions -> CommandSeek seek o = startConcurrency stages $ do - let go = whenAnnexed $ start (fromToOptions o) (removeWhen o) + let go = start (fromToOptions o) (removeWhen o) + let seeker = AnnexedFileSeeker + { seekAction = commandAction' go + , checkContentPresent = Nothing + , usesLocationLog = False + } case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) NoBatch -> withKeyOptions (keyOptions o) False (commandAction . startKey (fromToOptions o) (removeWhen o)) - (withFilesInGit ww (commandAction . go)) + (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (moveFiles o) where stages = case fromToOptions o of diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -130,13 +130,13 @@ starting "sending files" (ActionItemOther Nothing) $ withTmpFile "send" $ \t h -> do let ww = WarnUnmatchLsFiles - fs' <- seekHelper ww LsFiles.inRepo + fs' <- seekHelper id ww LsFiles.inRepo =<< workTreeItems ww fs matcher <- Limit.getMatcher let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $ liftIO $ hPutStrLn h o forM_ fs' $ \f -> do - mk <- lookupFile f + mk <- lookupKey f case mk of Nothing -> noop Just k -> withObjectLoc k $ diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -13,7 +13,6 @@ import Annex import Utility.Rsync import Types.Transfer -import Types.Remote (RetrievalSecurityPolicy(..)) import Command.SendKey (fieldTransfer) import qualified CmdLine.GitAnnexShell.Fields as Fields diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -88,18 +88,23 @@ b <- liftIO $ L.hGetContents stdin ifM fileoutsiderepo ( liftIO $ L.hPut stdout b - , case parseLinkTargetOrPointerLazy b of - Just k -> do - getMoveRaceRecovery k (toRawFilePath file) - liftIO $ L.hPut stdout b - Nothing -> do - let fileref = Git.Ref.fileRef (toRawFilePath file) - indexmeta <- catObjectMetaData fileref - go b indexmeta =<< catKey' fileref indexmeta + , do + -- Avoid a potential deadlock. + Annex.changeState $ \s -> s + { Annex.insmudgecleanfilter = True } + go b ) stop where - go b indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) + go b = case parseLinkTargetOrPointerLazy b of + Just k -> do + getMoveRaceRecovery k (toRawFilePath file) + liftIO $ L.hPut stdout b + Nothing -> do + let fileref = Git.Ref.fileRef (toRawFilePath file) + indexmeta <- catObjectMetaData fileref + go' b indexmeta =<< catKey' fileref indexmeta + go' b indexmeta oldkey = ifM (shouldAnnex file indexmeta oldkey) ( do -- Before git 2.5, failing to consume all stdin here -- would cause a SIGPIPE and crash it. diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -70,6 +70,7 @@ import Utility.Bloom import Utility.OptParse import Utility.Process.Transcript +import Utility.Tuple import Control.Concurrent.MVar import qualified Data.Map as M @@ -455,7 +456,7 @@ let subdir = if S.null p then Nothing else Just (asTopFilePath p) - Command.Import.seekRemote remote branch subdir + Command.Import.seekRemote remote branch subdir True void $ mergeRemote remote currbranch mergeconfig o where wantpull = remoteAnnexPull (Remote.gitconfig remote) @@ -651,22 +652,26 @@ waitForAllRunningCommandActions liftIO $ not <$> isEmptyMVar mvar where - seekworktree mvar l bloomfeeder = - seekHelper ww LsFiles.inRepo l - >>= gofiles bloomfeeder mvar + seekworktree mvar l bloomfeeder = do + let seeker = AnnexedFileSeeker + { seekAction = gofile bloomfeeder mvar + , checkContentPresent = Nothing + , usesLocationLog = True + } + seekFilteredKeys seeker $ + seekHelper fst3 ww LsFiles.inRepoDetails l - seekincludinghidden origbranch mvar l bloomfeeder = - seekHelper ww (LsFiles.inRepoOrBranch origbranch) l - >>= gofiles bloomfeeder mvar + seekincludinghidden origbranch mvar l bloomfeeder = + seekFiltered (\f -> ifAnnexed f (gofile bloomfeeder mvar f) noop) $ + seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l ww = WarnUnmatchLsFiles - gofiles bloomfeeder mvar = mapM_ $ \f -> - ifAnnexed f - (go (Right bloomfeeder) mvar (AssociatedFile (Just f))) - noop + gofile bloom mvar f k = + go (Right bloom) mvar (AssociatedFile (Just f)) k - gokey mvar bloom (k, _) = go (Left bloom) mvar (AssociatedFile Nothing) k + gokey mvar bloom (k, _) = + go (Left bloom) mvar (AssociatedFile Nothing) k go ebloom mvar af k = do -- Run syncFile as a command action so file transfers run diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -13,7 +13,7 @@ import qualified Annex import qualified Remote import qualified Types.Remote as Remote -import qualified Types.Backend as Backend +import qualified Types.Backend import Types.KeySource import Annex.Content import Annex.WorkTree @@ -75,7 +75,9 @@ start :: TestRemoteOptions -> CommandStart start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do fast <- Annex.getState Annex.fast - r <- either giveup disableExportTree =<< Remote.byName' (testRemote o) + cache <- liftIO newRemoteVariantCache + r <- either giveup (disableExportTree cache) + =<< Remote.byName' (testRemote o) ks <- case testReadonlyFile o of [] -> if Remote.readonly r then giveup "This remote is readonly, so you need to use the --test-readonly option." @@ -88,11 +90,11 @@ else r { Remote.readonly = True } let drs = if Remote.readonly r' then [Described "remote" (pure (Just r'))] - else remoteVariants (Described "remote" (pure r')) basesz fast + else remoteVariants cache (Described "remote" (pure r')) basesz fast unavailr <- Remote.mkUnavailable r' let exportr = if Remote.readonly r' then return Nothing - else exportTreeVariant r' + else exportTreeVariant cache r' perform drs unavailr exportr ks where basesz = fromInteger $ sizeOption o @@ -114,61 +116,79 @@ where desck k = unwords [ "key size", show (fromKey keySize k) ] -remoteVariants :: Described (Annex Remote) -> Int -> Bool -> [Described (Annex (Maybe Remote))] -remoteVariants dr basesz fast = - concatMap encryptionVariants $ +remoteVariants :: RemoteVariantCache -> Described (Annex Remote) -> Int -> Bool -> [Described (Annex (Maybe Remote))] +remoteVariants cache dr basesz fast = + concatMap (encryptionVariants cache) $ map chunkvariant (chunkSizes basesz fast) where chunkvariant sz = Described (getDesc dr ++ " chunksize=" ++ show sz) $ do r <- getVal dr - adjustChunkSize r sz + adjustChunkSize cache r sz -adjustChunkSize :: Remote -> Int -> Annex (Maybe Remote) -adjustChunkSize r chunksize = adjustRemoteConfig r $ +adjustChunkSize :: RemoteVariantCache -> Remote -> Int -> Annex (Maybe Remote) +adjustChunkSize cache r chunksize = adjustRemoteConfig cache r $ M.insert chunkField (Proposed (show chunksize)) -- Variants of a remote with no encryption, and with simple shared -- encryption. Gpg key based encryption is not tested. -encryptionVariants :: Described (Annex (Maybe Remote)) -> [Described (Annex (Maybe Remote))] -encryptionVariants dr = [noenc, sharedenc] +encryptionVariants :: RemoteVariantCache -> Described (Annex (Maybe Remote)) -> [Described (Annex (Maybe Remote))] +encryptionVariants cache dr = [noenc, sharedenc] where noenc = Described (getDesc dr ++ " encryption=none") $ getVal dr >>= \case Nothing -> return Nothing - Just r -> adjustRemoteConfig r $ + Just r -> adjustRemoteConfig cache r $ M.insert encryptionField (Proposed "none") sharedenc = Described (getDesc dr ++ " encryption=shared") $ getVal dr >>= \case Nothing -> return Nothing - Just r -> adjustRemoteConfig r $ + Just r -> adjustRemoteConfig cache r $ M.insert encryptionField (Proposed "shared") . M.insert highRandomQualityField (Proposed "false") -- Variant of a remote with exporttree disabled. -disableExportTree :: Remote -> Annex Remote -disableExportTree r = maybe (error "failed disabling exportree") return - =<< adjustRemoteConfig r (M.delete exportTreeField) +disableExportTree :: RemoteVariantCache -> Remote -> Annex Remote +disableExportTree cache r = maybe (error "failed disabling exportree") return + =<< adjustRemoteConfig cache r (M.delete exportTreeField) -- Variant of a remote with exporttree enabled. -exportTreeVariant :: Remote -> Annex (Maybe Remote) -exportTreeVariant r = ifM (Remote.isExportSupported r) - ( adjustRemoteConfig r $ +exportTreeVariant :: RemoteVariantCache -> Remote -> Annex (Maybe Remote) +exportTreeVariant cache r = ifM (Remote.isExportSupported r) + ( adjustRemoteConfig cache r $ M.insert encryptionField (Proposed "none") . M.insert exportTreeField (Proposed "yes") , return Nothing ) +-- The Annex wrapper is used by Test; it should return the same TMVar +-- each time run. +type RemoteVariantCache = Annex (TVar (M.Map RemoteConfig Remote)) + +newRemoteVariantCache :: IO RemoteVariantCache +newRemoteVariantCache = newTVarIO M.empty >>= return . pure + -- Regenerate a remote with a modified config. -adjustRemoteConfig :: Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote) -adjustRemoteConfig r adjustconfig = do - repo <- Remote.getRepo r +adjustRemoteConfig :: RemoteVariantCache -> Remote -> (Remote.RemoteConfig -> Remote.RemoteConfig) -> Annex (Maybe Remote) +adjustRemoteConfig getcache r adjustconfig = do + cache <- getcache + m <- liftIO $ atomically $ readTVar cache let ParsedRemoteConfig _ origc = Remote.config r - Remote.generate (Remote.remotetype r) - repo - (Remote.uuid r) - (adjustconfig origc) - (Remote.gitconfig r) - (Remote.remoteStateHandle r) + let newc = adjustconfig origc + case M.lookup newc m of + Just r' -> return (Just r') + Nothing -> do + repo <- Remote.getRepo r + v <- Remote.generate (Remote.remotetype r) + repo + (Remote.uuid r) + newc + (Remote.gitconfig r) + (Remote.remoteStateHandle r) + case v of + Just r' -> liftIO $ atomically $ + modifyTVar' cache $ M.insert newc r' + Nothing -> return () + return v data Described t = Described { getDesc :: String @@ -270,7 +290,7 @@ present r k b = (== Right b) <$> Remote.hasKey r k fsck _ k = case maybeLookupBackendVariety (fromKey keyVariety k) of Nothing -> return True - Just b -> case Backend.verifyKeyContent b of + 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 $ \dest -> @@ -412,14 +432,14 @@ , contentLocation = toRawFilePath f , inodeCache = Nothing } - k <- case Backend.getKey Backend.Hash.testKeyBackend of + k <- case Types.Backend.genKey Backend.Hash.testKeyBackend of Just a -> a ks nullMeterUpdate Nothing -> giveup "failed to generate random key (backend problem)" _ <- moveAnnex k f return k getReadonlyKey :: Remote -> FilePath -> Annex Key -getReadonlyKey r f = lookupFile (toRawFilePath f) >>= \case +getReadonlyKey r f = lookupKey (toRawFilePath f) >>= \case Nothing -> giveup $ f ++ " is not an annexed file" Just k -> do unlessM (inAnnex k) $ diff --git a/Command/TransferKeys.hs b/Command/TransferKeys.hs --- a/Command/TransferKeys.hs +++ b/Command/TransferKeys.hs @@ -30,7 +30,7 @@ start :: CommandStart start = do - enableInteractiveJournalAccess + enableInteractiveBranchAccess (readh, writeh) <- liftIO dupIoHandles runRequests readh writeh runner stop diff --git a/Command/Unannex.hs b/Command/Unannex.hs --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -9,7 +9,6 @@ import Command import qualified Annex -import Annex.Content import Annex.Perms import qualified Git.Command import Utility.CopyFile @@ -23,13 +22,19 @@ paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = (withFilesInGit ww $ commandAction . whenAnnexed start) - =<< workTreeItems ww ps +seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles +seeker :: AnnexedFileSeeker +seeker = AnnexedFileSeeker + { seekAction = commandAction' start + , checkContentPresent = Just True + , usesLocationLog = False + } + start :: RawFilePath -> Key -> CommandStart -start file key = stopUnless (inAnnex key) $ +start file key = starting "unannex" (mkActionItem (key, file)) $ perform file key diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -44,7 +44,7 @@ l <- workTreeItems ww ps withFilesNotInGit (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l Annex.changeState $ \s -> s { Annex.fast = True } - withFilesInGit ww (commandAction . whenAnnexed Command.Unannex.start) l + withFilesInGitAnnex ww Command.Unannex.seeker l finish where ww = WarnUnmatchLsFiles diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -27,10 +27,14 @@ command n SectionCommon d paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = withFilesInGit ww (commandAction . whenAnnexed start) - =<< workTreeItems ww ps +seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles + seeker = AnnexedFileSeeker + { seekAction = commandAction' start + , checkContentPresent = Nothing + , usesLocationLog = False + } start :: RawFilePath -> Key -> CommandStart start file key = ifM (isJust <$> isAnnexLink file) diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -215,7 +215,7 @@ Just dir -> inRepo $ LsFiles.inRepo [] [toRawFilePath dir] go v [] = return v go v (f:fs) = do - mk <- lookupFile f + mk <- lookupKey f case mk of Nothing -> go v fs Just k -> do diff --git a/Command/Vicfg.hs b/Command/Vicfg.hs --- a/Command/Vicfg.hs +++ b/Command/Vicfg.hs @@ -31,7 +31,7 @@ import Types.ScheduledActivity import Types.NumCopies import Remote -import Git.Types (ConfigKey(..), fromConfigKey, fromConfigValue) +import Git.Types (fromConfigKey, fromConfigValue) cmd :: Command cmd = command "vicfg" SectionSetup "edit configuration in git-annex branch" diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -51,13 +51,19 @@ seek :: WhereisOptions -> CommandSeek seek o = do m <- remoteMap id - let go = whenAnnexed $ start o m + let go = start o m case batchOption o of - Batch fmt -> batchFilesMatching fmt (go . toRawFilePath) - NoBatch -> + Batch fmt -> batchFilesMatching fmt + (whenAnnexed go . toRawFilePath) + NoBatch -> do + let seeker = AnnexedFileSeeker + { seekAction = commandAction' go + , checkContentPresent = Nothing + , usesLocationLog = True + } withKeyOptions (keyOptions o) False (commandAction . startKeys o m) - (withFilesInGit ww (commandAction . go)) + (withFilesInGitAnnex ww seeker) =<< workTreeItems ww (whereisFiles o) where ww = WarnUnmatchLsFiles diff --git a/Config.hs b/Config.hs --- a/Config.hs +++ b/Config.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Config ( module Config, @@ -83,3 +84,13 @@ setCrippledFileSystem :: Bool -> Annex () setCrippledFileSystem b = setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b) + +pidLockFile :: Annex (Maybe FilePath) +#ifndef mingw32_HOST_OS +pidLockFile = ifM (annexPidLock <$> Annex.getGitConfig) + ( Just <$> Annex.fromRepo gitAnnexPidLockFile + , pure Nothing + ) +#else +pidLockFile = pure Nothing +#endif diff --git a/Creds.hs b/Creds.hs --- a/Creds.hs +++ b/Creds.hs @@ -29,7 +29,6 @@ import Annex.Perms import Utility.FileMode import Crypto -import Types.Remote (RemoteConfig, RemoteConfigField) import Types.ProposedAccepted import Remote.Helper.Encryptable (remoteCipher, remoteCipher', embedCreds, EncryptionIsSetup, extractCipher) import Utility.Env (getEnv) diff --git a/Database/Init.hs b/Database/Init.hs --- a/Database/Init.hs +++ b/Database/Init.hs @@ -12,7 +12,6 @@ import Utility.FileMode import Database.Persist.Sqlite -import Control.Monad.IO.Class (liftIO) import qualified Data.Text as T import Lens.Micro diff --git a/Git/CatFile.hs b/Git/CatFile.hs --- a/Git/CatFile.hs +++ b/Git/CatFile.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} module Git.CatFile ( CatFileHandle, @@ -19,6 +20,9 @@ catObject, catObjectDetails, catObjectMetaData, + catObjectStreamLsTree, + catObjectStream, + catObjectMetaDataStream, ) where import System.IO @@ -27,12 +31,15 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.Attoparsec.ByteString as A import qualified Data.Attoparsec.ByteString.Char8 as A8 -import qualified Data.Map as M +import qualified Data.Map.Strict as M import Data.String import Data.Char import Numeric import System.Posix.Types import Text.Read +import Control.Concurrent.Async +import Control.Concurrent.Chan +import Control.Monad.IO.Class (MonadIO) import Common import Git @@ -40,9 +47,10 @@ import qualified Git.Ref import Git.Command import Git.Types -import Git.FilePath import Git.HashObject +import qualified Git.LsTree as LsTree import qualified Utility.CoProcess as CoProcess +import qualified Git.BuildVersion as BuildVersion import Utility.Tuple data CatFileHandle = CatFileHandle @@ -57,7 +65,7 @@ catFileStart' :: Bool -> Repo -> IO CatFileHandle catFileStart' restartable repo = CatFileHandle <$> startp "--batch" - <*> startp "--batch-check=%(objectname) %(objecttype) %(objectsize)" + <*> startp ("--batch-check=" ++ batchFormat) <*> pure repo where startp p = gitCoProcessStart restartable @@ -65,6 +73,9 @@ , Param p ] repo +batchFormat :: String +batchFormat = "%(objectname) %(objecttype) %(objectsize)" + catFileStop :: CatFileHandle -> IO () catFileStop h = do CoProcess.stop (catFileProcess h) @@ -72,12 +83,12 @@ {- Reads a file from a specified branch. -} catFile :: CatFileHandle -> Branch -> RawFilePath -> IO L.ByteString -catFile h branch file = catObject h $ Ref $ - fromRef' branch <> ":" <> toInternalGitPath file +catFile h branch file = catObject h $ + Git.Ref.branchFileRef branch file catFileDetails :: CatFileHandle -> Branch -> RawFilePath -> IO (Maybe (L.ByteString, Sha, ObjectType)) -catFileDetails h branch file = catObjectDetails h $ Ref $ - fromRef' branch <> ":" <> toInternalGitPath file +catFileDetails h branch file = catObjectDetails h $ + Git.Ref.branchFileRef branch file {- Uses a running git cat-file read the content of an object. - Objects that do not exist will have "" returned. -} @@ -88,18 +99,12 @@ catObjectDetails h object = query (catFileProcess h) object newlinefallback $ \from -> do header <- S8.hGetLine from case parseResp object header of - Just (ParsedResp sha objtype size) -> do - content <- S.hGet from (fromIntegral size) - eatchar '\n' from - return $ Just (L.fromChunks [content], sha, objtype) + Just r@(ParsedResp sha objtype _size) -> do + content <- readObjectContent from r + return $ Just (content, sha, objtype) Just DNE -> return Nothing Nothing -> error $ "unknown response from git cat-file " ++ show (header, object) where - eatchar expected from = do - c <- hGetChar from - when (c /= expected) $ - error $ "missing " ++ (show expected) ++ " from git cat-file" - -- Slow fallback path for filenames containing newlines. newlinefallback = queryObjectType object (gitRepo h) >>= \case Nothing -> return Nothing @@ -113,6 +118,18 @@ (gitRepo h) return (Just (content, sha, objtype)) +readObjectContent :: Handle -> ParsedResp -> IO L.ByteString +readObjectContent h (ParsedResp _ _ size) = do + content <- S.hGet h (fromIntegral size) + eatchar '\n' + return (L.fromChunks [content]) + where + eatchar expected = do + c <- hGetChar h + when (c /= expected) $ + error $ "missing " ++ (show expected) ++ " from git cat-file" +readObjectContent _ DNE = error "internal" + {- Gets the size and type of an object, without reading its content. -} catObjectMetaData :: CatFileHandle -> Ref -> IO (Maybe (Sha, FileSize, ObjectType)) catObjectMetaData h object = query (checkFileProcess h) object newlinefallback $ \from -> do @@ -266,3 +283,123 @@ sp = fromIntegral (ord ' ') lt = fromIntegral (ord '<') gt = fromIntegral (ord '>') + +{- Uses cat-file to stream the contents of the files as efficiently + - as possible. This is much faster than querying it repeatedly per file. + -} +catObjectStreamLsTree + :: (MonadMask m, MonadIO m) + => [LsTree.TreeItem] + -> (LsTree.TreeItem -> Maybe v) + -> Repo + -> (IO (Maybe (v, Maybe L.ByteString)) -> m a) + -> m a +catObjectStreamLsTree l want repo reader = withCatFileStream False repo $ + \c hin hout -> bracketIO + (async $ feeder c hin) + cancel + (const (reader (catObjectReader readObjectContent c hout))) + where + feeder c h = do + forM_ l $ \ti -> case want ti of + Nothing -> return () + Just v -> do + let sha = LsTree.sha ti + liftIO $ writeChan c (sha, v) + S8.hPutStrLn h (fromRef' sha) + hClose h + +catObjectStream + :: (MonadMask m, MonadIO m) + => Repo + -> ( + ((v, Ref) -> IO ()) -- ^ call to feed values in + -> IO () -- call once all values are fed in + -> IO (Maybe (v, Maybe L.ByteString)) -- call to read results + -> m a + ) + -> m a +catObjectStream repo a = withCatFileStream False repo go + where + go c hin hout = a + (feeder c hin) + (hClose hin) + (catObjectReader readObjectContent c hout) + feeder c h (v, ref) = do + liftIO $ writeChan c (ref, v) + S8.hPutStrLn h (fromRef' ref) + +catObjectMetaDataStream + :: (MonadMask m, MonadIO m) + => Repo + -> ( + ((v, Ref) -> IO ()) -- ^ call to feed values in + -> IO () -- call once all values are fed in + -> IO (Maybe (v, Maybe (Sha, FileSize, ObjectType))) -- call to read results + -> m a + ) + -> m a +catObjectMetaDataStream repo a = withCatFileStream True repo go + where + go c hin hout = a + (feeder c hin) + (hClose hin) + (catObjectReader (\_h r -> pure (conv r)) c hout) + + feeder c h (v, ref) = do + liftIO $ writeChan c (ref, v) + S8.hPutStrLn h (fromRef' ref) + + conv (ParsedResp sha ty sz) = (sha, sz, ty) + conv DNE = error "internal" + +catObjectReader + :: (Handle -> ParsedResp -> IO t) + -> Chan (Ref, a) + -> Handle + -> IO (Maybe (a, Maybe t)) +catObjectReader getv c h = ifM (hIsEOF h) + ( return Nothing + , do + (ref, f) <- liftIO $ readChan c + resp <- S8.hGetLine h + case parseResp ref resp of + Just r@(ParsedResp {}) -> do + v <- getv h r + return (Just (f, Just v)) + Just DNE -> return (Just (f, Nothing)) + Nothing -> error $ "unknown response from git cat-file " ++ show resp + ) + +withCatFileStream + :: (MonadMask m, MonadIO m) + => Bool + -> Repo + -> (Chan v -> Handle -> Handle -> m a) + -> m a +withCatFileStream check repo reader = assertLocal repo $ + bracketIO start stop $ \(c, hin, hout, _) -> reader c hin hout + where + params = catMaybes + [ Just $ Param "cat-file" + , Just $ Param ("--batch" ++ (if check then "-check" else "") ++ "=" ++ batchFormat) + -- This option makes it faster, but is not present in + -- older versions of git. + , if BuildVersion.older "2.4.3" + then Nothing + else Just $ Param "--buffer" + ] + + start = do + let p = gitCreateProcess params repo + (Just hin, Just hout, _, pid) <- createProcess p + { std_in = CreatePipe + , std_out = CreatePipe + } + c <- newChan + return (c, hin, hout, pid) + + stop (_, hin, hout, pid) = do + hClose hin + hClose hout + void $ checkSuccessProcess pid diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -206,7 +206,7 @@ {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - - output and any standard output of the command. -} + - output and standard error of the command. -} fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, S.ByteString)) fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go where diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -8,6 +8,7 @@ module Git.LsFiles ( Options(..), inRepo, + inRepoDetails, inRepoOrBranch, notInRepo, notInRepoIncludingEmptyDirectories, @@ -16,6 +17,8 @@ modified, staged, stagedNotDeleted, + usualStageNum, + mergeConflictHeadStageNum, stagedDetails, typeChanged, typeChangedStaged, @@ -33,12 +36,13 @@ import Git.Sha import Utility.InodeCache import Utility.TimeStamp +import Utility.Attoparsec -import Numeric -import Data.Char import System.Posix.Types import qualified Data.Map as M import qualified Data.ByteString as S +import qualified Data.Attoparsec.ByteString as A +import qualified Data.Attoparsec.ByteString.Char8 as A8 {- It's only safe to use git ls-files on the current repo, not on a remote. - @@ -64,6 +68,9 @@ data Options = ErrorUnmatch +opParam :: Options -> CommandParam +opParam ErrorUnmatch = Param "--error-unmatch" + {- Lists files that are checked into git's index at the specified paths. - With no paths, all files are listed. -} @@ -76,10 +83,19 @@ params = Param "ls-files" : Param "-z" : - map op os ++ ps ++ + map opParam os ++ ps ++ (Param "--" : map (File . fromRawFilePath) l) - op ErrorUnmatch = Param "--error-unmatch" +{- Lists the same files inRepo does, but with sha and mode. -} +inRepoDetails :: [Options] -> [RawFilePath] -> Repo -> IO ([(RawFilePath, Sha, FileMode)], IO Bool) +inRepoDetails = stagedDetails' parser . map opParam + where + parser s = case parseStagedDetails s of + Just (file, sha, mode, stagenum) + | stagenum == usualStageNum || stagenum == mergeConflictHeadStageNum -> + Just (file, sha, mode) + _ -> Nothing + {- Files that are checked into the index or have been committed to a - branch. -} inRepoOrBranch :: Branch -> [Options] -> [RawFilePath] -> Repo -> IO ([RawFilePath], IO Bool) @@ -136,31 +152,49 @@ prefix = [Param "diff", Param "--cached", Param "--name-only", Param "-z"] suffix = Param "--" : map (File . fromRawFilePath) l -type StagedDetails = (RawFilePath, Maybe Sha, Maybe FileMode) +type StagedDetails = (RawFilePath, Sha, FileMode, StageNum) -{- Returns details about all files that are staged in the index. -} +type StageNum = Int + +{- Used when not in a merge conflict. -} +usualStageNum :: Int +usualStageNum = 0 + +{- WHen in a merge conflict, git uses stage number 2 for the local HEAD + - side of the merge conflict. -} +mergeConflictHeadStageNum :: Int +mergeConflictHeadStageNum = 2 + +{- Returns details about all files that are staged in the index. + - + - Note that, during a conflict, a file will appear in the list + - more than once with different stage numbers. + -} stagedDetails :: [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedDetails = stagedDetails' [] +stagedDetails = stagedDetails' parseStagedDetails [] -{- Gets details about staged files, including the Sha of their staged - - contents. -} -stagedDetails' :: [CommandParam] -> [RawFilePath] -> Repo -> IO ([StagedDetails], IO Bool) -stagedDetails' ps l repo = guardSafeForLsFiles repo $ do +stagedDetails' :: (S.ByteString -> Maybe t) -> [CommandParam] -> [RawFilePath] -> Repo -> IO ([t], IO Bool) +stagedDetails' parser ps l repo = guardSafeForLsFiles repo $ do (ls, cleanup) <- pipeNullSplit' params repo - return (map parseStagedDetails ls, cleanup) + return (mapMaybe parser ls, cleanup) where params = Param "ls-files" : Param "--stage" : Param "-z" : ps ++ Param "--" : map (File . fromRawFilePath) l -parseStagedDetails :: S.ByteString -> StagedDetails -parseStagedDetails s - | S.null file = (s, Nothing, Nothing) - | otherwise = (file, extractSha sha, readmode mode) +parseStagedDetails :: S.ByteString -> Maybe StagedDetails +parseStagedDetails = eitherToMaybe . A.parseOnly parser where - (metadata, file) = separate' (== fromIntegral (ord '\t')) s - (mode, metadata') = separate' (== fromIntegral (ord ' ')) metadata - (sha, _) = separate' (== fromIntegral (ord ' ')) metadata' - readmode = fst <$$> headMaybe . readOct . decodeBS' + parser = do + mode <- octal + void $ A8.char ' ' + sha <- maybe (fail "bad sha") return . extractSha =<< nextword + void $ A8.char ' ' + stagenum <- A8.decimal + void $ A8.char '\t' + file <- A.takeByteString + return (file, sha, mode, stagenum) + + nextword = A8.takeTill (== ' ') {- Returns a list of the files in the specified locations that are staged - for commit, and whose type has changed. -} diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -1,6 +1,6 @@ {- git ref stuff - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -14,6 +14,7 @@ import Git.Command import Git.Sha import Git.Types +import Git.FilePath import Data.Char (chr, ord) import qualified Data.ByteString as S @@ -68,7 +69,11 @@ - of a repo. -} fileRef :: RawFilePath -> Ref -fileRef f = Ref $ ":./" <> f +fileRef f = Ref $ ":./" <> toInternalGitPath f + +{- A Ref that can be used to refer to a file in a particular branch. -} +branchFileRef :: Branch -> RawFilePath -> Ref +branchFileRef branch f = Ref $ fromRef' branch <> ":" <> toInternalGitPath f {- Converts a Ref to refer to the content of the Ref on a given date. -} dateRef :: Ref -> RefDate -> Ref diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -38,7 +38,6 @@ import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode -import Utility.Tuple import qualified Data.Set as S import qualified Data.ByteString.Lazy as L @@ -379,9 +378,8 @@ partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) partitionIndex r = do (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r - l <- forM indexcontents $ \i -> case i of - (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i - _ -> pure (False, i) + l <- forM indexcontents $ \i@(_file, sha, _mode, _stagenum) -> + (,) <$> isMissing sha r <*> pure i let (bad, good) = partition fst l return (map snd bad, map snd good, cleanup) @@ -397,13 +395,12 @@ UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map (fromRawFilePath . fst3) bad + return $ map (\(file,_, _, _) -> fromRawFilePath file) bad where - reinject (file, Just sha, Just mode) = case toTreeItemType mode of + reinject (file, sha, mode, _) = case toTreeItemType mode of Nothing -> return Nothing Just treeitemtype -> Just <$> UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r - reinject _ = return Nothing newtype GoodCommits = GoodCommits (S.Set Sha) diff --git a/Key.hs b/Key.hs --- a/Key.hs +++ b/Key.hs @@ -5,6 +5,7 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Key ( @@ -22,6 +23,8 @@ nonChunkKey, chunkKeyOffset, isChunkKey, + gitShaKey, + keyGitSha, isKeyPrefix, splitKeyNameExtension, @@ -35,6 +38,7 @@ import Common import Types.Key +import Git.Types import Utility.QuickCheck import Utility.Bloom import Utility.Aeson @@ -57,6 +61,23 @@ isChunkKey :: Key -> Bool isChunkKey k = isJust (fromKey keyChunkSize k) && isJust (fromKey keyChunkNum k) + +-- Encodes a git sha as a key. +-- +-- This is not the same as a SHA1 key, because the mapping needs to be +-- bijective, also because git may not always use SHA1. +gitShaKey :: Sha -> Key +gitShaKey (Ref s) = mkKey $ \kd -> kd + { keyName = s + , keyVariety = OtherKey "GIT" + } + +-- Reverse of gitShaKey +keyGitSha :: Key -> Maybe Sha +keyGitSha k + | fromKey keyVariety k == OtherKey "GIT" = + Just (Ref (fromKey keyName k)) + | otherwise = Nothing serializeKey :: Key -> String serializeKey = decodeBS' . serializeKey' diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -34,6 +34,7 @@ import Utility.HumanTime import Utility.DataUnits import qualified Utility.RawFilePath as R +import Backend import Data.Time.Clock.POSIX import qualified Data.Set as S @@ -305,7 +306,7 @@ addSecureHash = addLimit $ Right limitSecureHash limitSecureHash :: MatchFiles Annex -limitSecureHash _ = checkKey $ pure . cryptographicallySecure . fromKey keyVariety +limitSecureHash _ = checkKey $ pure . isCryptographicallySecure {- Adds a limit to skip files that are too large or too small -} addLargerThan :: String -> Annex () @@ -372,7 +373,7 @@ secs = fromIntegral (durationSeconds duration) lookupFileKey :: FileInfo -> Annex (Maybe Key) -lookupFileKey = lookupFile . currFile +lookupFileKey = lookupKey . currFile checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a diff --git a/Logs.hs b/Logs.hs --- a/Logs.hs +++ b/Logs.hs @@ -38,6 +38,26 @@ | isMetaDataLog f || f `elem` otherLogs = Just OtherLog | otherwise = PresenceLog <$> firstJust (presenceLogs config f) +{- Typical number of log files that may be read while processing a single + - key. This is used to size a cache. + - + - The location log is generally read, and the metadata log is read when + - matching a preferred content expression that matches on metadata, + - or when using metadata options. + - + - When using a remote, the url log, chunk log, remote state log, remote + - metadata log, and remote content identifier log might each be used, + - but probably at most 3 out of the 6. However, caching too much slows + - down all operations because the cache is a linear list, so the cache + - is not currently sized to include these. + - + - The result is that when seeking for files to operate on, + - the location log will stay in the cache if the metadata log is also + - read. + -} +logFilesToCache :: Int +logFilesToCache = 2 + {- All the old-format uuid-based logs stored in the top of the git-annex branch. -} topLevelOldUUIDBasedLogs :: [RawFilePath] topLevelOldUUIDBasedLogs = @@ -59,7 +79,6 @@ [ exportLog ] - {- All the ways to get a key from a presence log file -} presenceLogs :: GitConfig -> RawFilePath -> [Maybe Key] presenceLogs config f = @@ -205,11 +224,11 @@ {- From an extension and a log filename, get the key that it's a log for. -} extLogFileKey :: S.ByteString -> RawFilePath -> Maybe Key extLogFileKey expectedext path - | encodeBS' ext == expectedext = fileKey (toRawFilePath base) + | ext == expectedext = fileKey base | otherwise = Nothing where - file = takeFileName (fromRawFilePath path) - (base, ext) = splitAt (length file - extlen) file + file = P.takeFileName path + (base, ext) = S.splitAt (S.length file - extlen) file extlen = S.length expectedext {- Converts a url log file into a key. diff --git a/Logs/MetaData.hs b/Logs/MetaData.hs --- a/Logs/MetaData.hs +++ b/Logs/MetaData.hs @@ -19,13 +19,14 @@ - after the other remote redundantly set foo +x, it was unset, - and so foo currently has no value. - - - Copyright 2014-2019 Joey Hess + - Copyright 2014-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Logs.MetaData ( getCurrentMetaData, + parseCurrentMetaData, getCurrentRemoteMetaData, addMetaData, addRemoteMetaData, @@ -47,6 +48,7 @@ import qualified Data.Set as S import qualified Data.Map as M +import qualified Data.ByteString.Lazy as L {- Go through the log from oldest to newest, and combine it all - into a single MetaData representing the current state. @@ -60,9 +62,13 @@ getCurrentMetaData' :: (GitConfig -> Key -> RawFilePath) -> Key -> Annex MetaData getCurrentMetaData' getlogfile k = do config <- Annex.getGitConfig - ls <- S.toAscList <$> readLog (getlogfile config k) - let loggedmeta = logToCurrentMetaData ls - return $ currentMetaData $ unionMetaData loggedmeta + parseCurrentMetaData <$> Annex.Branch.get (getlogfile config k) + +parseCurrentMetaData :: L.ByteString -> MetaData +parseCurrentMetaData content = + let ls = S.toAscList $ parseLog content + loggedmeta = logToCurrentMetaData ls + in currentMetaData $ unionMetaData loggedmeta (lastchanged ls loggedmeta) where lastchanged [] _ = emptyMetaData diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -1,17 +1,19 @@ {- Web url logs. - - - Copyright 2011-2014 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE BangPatterns #-} + module Logs.Web ( URLString, getUrls, getUrlsWithPrefix, setUrlPresent, setUrlMissing, - knownUrls, + withKnownUrls, Downloader(..), getDownloader, setDownloader, @@ -28,9 +30,9 @@ import Logs.Presence import Logs.Location import qualified Annex.Branch -import Annex.CatFile -import qualified Git -import qualified Git.LsFiles +import qualified Git.LsTree +import Git.CatFile (catObjectStreamLsTree) +import Git.FilePath import Utility.Url import Annex.UUID import qualified Types.Remote as Remote @@ -85,27 +87,29 @@ _ -> True {- Finds all known urls. -} -knownUrls :: Annex [(Key, URLString)] -knownUrls = do - {- Ensure the git-annex branch's index file is up-to-date and - - any journaled changes are reflected in it, since we're going - - to query its index directly. -} +withKnownUrls :: (Annex (Maybe (Key, [URLString])) -> Annex a) -> Annex a +withKnownUrls a = do + {- Ensure any journalled changes are committed to the git-annex + - branch, since we're going to look at its tree. -} _ <- Annex.Branch.update Annex.Branch.commit =<< Annex.Branch.commitMessage - Annex.Branch.withIndex $ do - top <- fromRepo Git.repoPath - (l, cleanup) <- inRepo $ Git.LsFiles.stagedDetails [top] - r <- mapM getkeyurls l - void $ liftIO cleanup - return $ concat r + (l, cleanup) <- inRepo $ Git.LsTree.lsTree + Git.LsTree.LsTreeRecursive + Annex.Branch.fullname + g <- Annex.gitRepo + let want = urlLogFileKey . getTopFilePath . Git.LsTree.file + catObjectStreamLsTree l want g (\reader -> a (go reader)) + `finally` void (liftIO cleanup) where - getkeyurls (f, s, _) = case urlLogFileKey f of - Just k -> zip (repeat k) <$> geturls s - Nothing -> return [] - geturls Nothing = return [] - geturls (Just logsha) = - map (decodeBS . fromLogInfo) . getLog - <$> catObject logsha + go reader = liftIO reader >>= \case + Just (k, Just content) -> + case geturls content of + [] -> go reader + us -> return (Just (k, us)) + Just (_, Nothing) -> go reader + Nothing -> return Nothing + + geturls = map (decodeBS . fromLogInfo) . getLog setTempUrl :: Key -> URLString -> Annex () setTempUrl key url = Annex.changeState $ \s -> diff --git a/P2P/Annex.hs b/P2P/Annex.hs --- a/P2P/Annex.hs +++ b/P2P/Annex.hs @@ -22,7 +22,6 @@ import P2P.IO import Logs.Location import Types.NumCopies -import Types.Remote (RetrievalSecurityPolicy(..)) import Utility.Metered import Control.Monad.Free diff --git a/P2P/IO.hs b/P2P/IO.hs --- a/P2P/IO.hs +++ b/P2P/IO.hs @@ -40,7 +40,6 @@ import Control.Monad.Free import Control.Monad.IO.Class -import System.Exit (ExitCode(..)) import System.IO.Error import Network.Socket import Control.Concurrent diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -52,6 +52,7 @@ nameToUUID, nameToUUID', showTriedRemotes, + listRemoteNames, showLocations, forceTrust, logStatus, @@ -365,8 +366,11 @@ showTriedRemotes :: [Remote] -> Annex () showTriedRemotes [] = noop showTriedRemotes remotes = - showLongNote $ "Unable to access these remotes: " ++ - intercalate ", " (map name remotes) + showLongNote $ "Unable to access these remotes: " + ++ listRemoteNames remotes + +listRemoteNames :: [Remote] -> String +listRemoteNames remotes = intercalate ", " (map name remotes) forceTrust :: TrustLevel -> String -> Annex () forceTrust level remotename = do diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -81,6 +81,7 @@ } , importActions = ImportActions { listImportableContents = listImportableContentsM serial adir + , importKey = Nothing , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM serial adir , storeExportWithContentIdentifier = storeExportWithContentIdentifierM serial adir , removeExportWithContentIdentifier = removeExportWithContentIdentifierM serial adir diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -32,6 +32,8 @@ import qualified Remote.Directory.LegacyChunked as Legacy import Annex.Content import Annex.UUID +import Backend +import Types.KeySource import Utility.Metered import Utility.Tmp import Utility.InodeCache @@ -88,6 +90,7 @@ } , importActions = ImportActions { listImportableContents = listImportableContentsM dir + , importKey = Just (importKeyM dir) , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierM dir , storeExportWithContentIdentifier = storeExportWithContentIdentifierM dir , removeExportWithContentIdentifier = removeExportWithContentIdentifierM dir @@ -342,6 +345,26 @@ fmap (ContentIdentifier . encodeBS . showInodeCache) <$> toInodeCache noTSDelta f st +guardSameContentIdentifiers :: a -> ContentIdentifier -> Maybe ContentIdentifier -> a +guardSameContentIdentifiers cont old new + | new == Just old = cont + | otherwise = giveup "file content has changed" + +importKeyM :: FilePath -> ExportLocation -> ContentIdentifier -> MeterUpdate -> Annex Key +importKeyM dir loc cid p = do + backend <- chooseBackend (fromRawFilePath f) + k <- fst <$> genKey ks p backend + currcid <- liftIO $ mkContentIdentifier absf =<< getFileStatus absf + guardSameContentIdentifiers (return k) cid currcid + where + f = fromExportLocation loc + absf = dir fromRawFilePath f + ks = KeySource + { keyFilename = f + , contentLocation = toRawFilePath absf + , inodeCache = Nothing + } + retrieveExportWithContentIdentifierM :: FilePath -> ExportLocation -> ContentIdentifier -> FilePath -> Annex Key -> MeterUpdate -> Annex Key retrieveExportWithContentIdentifierM dir loc cid dest mkkey p = precheck $ docopy postcheck @@ -364,7 +387,7 @@ #else let open = openBinaryFile f ReadMode let close = hClose - bracketIO setup close $ \h -> do + bracketIO open close $ \h -> do #endif liftIO $ hGetContentsMetered h p >>= L.writeFile dest k <- mkkey @@ -376,7 +399,7 @@ -- Check before copy, to avoid expensive copy of wrong file -- content. - precheck cont = comparecid cont + precheck cont = guardSameContentIdentifiers cont cid =<< liftIO . mkContentIdentifier f =<< liftIO (getFileStatus f) @@ -404,11 +427,7 @@ #else =<< getFileStatus f #endif - comparecid cont currcid - - comparecid cont currcid - | currcid == Just cid = cont - | otherwise = giveup "file content has changed" + guardSameContentIdentifiers cont cid currcid storeExportWithContentIdentifierM :: FilePath -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierM dir src _k loc overwritablecids p = do diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -632,8 +632,8 @@ `onException` liftIO forcestop copyFromRemoteCheap :: Remote -> State -> Git.Repo -> Maybe (Key -> AssociatedFile -> FilePath -> Annex ()) -copyFromRemoteCheap r st repo #ifndef mingw32_HOST_OS +copyFromRemoteCheap r st repo | not $ Git.repoIsUrl repo = Just $ \key _af file -> guardUsable repo (giveup "cannot access remote") $ do gc <- getGitConfigFromState st loc <- liftIO $ gitAnnexLocation key repo gc @@ -650,7 +650,7 @@ ) | otherwise = Nothing #else -copyFromRemoteCheap' _ _ _ = Nothing +copyFromRemoteCheap _ _ _ = Nothing #endif {- Tries to copy a key's content to a remote's annex. -} diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -6,6 +6,7 @@ -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Remote.GitLFS (remote, gen, configKnownUrl) where @@ -15,8 +16,8 @@ import Types.Key import Types.Creds import Types.ProposedAccepted +import Types.NumCopies import qualified Annex -import qualified Annex.SpecialRemote.Config import qualified Git import qualified Git.Types as Git import qualified Git.Url @@ -40,9 +41,14 @@ import Utility.Url import Logs.Remote import Logs.RemoteState -import qualified Utility.GitLFS as LFS import qualified Git.Config +#ifdef WITH_GIT_LFS +import qualified Network.GitLFS as LFS +#else +import qualified Utility.GitLFS as LFS +#endif + import Control.Concurrent.STM import Data.String import Network.HTTP.Types @@ -95,9 +101,9 @@ (retrieve rs h) (remove h) (checkKey rs h) - (this c cst) + (this c cst h) where - this c cst = Remote + this c cst h = Remote { uuid = u , cost = cst , name = Git.repoDescribe r @@ -109,7 +115,7 @@ -- is checked on download , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy - , lockContent = Nothing + , lockContent = Just $ lockKey (this c cst h) rs h , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = exportUnsupported @@ -127,7 +133,7 @@ -- content cannot be removed from a git-lfs repo , appendonly = True , mkUnavailable = return Nothing - , getInfo = gitRepoInfo (this c cst) + , getInfo = gitRepoInfo (this c cst h) , claimUrl = Nothing , checkUrl = Nothing , remoteStateHandle = rs @@ -487,6 +493,16 @@ Just req -> do uo <- getUrlOptions liftIO $ downloadConduit p req dest uo + +-- Since git-lfs does not support removing content, nothing needs to be +-- done to lock content in the remote, except for checking that the content +-- is actually present. +lockKey :: Remote -> RemoteStateHandle -> TVar LFSHandle -> Key -> (VerifiedCopy -> Annex a) -> Annex a +lockKey r rs h key callback = + ifM (checkKey rs h key) + ( withVerifiedCopy LockedCopy (uuid r) (return True) callback + , giveup $ "content seems to be missing from " ++ name r + ) checkKey :: RemoteStateHandle -> TVar LFSHandle -> CheckPresent checkKey rs h key = getLFSEndpoint LFS.RequestDownload h >>= \case diff --git a/Remote/Helper/ExportImport.hs b/Remote/Helper/ExportImport.hs --- a/Remote/Helper/ExportImport.hs +++ b/Remote/Helper/ExportImport.hs @@ -56,6 +56,7 @@ instance HasImportUnsupported (ImportActions Annex) where importUnsupported = ImportActions { listImportableContents = return Nothing + , importKey = Nothing , retrieveExportWithContentIdentifier = nope , storeExportWithContentIdentifier = nope , removeExportWithContentIdentifier = nope diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -58,6 +58,7 @@ import Logs.MetaData import Types.MetaData import Types.ProposedAccepted +import Types.NumCopies import Utility.Metered import Utility.DataUnits import Annex.Content @@ -199,7 +200,7 @@ -- secure. , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = removeKeyDummy - , lockContent = Nothing + , lockContent = lockContentS3 hdl this rs c info , checkPresent = checkPresentDummy , checkPresentCheap = False , exportActions = ExportActions @@ -213,6 +214,7 @@ } , importActions = ImportActions { listImportableContents = listImportableContentsS3 hdl this info + , importKey = Nothing , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierS3 hdl this rs info , storeExportWithContentIdentifier = storeExportWithContentIdentifierS3 hdl this rs info magic , removeExportWithContentIdentifier = removeExportWithContentIdentifierS3 hdl this rs info @@ -426,6 +428,19 @@ S3.DeleteObjectResponse <- liftIO $ runResourceT $ sendS3Handle h $ S3.DeleteObject (T.pack $ bucketObject info k) (bucket info) return () + +lockContentS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Maybe (Key -> (VerifiedCopy -> Annex a) -> Annex a) +lockContentS3 hv r rs c info + -- When versioning is enabled, content is never removed from the + -- remote, so nothing needs to be done to lock the content there, + -- beyond a sanity check that the content is in fact present. + | versioning info = Just $ \k callback -> do + checkVersioning info rs k + ifM (checkKey hv r rs c info k) + ( withVerifiedCopy LockedCopy (uuid r) (return True) callback + , giveup $ "content seems to be missing from " ++ name r ++ " despite S3 versioning being enabled" + ) + | otherwise = Nothing checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent checkKey hv r rs c info k = withS3Handle hv $ \case diff --git a/Remote/Tahoe.hs b/Remote/Tahoe.hs --- a/Remote/Tahoe.hs +++ b/Remote/Tahoe.hs @@ -13,7 +13,7 @@ - - Tahoe has its own encryption, so git-annex's encryption is not used. - - - Copyright 2014-2019 Joey Hess + - Copyright 2014-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -31,6 +31,7 @@ import Types.Remote import Types.Creds import Types.ProposedAccepted +import Types.NumCopies import qualified Git import Config import Config.Cost @@ -91,7 +92,7 @@ -- Tahoe cryptographically verifies content. , retrievalSecurityPolicy = RetrievalAllKeysSecure , removeKey = remove - , lockContent = Nothing + , lockContent = Just $ lockKey u rs hdl , checkPresent = checkKey rs hdl , checkPresentCheap = False , exportActions = exportUnsupported @@ -152,6 +153,16 @@ remove :: Key -> Annex () remove _k = giveup "content cannot be removed from tahoe remote" + +-- Since content cannot be removed from tahoe (by git-annex), +-- nothing needs to be done to lock content there, except for checking that +-- it is actually present. +lockKey :: UUID -> RemoteStateHandle -> TahoeHandle -> Key -> (VerifiedCopy -> Annex a) -> Annex a +lockKey u rs hrl k callback = + ifM (checkKey rs hrl k) + ( withVerifiedCopy LockedCopy u (return True) callback + , giveup $ "content seems to be missing from tahoe remote" + ) checkKey :: RemoteStateHandle -> TahoeHandle -> Key -> Annex Bool checkKey rs hdl k = go =<< getCapability rs k diff --git a/RemoteDaemon/Core.hs b/RemoteDaemon/Core.hs --- a/RemoteDaemon/Core.hs +++ b/RemoteDaemon/Core.hs @@ -166,7 +166,7 @@ let h = TransportHandle (LocalRepo g) annexstate liftAnnex h $ do Annex.setOutput QuietOutput - enableInteractiveJournalAccess + enableInteractiveBranchAccess return h updateTransportHandle :: TransportHandle -> IO TransportHandle diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -88,11 +88,11 @@ import qualified Utility.FileSystemEncoding import qualified Utility.Aeson import qualified Utility.CopyFile +import qualified Types.Remote #ifndef mingw32_HOST_OS import qualified Remote.Helper.Encryptable import qualified Types.Crypto import qualified Utility.Gpg -import qualified Types.Remote #endif optParser :: Parser TestOptions @@ -257,22 +257,25 @@ @? "init failed" r <- annexeval $ either error return =<< Remote.byName' remotename + cache <- Command.TestRemote.newRemoteVariantCache unavailr <- annexeval $ Types.Remote.mkUnavailable r - exportr <- annexeval $ Command.TestRemote.exportTreeVariant r + exportr <- annexeval $ Command.TestRemote.exportTreeVariant cache r ks <- annexeval $ mapM Command.TestRemote.randKey keysizes v <- getv + cv <- annexeval cache liftIO $ atomically $ putTMVar v - (r, (unavailr, (exportr, ks))) + (r, (unavailr, (exportr, (ks, cv)))) go getv = Command.TestRemote.mkTestTrees runannex mkrs mkunavailr mkexportr mkks where runannex = inmainrepo . annexeval - mkrs = Command.TestRemote.remoteVariants mkr basesz False + mkrs = Command.TestRemote.remoteVariants cache mkr basesz False mkr = descas (remotetype ++ " remote") (fst <$> v) mkunavailr = fst . snd <$> v mkexportr = fst . snd . snd <$> v mkks = map (\(sz, n) -> desckeysize sz (getk n)) (zip keysizes [0..]) - getk n = fmap (!! n) (snd . snd . snd <$> v) + getk n = fmap (!! n) (fst . snd . snd . snd <$> v) + cache = snd . snd . snd . snd <$> v v = liftIO $ atomically . readTMVar =<< getv descas = Command.TestRemote.Described desckeysize sz = descas ("key size " ++ show sz) @@ -289,6 +292,8 @@ unitTests note = testGroup ("Unit Tests " ++ note) [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras + , testCase "ignore deleted files" test_ignore_deleted_files + , testCase "metadata" test_metadata , testCase "export_import" test_export_import , testCase "export_import_subdir" test_export_import_subdir , testCase "shared clone" test_shared_clone @@ -399,6 +404,33 @@ annexed_present wormannexedfile checkbackend wormannexedfile backendWORM +test_ignore_deleted_files :: Assertion +test_ignore_deleted_files = intmpclonerepo $ do + git_annex "get" [annexedfile] @? "get failed" + git_annex_expectoutput "find" [] [annexedfile] + nukeFile annexedfile + -- A file that has been deleted, but the deletion not staged, + -- is a special case; make sure git-annex skips these. + git_annex_expectoutput "find" [] [] + +test_metadata :: Assertion +test_metadata = intmpclonerepo $ do + git_annex "metadata" ["-s", "foo=bar", annexedfile] @? "set metadata" + git_annex_expectoutput "find" ["--metadata", "foo=bar"] [annexedfile] + git_annex_expectoutput "find" ["--metadata", "foo=other"] [] + writecontent annexedfiledup $ content annexedfiledup + add_annex annexedfiledup @? "add of second file with same content failed" + annexed_present annexedfiledup + git_annex_expectoutput "find" ["--metadata", "foo=bar"] + [annexedfile, annexedfiledup] + git_annex_shouldfail "metadata" ["--remove", "foo", "."] + @? "removing metadata from dir with multiple files failed to fail" + git_annex "metadata" ["--remove", "foo", annexedfile] + @? "removing metadata failed" + git_annex_expectoutput "find" ["--metadata", "foo=bar"] [] + git_annex "metadata" ["--force", "-s", "foo=bar", "."] + @? "recursively set metadata force" + test_shared_clone :: Assertion test_shared_clone = intmpsharedclonerepo $ do v <- catchMaybeIO $ Utility.Process.readProcess "git" @@ -701,7 +733,7 @@ git_annex "get" [annexedfile] @? "get of file failed" git_annex "unlock" [annexedfile] @? "unlock failed" annexeval $ do - Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile) + Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) Database.Keys.removeInodeCaches k Database.Keys.closeDb liftIO . nukeFile =<< Annex.fromRepo Annex.Locations.gitAnnexKeysDbIndexCache @@ -1499,6 +1531,7 @@ withtmpclonerepo $ \r -> whenM (adjustedbranchsupported r) $ do indir r $ do disconnectOrigin + origbranch <- annexeval origBranch git_annex "upgrade" [] @? "upgrade failed" git_annex "adjust" ["--unlock", "--force"] @? "adjust failed" createDirectoryIfMissing True "a/b/c" @@ -1509,7 +1542,7 @@ writecontent "a/b/x/y" "foo" git_annex "add" ["a/b/x"] @? "add a/b/x failed" git_annex "sync" [] @? "sync failed" - boolSystem "git" [Param "checkout", Param "master"] @? "git checkout master failed" + boolSystem "git" [Param "checkout", Param origbranch] @? "git checkout failed" doesFileExist "a/b/x/y" @? ("a/b/x/y missing from master after adjusted branch sync") {- Set up repos as remotes of each other. -} @@ -1676,7 +1709,7 @@ (c,k) <- annexeval $ do uuid <- Remote.nameToUUID "foo" rs <- Logs.Remote.readRemoteLog - Just k <- Annex.WorkTree.lookupFile (toRawFilePath annexedfile) + Just k <- Annex.WorkTree.lookupKey (toRawFilePath annexedfile) return (fromJust $ M.lookup uuid rs, k) let key = if scheme `elem` ["hybrid","pubkey"] then Just $ Utility.Gpg.KeyIds [Utility.Gpg.testKeyId] @@ -1768,19 +1801,20 @@ -- is in sync with the adjusted branch, which it may not be -- depending on how the repository was set up. commitchanges - git_annex "export" ["master", "--to", "foo"] @? "export to dir failed" + origbranch <- annexeval origBranch + git_annex "export" [origbranch, "--to", "foo"] @? "export to dir failed" dircontains annexedfile (content annexedfile) writedir "import" (content "import") - git_annex "import" ["master", "--from", "foo"] @? "import from dir failed" - git_annex "merge" ["foo/master"] @? "git annex merge foo/master failed" + git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed" + git_annex "merge" ["foo/" ++ origbranch] @? "git annex merge failed" annexed_present_imported "import" nukeFile "import" writecontent "import" (content "newimport1") git_annex "add" ["import"] @? "add of import failed" commitchanges - git_annex "export" ["master", "--to", "foo"] @? "export modified file to dir failed" + git_annex "export" [origbranch, "--to", "foo"] @? "export modified file to dir failed" dircontains "import" (content "newimport1") -- verify that export refuses to overwrite modified file @@ -1789,17 +1823,17 @@ writecontent "import" (content "newimport3") git_annex "add" ["import"] @? "add of import failed" commitchanges - git_annex_shouldfail "export" ["master", "--to", "foo"] @? "export failed to fail in conflict" + git_annex_shouldfail "export" [origbranch, "--to", "foo"] @? "export failed to fail in conflict" dircontains "import" (content "newimport2") -- resolving import conflict - git_annex "import" ["master", "--from", "foo"] @? "import from dir failed" + git_annex "import" [origbranch, "--from", "foo"] @? "import from dir failed" not <$> boolSystem "git" [Param "merge", Param "foo/master", Param "-mmerge"] @? "git merge of conflict failed to exit nonzero" nukeFile "import" writecontent "import" (content "newimport3") git_annex "add" ["import"] @? "add of import failed" commitchanges - git_annex "export" ["master", "--to", "foo"] @? "export failed after import conflict" + git_annex "export" [origbranch, "--to", "foo"] @? "export failed after import conflict" dircontains "import" (content "newimport3") where dircontains f v = @@ -1847,11 +1881,13 @@ subannexedfile = "subdir" annexedfile testexport = do - git_annex "export" ["master:"++subdir, "--to", "foo"] @? "export of subdir failed" + origbranch <- annexeval origBranch + git_annex "export" [origbranch++":"++subdir, "--to", "foo"] @? "export of subdir failed" dircontains annexedfile (content annexedfile) testimport = do - git_annex "import" ["master:"++subdir, "--from", "foo"] @? "import of subdir failed" + origbranch <- annexeval origBranch + git_annex "import" [origbranch++":"++subdir, "--from", "foo"] @? "import of subdir failed" git_annex "merge" ["foo/master"] @? "git annex merge foo/master failed" -- Make sure that import did not import the file to the top diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -1,6 +1,6 @@ {- git-annex test suite framework - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -24,6 +24,8 @@ import qualified Git.CurrentRepo import qualified Git.Construct import qualified Git.Types +import qualified Git.Branch +import qualified Git.Ref import qualified Types.KeySource import qualified Types.Backend import qualified Types @@ -314,7 +316,7 @@ checklocationlog :: FilePath -> Bool -> Assertion checklocationlog f expected = do thisuuid <- annexeval Annex.UUID.getUUID - r <- annexeval $ Annex.WorkTree.lookupFile (toRawFilePath f) + r <- annexeval $ Annex.WorkTree.lookupKey (toRawFilePath f) case r of Just k -> do uuids <- annexeval $ Remote.keyLocations k @@ -325,7 +327,7 @@ checkbackend :: FilePath -> Types.Backend -> Assertion checkbackend file expected = do b <- annexeval $ maybe (return Nothing) (Backend.getBackend file) - =<< Annex.WorkTree.lookupFile (toRawFilePath file) + =<< Annex.WorkTree.lookupKey (toRawFilePath file) assertEqual ("backend for " ++ file) (Just expected) b checkispointerfile :: FilePath -> Assertion @@ -582,7 +584,7 @@ backend_ = Backend.lookupBackendVariety . Types.Key.parseKeyVariety . encodeBS getKey :: Types.Backend -> FilePath -> IO Types.Key -getKey b f = case Types.Backend.getKey b of +getKey b f = case Types.Backend.genKey b of Just a -> annexeval $ a ks Utility.Metered.nullMeterUpdate Nothing -> error "internal" where @@ -591,3 +593,10 @@ , Types.KeySource.contentLocation = toRawFilePath f , Types.KeySource.inodeCache = Nothing } + +{- Get the name of the original branch, eg the current branch, or + - if in an adjusted branch, the parent branch. -} +origBranch :: Types.Annex String +origBranch = maybe "foo" + (Git.Types.fromRef . Git.Ref.base . Annex.AdjustedBranch.fromAdjustedBranch) + <$> Annex.inRepo Git.Branch.current diff --git a/Types/Backend.hs b/Types/Backend.hs --- a/Types/Backend.hs +++ b/Types/Backend.hs @@ -2,7 +2,7 @@ - - Most things should not need this, using Types instead - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -17,8 +17,9 @@ data BackendA a = Backend { backendVariety :: KeyVariety - , getKey :: Maybe (KeySource -> MeterUpdate -> a Key) - -- Verifies the content of a key. + , genKey :: Maybe (KeySource -> MeterUpdate -> a Key) + -- Verifies the content of a key using a hash. This does not need + -- to be cryptographically secure. , verifyKeyContent :: Maybe (Key -> FilePath -> a Bool) -- Checks if a key can be upgraded to a better form. , canUpgradeKey :: Maybe (Key -> Bool) @@ -28,6 +29,8 @@ -- Checks if a key is known (or assumed) to always refer to the -- same data. , isStableKey :: Key -> Bool + -- Checks if a key is verified using a cryptographically secure hash. + , isCryptographicallySecure :: Key -> Bool } instance Show (BackendA a) where diff --git a/Types/BranchState.hs b/Types/BranchState.hs --- a/Types/BranchState.hs +++ b/Types/BranchState.hs @@ -1,12 +1,16 @@ {- git-annex BranchState data type - - - Copyright 2011 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Types.BranchState where +import Common + +import qualified Data.ByteString.Lazy as L + data BranchState = BranchState { branchUpdated :: Bool -- ^ has the branch been updated this run? @@ -15,10 +19,14 @@ , journalIgnorable :: Bool -- ^ can reading the journal be skipped, while still getting -- sufficiently up-to-date information from the branch? - , journalNeverIgnorable :: Bool - -- ^ should the journal always be read even if it would normally - -- be safe to skip it? + , cachedFileContents :: [(RawFilePath, L.ByteString)] + -- ^ contents of a few files recently read from the branch + , needInteractiveAccess :: Bool + -- ^ do new changes written to the journal or branch by another + -- process need to be noticed while the current process is running? + -- (This makes the journal always be read, and avoids using the + -- cache.) } startBranchState :: BranchState -startBranchState = BranchState False False False False +startBranchState = BranchState False False False [] False diff --git a/Types/Key.hs b/Types/Key.hs --- a/Types/Key.hs +++ b/Types/Key.hs @@ -23,8 +23,6 @@ HashSize(..), hasExt, sameExceptExt, - cryptographicallySecure, - isVerifiable, formatKeyVariety, parseKeyVariety, ) where @@ -261,36 +259,6 @@ sameExceptExt (SHA1Key _) (SHA1Key _) = True sameExceptExt (MD5Key _) (MD5Key _) = True sameExceptExt _ _ = False - -{- Is the Key variety cryptographically secure, such that no two differing - - file contents can be mapped to the same Key? -} -cryptographicallySecure :: KeyVariety -> Bool -cryptographicallySecure (SHA2Key _ _) = True -cryptographicallySecure (SHA3Key _ _) = True -cryptographicallySecure (SKEINKey _ _) = True -cryptographicallySecure (Blake2bKey _ _) = True -cryptographicallySecure (Blake2bpKey _ _) = True -cryptographicallySecure (Blake2sKey _ _) = True -cryptographicallySecure (Blake2spKey _ _) = True -cryptographicallySecure _ = False - -{- Is the Key variety backed by a hash, which allows verifying content? - - It does not have to be cryptographically secure against eg birthday - - attacks. - -} -isVerifiable :: KeyVariety -> Bool -isVerifiable (SHA2Key _ _) = True -isVerifiable (SHA3Key _ _) = True -isVerifiable (SKEINKey _ _) = True -isVerifiable (Blake2bKey _ _) = True -isVerifiable (Blake2bpKey _ _) = True -isVerifiable (Blake2sKey _ _) = True -isVerifiable (Blake2spKey _ _) = True -isVerifiable (SHA1Key _) = True -isVerifiable (MD5Key _) = True -isVerifiable WORMKey = False -isVerifiable URLKey = False -isVerifiable (OtherKey _) = False formatKeyVariety :: KeyVariety -> S.ByteString formatKeyVariety v = case v of diff --git a/Types/Remote.hs b/Types/Remote.hs --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -276,6 +276,18 @@ -- May also find old versions of files that are still stored in the -- remote. { listImportableContents :: a (Maybe (ImportableContents (ContentIdentifier, ByteSize))) + -- Imports a file from the remote, without downloading it, + -- by generating a Key (of any type). + -- + -- May update the progress meter if it needs to perform an + -- expensive operation, such as hashing a local file. + -- + -- Ensures that the key corresponds to the ContentIdentifier, + -- 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) -- Retrieves a file from the remote. Ensures that the file -- it retrieves has the requested ContentIdentifier. -- diff --git a/Types/View.hs b/Types/View.hs --- a/Types/View.hs +++ b/Types/View.hs @@ -25,7 +25,7 @@ deriving (Eq, Read, Show) instance Arbitrary View where - arbitrary = View (Git.Ref "master") + arbitrary = View (Git.Ref "foo") <$> resize 10 (listOf arbitrary) data ViewComponent = ViewComponent diff --git a/Upgrade/V0.hs b/Upgrade/V0.hs --- a/Upgrade/V0.hs +++ b/Upgrade/V0.hs @@ -31,8 +31,8 @@ keyFile0 = Upgrade.V1.keyFile1 fileKey0 :: FilePath -> Key fileKey0 = Upgrade.V1.fileKey1 -lookupFile0 :: FilePath -> Annex (Maybe (Key, Backend)) -lookupFile0 = Upgrade.V1.lookupFile1 +lookupKey0 :: FilePath -> Annex (Maybe (Key, Backend)) +lookupKey0 = Upgrade.V1.lookupKey1 getKeysPresent0 :: FilePath -> Annex [Key] getKeysPresent0 dir = ifM (liftIO $ doesDirectoryExist dir) diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs --- a/Upgrade/V1.hs +++ b/Upgrade/V1.hs @@ -90,7 +90,7 @@ void $ liftIO cleanup where fixlink f = do - r <- lookupFile1 f + r <- lookupKey1 f case r of Nothing -> noop Just (k, _) -> do @@ -191,8 +191,8 @@ readLog1 file = catchDefaultIO [] $ parseLog . encodeBL <$> readFileStrict file -lookupFile1 :: FilePath -> Annex (Maybe (Key, Backend)) -lookupFile1 file = do +lookupKey1 :: FilePath -> Annex (Maybe (Key, Backend)) +lookupKey1 file = do tl <- liftIO $ tryIO getsymlink case tl of Left _ -> return Nothing diff --git a/Upgrade/V5.hs b/Upgrade/V5.hs --- a/Upgrade/V5.hs +++ b/Upgrade/V5.hs @@ -110,12 +110,12 @@ upgradeDirectWorkTree :: Annex () upgradeDirectWorkTree = do top <- fromRepo Git.repoPath - (l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top] + (l, clean) <- inRepo $ Git.LsFiles.inRepoDetails [] [top] forM_ l go void $ liftIO clean where - go (f, Just _sha, Just mode) | isSymLink mode = do - -- Cannot use lookupFile here, as we're in between direct + go (f, _sha, mode) | isSymLink mode = do + -- Cannot use lookupKey here, as we're in between direct -- mode and v6. mk <- catKeyFile f case mk of diff --git a/Utility/CoProcess.hs b/Utility/CoProcess.hs --- a/Utility/CoProcess.hs +++ b/Utility/CoProcess.hs @@ -1,7 +1,7 @@ {- Interface for running a shell command as a coprocess, - sending it queries and getting back results. - - - Copyright 2012-2020 Joey Hess + - Copyright 2012-2013 Joey Hess - - License: BSD-2-clause -} @@ -62,46 +62,28 @@ let p = proc (coProcessCmd $ coProcessSpec s) (coProcessParams $ coProcessSpec s) forceSuccessProcess p (coProcessPid s) -{- Note that concurrent queries are not safe to perform; caller should - - serialize calls to query. - - - - To handle a restartable process, any IO exception thrown by the send and +{- To handle a restartable process, any IO exception thrown by the send and - receive actions are assumed to mean communication with the process - - failed, and the query is re-run with a new process. - - - - If an async exception is received during a query, the state of - - communication with the process is unknown, so it is killed, and a new - - one started so the CoProcessHandle can continue to be used by other - - threads. - -} + - failed, and the failed action is re-run with a new process. -} query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b -query ch send receive = uninterruptibleMask $ \unmask -> - unmask (readMVar ch >>= restartable) - `catchAsync` forcerestart +query ch send receive = do + s <- readMVar ch + restartable s (send $ coProcessTo s) $ const $ + restartable s (hFlush $ coProcessTo s) $ const $ + restartable s (receive $ coProcessFrom s) + return where - go s = do - void $ send $ coProcessTo s - hFlush $ coProcessTo s - receive $ coProcessFrom s - - restartable s + restartable s a cont | coProcessNumRestarts (coProcessSpec s) > 0 = - catchMaybeIO (go s) - >>= maybe (restart s increstarts restartable) return - | otherwise = go s - - increstarts s = s { coProcessNumRestarts = coProcessNumRestarts s - 1 } - - restart s f cont = do - void $ tryNonAsync $ do + maybe restart cont =<< catchMaybeIO a + | otherwise = cont =<< a + restart = do + s <- takeMVar ch + void $ catchMaybeIO $ do hClose $ coProcessTo s hClose $ coProcessFrom s void $ waitForProcess $ coProcessPid s - s' <- withMVarMasked ch $ \_ -> start' (f (coProcessSpec s)) - cont s' - - forcerestart ex = do - s <- readMVar ch - terminateProcess (coProcessPid s) - restart s id $ \s' -> void $ swapMVar ch s' - either throwM throwM ex + s' <- start' $ (coProcessSpec s) + { coProcessNumRestarts = coProcessNumRestarts (coProcessSpec s) - 1 } + putMVar ch s' + query ch send receive diff --git a/Utility/Exception.hs b/Utility/Exception.hs --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,6 +1,6 @@ {- Simple IO exception handling (and some more) - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2016 Joey Hess - - License: BSD-2-clause -} @@ -20,7 +20,6 @@ bracketIO, catchNonAsync, tryNonAsync, - catchAsync, tryWhenExists, catchIOErrorType, IOErrorType(..), @@ -86,14 +85,6 @@ [ M.Handler (\ (e :: AsyncException) -> throwM e) , M.Handler (\ (e :: SomeAsyncException) -> throwM e) , M.Handler (\ (e :: SomeException) -> onerr e) - ] - -{- Catches only async exceptions. -} -catchAsync :: MonadCatch m => m a -> (Either AsyncException SomeAsyncException -> m a) -> m a -catchAsync a onerr = a `catches` - [ M.Handler (\ (e :: AsyncException) -> onerr (Left e)) - , M.Handler (\ (e :: SomeAsyncException) -> onerr (Right e)) - , M.Handler (\ (e :: SomeException) -> throwM e) ] tryNonAsync :: MonadCatch m => m a -> m (Either SomeException a) diff --git a/Utility/GitLFS.hs b/Utility/GitLFS.hs --- a/Utility/GitLFS.hs +++ b/Utility/GitLFS.hs @@ -21,6 +21,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} +-- This is a vendored copy of Network.GitLFS from the git-lfs package, +-- and will be removed once that package is available in all build +-- environments. module Utility.GitLFS ( -- * Transfer requests TransferRequest(..), diff --git a/Utility/HttpManagerRestricted.hs b/Utility/HttpManagerRestricted.hs --- a/Utility/HttpManagerRestricted.hs +++ b/Utility/HttpManagerRestricted.hs @@ -9,6 +9,9 @@ {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, LambdaCase, PatternGuards #-} +-- This is a vendored copy of Network.HTTP.Client.Restricted from the +-- http-client-restricted package, and will be removed once that package +-- is available in all build environments. module Utility.HttpManagerRestricted ( Restriction, checkAddressRestriction, @@ -21,8 +24,7 @@ ) where import Network.HTTP.Client -import Network.HTTP.Client.Internal - (ManagerSettings(..), Connection, runProxyOverride, makeConnection) +import Network.HTTP.Client.Internal (ManagerSettings(..), Connection, runProxyOverride) import Network.HTTP.Client.TLS (mkManagerSettingsContext) import Network.Socket import Network.BSD (getProtocolNumber) diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -34,6 +34,9 @@ import System.FilePath import Data.List import Data.Maybe +#ifdef mingw32_HOST_OS +import Data.Char +#endif import Control.Applicative import Prelude @@ -211,22 +214,23 @@ - we stop preserving ordering at that point. Presumably a user passing - that many paths in doesn't care too much about order of the later ones. -} -segmentPaths :: [RawFilePath] -> [RawFilePath] -> [[RawFilePath]] -segmentPaths [] new = [new] -segmentPaths [_] new = [new] -- optimisation -segmentPaths (l:ls) new = found : segmentPaths ls rest +segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]] +segmentPaths _ [] new = [new] +segmentPaths _ [_] new = [new] -- optimisation +segmentPaths c (l:ls) new = found : segmentPaths c ls rest where (found, rest) = if length ls < 100 then partition inl new else break (not . inl) new - inl f = fromRawFilePath l `dirContains` fromRawFilePath f + inl f = l' `dirContains` fromRawFilePath (c f) + l' = fromRawFilePath l {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In - the case of git file list commands, that assumption tends to hold. -} -runSegmentPaths :: ([RawFilePath] -> IO [RawFilePath]) -> [RawFilePath] -> IO [[RawFilePath]] -runSegmentPaths a paths = segmentPaths paths <$> a paths +runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]] +runSegmentPaths c a paths = segmentPaths c paths <$> a paths {- Converts paths in the home directory to use ~/ -} relHome :: FilePath -> IO String diff --git a/Utility/Process/Transcript.hs b/Utility/Process/Transcript.hs --- a/Utility/Process/Transcript.hs +++ b/Utility/Process/Transcript.hs @@ -75,7 +75,7 @@ , std_out = CreatePipe , std_err = CreatePipe } - withCreateProcess cp' \hin hout herr pid -> do + withCreateProcess cp' $ \hin hout herr pid -> do let p = (hin, hout, herr, pid) getout <- asyncreader (stdoutHandle p) geterr <- asyncreader (stderrHandle p) diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -26,6 +26,8 @@ import Utility.FileSystemEncoding (RawFilePath) import System.Posix.Files.ByteString +-- | Checks if a file or directoy exists. Note that a dangling symlink +-- will be false. doesPathExist :: RawFilePath -> IO Bool doesPathExist = fileExist diff --git a/Utility/SimpleProtocol.hs b/Utility/SimpleProtocol.hs --- a/Utility/SimpleProtocol.hs +++ b/Utility/SimpleProtocol.hs @@ -25,7 +25,6 @@ import Data.Char import GHC.IO.Handle -import System.Exit (ExitCode(..)) import Common diff --git a/Utility/TList.hs b/Utility/TList.hs --- a/Utility/TList.hs +++ b/Utility/TList.hs @@ -6,7 +6,9 @@ - Unlike a TQueue, the entire contents of a TList can be efficiently - read without modifying it. - - - Copyright 2013 Joey Hess + - Copyright 2013-2020 Joey Hess + - + - License: BSD-2-clause -} {-# LANGUAGE BangPatterns #-} @@ -21,6 +23,7 @@ consTList, snocTList, appendTList, + headTList, ) where import Common @@ -33,6 +36,19 @@ newTList :: STM (TList a) newTList = newEmptyTMVar +{- Takes the head of the TList, leaving the rest. + - Blocks when empty. + - + - O(n) due to use of D.tail + -} +headTList :: TList a -> STM a +headTList tlist = do + dl <- takeTMVar tlist + let !dl' = D.tail dl + unless (emptyDList dl') $ + putTMVar tlist dl' + return (D.head dl) + {- Gets the contents of the TList. Blocks when empty. - TList is left empty. -} getTList :: TList a -> STM [a] @@ -57,7 +73,9 @@ readTList :: TList a -> STM [a] readTList tlist = maybe [] D.toList <$> tryReadTMVar tlist -{- Mutates a TList. -} +{- Mutates a TList. + - + - O(n) due to the use of emptyDList -} modifyTList :: TList a -> (D.DList a -> D.DList a) -> STM () modifyTList tlist a = do dl <- fromMaybe D.empty <$> tryTakeTMVar tlist @@ -66,8 +84,9 @@ - Thus attempts to read it automatically block. -} unless (emptyDList dl') $ putTMVar tlist dl' - where - emptyDList = D.list True (\_ _ -> False) + +emptyDList :: D.DList a -> Bool +emptyDList = D.list True (\_ _ -> False) consTList :: TList a -> a -> STM () consTList tlist v = modifyTList tlist $ \dl -> D.cons v dl diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -9,6 +9,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} module Utility.Url ( newManager, @@ -44,7 +45,11 @@ import Common import Utility.Metered +#ifdef WITH_HTTP_CLIENT_RESTRICTED +import Network.HTTP.Client.Restricted +#else import Utility.HttpManagerRestricted +#endif import Utility.IPAddress import Network.URI 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 @@ -14,11 +14,11 @@ # IMPORTING FROM A SPECIAL REMOTE -Importing from a special remote first downloads all new content from it, -and then constructs a git commit that reflects files that have changed on -the special remote since the last time git-annex looked at it. Merging that -commit into your repository will update it to reflect changes made on the -special remote. +Importing from a special remote first downloads or hashes all new content +from it, and then constructs a git commit that reflects files that have +changed on the special remote since the last time git-annex looked at it. +Merging that commit into your repository will update it to reflect changes +made on the special remote. This way, something can be using the special remote for file storage, adding files, modifying files, and deleting files, and you can track those @@ -34,8 +34,8 @@ non-exhastive list is the directory, s3, and adb special remotes. To import from a special remote, you must specify the name of a branch. -A corresponding remote tracking branch will be updated by `git annex -import`. After that point, it's the same as if you had run a `git fetch` +A corresponding remote tracking branch will be updated by `git annex import`. +After that point, it's the same as if you had run a `git fetch` from a regular git remote; you can merge the changes into your currently checked out branch. @@ -83,6 +83,38 @@ set. This includes expressions containing "copies=", "metadata=", and other things that depend on the key. Preferred content expressions containing "include=", "exclude=" "smallerthan=", "largerthan=" will work. + +# OPTIONS FOR IMPORTING FROM A SPECIAL REMOTE + +* `--content`, `--no-content` + + Controls whether content is downloaded from the special remote. + The default is to download content into the git-annex repository. + + With --no-content, git-annex keys are generated from information + provided by the special remote, without downloading it. Commands like + `git-annex get` can later be used to download files, as desired. + + The --no-content option is not supported by all special remotes, + and the kind of git-annex key that is generated is left up to + each special remote. So while the directory special remote hashes + the file and generates the same key it usually would, other + special remotes may use unusual keys like SHA1, or WORM, depending + on the limitations of the special remote. + + The annex.securehashesonly configuration, if set, will prevent + --no-content importing from a special remote that uses insecure keys. + + Using --no-content prevents annex.largefiles from being checked, + because the files are not downloaded. So, when using --no-content, + files that would usually be considered non-large will be added to the + annex, rather than adding them directly to the git repository. + + Note that a different git tree will often be generated when using + --no-content than would be generated when using --content, because + the options cause different kinds of keys to be used when importing + new/changed files. So mixing uses of --content and --no-content can + lead to merge conflicts in some situations. # IMPORTING FROM A DIRECTORY diff --git a/doc/git-annex-importfeed.mdwn b/doc/git-annex-importfeed.mdwn --- a/doc/git-annex-importfeed.mdwn +++ b/doc/git-annex-importfeed.mdwn @@ -22,20 +22,21 @@ To make the import process add metadata to the imported files from the feed, `git config annex.genmetadata true` +By default, the downloaded files are put in a directory with the title +of the feed, and files are named based on the title of the item in the +feed. This can be changed using the --template option. + +Existing files are not overwritten by this command. If "some feed/foo.mp3" +already exists, it will instead write to "some feed/2\_foo.mp3" +(or 3, 4, etc). Sometimes a feed will change an item's url, +resulting in the new url being downloaded to such a filename. + # OPTIONS * `--force` Force downloading items it's seen before. -* `--template` - - Controls where the files are stored. - - The default template is '${feedtitle}/${itemtitle}${extension}' - - Other available variables for templates: feedauthor, itemauthor, itemsummary, itemdescription, itemrights, itemid, itempubdate, title, author - * `--relaxed`, `--fast`, `--raw` These options behave the same as when using [[git-annex-addurl]](1). @@ -56,6 +57,37 @@ Prevent special handling of urls by youtube-dl, bittorrent, and other special remotes. This will for example, make importfeed download a .torrent file and not the contents it points to. + +* `--template` + + Controls where the files are stored. + + The default template is '${feedtitle}/${itemtitle}${extension}' + + The available variables in the template include these that + are information about the feed: feedtitle, feedauthor + + And these that are information about individual items in the feed: + itemtitle, itemauthor, itemsummary, itemdescription, itemrights, + itemid. + + Also, title is itemtitle but falls back to feedtitle if the item has no + title, and author is itemauthor but falls back to feedauthor. + + (All of the above are also added as metadata when annex.genmetadata is + set.) + + The extension variable is the extension of the file in the feed, + or sometimes ".m" if no extension can be determined. + + The template also has some variables for when an item was published. + + itempubyear (YYYY), itempubmonth (MM), itempubday (DD), itempubhour (HH), + itempubminute (MM), itempubsecond (SS), + itempubdate (YYYY-MM-DD or if the feed's date cannot be parsed, the raw + value from the feed). + + (These use the UTC time zone, not the local time zone.) # SEE ALSO 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 @@ -109,7 +109,7 @@ of a repository. See [[git-annex-preferred-content]](1). When `remote..annex-tracking-branch` is configured for a special remote - and that branch is checked out, syncing will import changes from + and that branch is checked out, syncing content will 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. See See [[git-annex-import]](1) and [[git-annex-export]](1) for details about diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -856,8 +856,10 @@ When this is set, the contents of files using cryptographically insecure hashes will not be allowed to be added to the repository. - Also, git-annex fsck` will complain about any files present in - the repository that use insecure hashes. + Also, `git-annex fsck` will complain about any files present in + the repository that use insecure hashes. And, + `git-annex import --no-content` will refuse to import files + from special remotes using insecure hashes. To configure the behavior in new clones of the repository, this can be set using [[git-annex-config]]. 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.20200617 +Version: 8.20200720 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -289,6 +289,14 @@ Description: Build with network-3.0 which split out network-bsd Default: True +Flag GitLfs + Description: Build with git-lfs library (rather than vendored copy) + Default: True + +Flag HttpClientRestricted + Description: Build with http-client-restricted library (rather than vendored copy) + Default: True + source-repository head type: git location: git://git-annex.branchable.com/ @@ -337,7 +345,7 @@ edit-distance, resourcet, connection (>= 0.2.6), - http-client (>= 0.5.0), + http-client (>= 0.5.3), http-client-tls, http-types (>= 0.7), http-conduit (>= 2.3.0), @@ -407,6 +415,18 @@ else Build-Depends: network (< 3.0.0.0), network (>= 2.6.3.0) + if flag(GitLfs) + Build-Depends: git-lfs (>= 1.1.0) + CPP-Options: -DWITH_GIT_LFS + else + Other-Modules: Utility.GitLFS + + if flag(HttpClientRestricted) + Build-Depends: http-client-restricted (>= 0.0.2) + CPP-Options: -DWITH_HTTP_CLIENT_RESTRICTED + else + Other-Modules: Utility.HttpManagerRestricted + if flag(S3) Build-Depends: aws (>= 0.20) CPP-Options: -DWITH_S3 @@ -418,6 +438,7 @@ Other-Modules: Remote.WebDAV Remote.WebDAV.DavLocation + if flag(S3) || flag(WebDAV) Other-Modules: Remote.Helper.Http @@ -1059,12 +1080,10 @@ Utility.FileSystemEncoding Utility.Format Utility.FreeDesktop - Utility.GitLFS Utility.Glob Utility.Gpg Utility.Hash Utility.HtmlDetect - Utility.HttpManagerRestricted Utility.HumanNumber Utility.HumanTime Utility.InodeCache diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -12,6 +12,8 @@ debuglocks: false benchmark: false networkbsd: false + gitlfs: true + httpclientrestricted: true packages: - '.' extra-deps: @@ -22,6 +24,9 @@ - sandi-0.5 - tasty-rerun-1.1.17 - torrent-10000.1.1 + - git-lfs-1.1.0 + - http-client-restricted-0.0.2 + - http-client-0.5.14 explicit-setup-deps: git-annex: true resolver: lts-14.27