git-annex 10.20221003 → 10.20221103
raw patch · 47 files changed
+506/−323 lines, 47 files
Files
- Annex.hs +0/−4
- Annex/Action.hs +20/−6
- Annex/Content.hs +1/−1
- Annex/Import.hs +7/−4
- Annex/Path.hs +32/−6
- Annex/WorkTree.hs +14/−21
- Assistant/Install.hs +0/−22
- Assistant/MakeRepo.hs +1/−1
- CHANGELOG +26/−0
- CmdLine.hs +1/−1
- CmdLine/Batch.hs +3/−2
- CmdLine/GitRemoteTorAnnex.hs +4/−1
- CmdLine/Usage.hs +2/−0
- Command.hs +0/−1
- Command/Add.hs +4/−1
- Command/AddUrl.hs +10/−5
- Command/Dead.hs +1/−1
- Command/EnableTor.hs +2/−1
- Command/Export.hs +1/−1
- Command/ImportFeed.hs +4/−1
- Command/Info.hs +4/−3
- Command/MetaData.hs +1/−1
- Command/Move.hs +10/−12
- Command/ReKey.hs +4/−1
- Command/RecvKey.hs +1/−3
- Command/Reinject.hs +7/−6
- Command/RmUrl.hs +7/−4
- Command/Semitrust.hs +1/−1
- Command/Sync.hs +6/−2
- Command/Trust.hs +5/−5
- Command/Uninit.hs +7/−2
- Command/Untrust.hs +1/−1
- Command/WebApp.hs +6/−2
- Database/Handle.hs +148/−84
- Database/Keys.hs +71/−47
- Database/Keys/Handle.hs +8/−5
- Database/Keys/Tables.hs +38/−0
- Logs/File.hs +10/−32
- Logs/Restage.hs +2/−1
- Remote.hs +1/−1
- Remote/Git.hs +7/−9
- Remote/S3.hs +13/−10
- Test.hs +3/−3
- Types/Remote.hs +4/−3
- Upgrade/V7.hs +3/−1
- Utility/Su.hs +3/−3
- git-annex.cabal +2/−1
Annex.hs view
@@ -287,12 +287,8 @@ run' :: MVar AnnexState -> AnnexRead -> Annex a -> IO (a, (AnnexState, AnnexRead)) run' mvar rd a = do r <- runReaderT (runAnnex a) (mvar, rd)- `onException` (flush rd)- flush rd st <- takeMVar mvar return (r, (st, rd))- where- flush = Keys.flushDbQueue . keysdbhandle {- Performs an action in the Annex monad from a starting state, - and throws away the changed state. -}
Annex/Action.hs view
@@ -1,6 +1,6 @@ {- git-annex actions -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -11,7 +11,7 @@ action, verifiedAction, startup,- shutdown,+ quiesce, stopCoProcesses, ) where @@ -25,6 +25,7 @@ import Annex.HashObject import Annex.CheckIgnore import Annex.TransferrerPool+import qualified Database.Keys import Control.Concurrent.STM #ifndef mingw32_HOST_OS@@ -74,12 +75,25 @@ return () #endif -{- Cleanup actions. -}-shutdown :: Bool -> Annex ()-shutdown nocommit = do+{- Rn all cleanup actions, save all state, stop all long-running child+ - processes.+ -+ - This can be run repeatedly with other Annex actions run in between,+ - but usually it is run only once at the end.+ -+ - When passed True, avoids making any commits to the git-annex branch,+ - leaving changes in the journal for later commit.+ -}+quiesce :: Bool -> Annex ()+quiesce nocommit = do+ cas <- Annex.withState $ \st -> return + ( st { Annex.cleanupactions = mempty }+ , Annex.cleanupactions st+ )+ sequence_ (M.elems cas) saveState nocommit- sequence_ =<< M.elems <$> Annex.getState Annex.cleanupactions stopCoProcesses+ Database.Keys.closeDb {- Stops all long-running child processes, including git query processes. -} stopCoProcesses :: Annex ()
Annex/Content.hs view
@@ -718,7 +718,7 @@ saveState :: Bool -> Annex () saveState nocommit = doSideAction $ do Annex.Queue.flush- Database.Keys.closeDb+ Database.Keys.flushDb unless nocommit $ whenM (annexAlwaysCommit <$> Annex.getGitConfig) $ Annex.Branch.commit =<< Annex.Branch.commitMessage
Annex/Import.hs view
@@ -184,10 +184,13 @@ unlessM (stillpresent db oldkey) $ logChange oldkey (Remote.uuid remote) InfoMissing _ -> noop- db <- Export.openDb (Remote.uuid remote)- forM_ (exportedTreeishes oldexport) $ \oldtree ->- Export.runExportDiffUpdater updater db oldtree finaltree- Export.closeDb db+ -- When the remote is versioned, it still contains keys+ -- that are not present in the new tree.+ unless (Remote.versionedExport (Remote.exportActions remote)) $ do+ db <- Export.openDb (Remote.uuid remote)+ forM_ (exportedTreeishes oldexport) $ \oldtree ->+ Export.runExportDiffUpdater updater db oldtree finaltree+ Export.closeDb db buildImportCommit' :: Remote -> ImportCommitConfig -> Maybe Sha -> History Sha -> Annex (Maybe Sha) buildImportCommit' remote importcommitconfig mtrackingcommit imported@(History ti _) =
Annex/Path.hs view
@@ -1,6 +1,6 @@ {- git-annex program path -- - Copyright 2013-2021 Joey Hess <id@joeyh.name>+ - Copyright 2013-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -11,6 +11,7 @@ gitAnnexChildProcess, gitAnnexChildProcessParams, gitAnnexDaemonizeParams,+ cleanStandaloneEnvironment, ) where import Annex.Common@@ -19,7 +20,7 @@ import Annex.PidLock import qualified Annex -import System.Environment (getExecutablePath, getArgs)+import System.Environment (getExecutablePath, getArgs, getProgName) {- A fully qualified path to the currently running git-annex program. - @@ -29,13 +30,16 @@ - or searching for the command name in PATH. - - The standalone build runs git-annex via ld.so, and defeats- - getExecutablePath. It sets GIT_ANNEX_PROGRAMPATH to the correct path- - to the wrapper script to use.+ - getExecutablePath. It sets GIT_ANNEX_DIR to the location of the+ - standalone build directory, and there are wrapper scripts for git-annex+ - and git-annex-shell in that directory. -} programPath :: IO FilePath-programPath = go =<< getEnv "GIT_ANNEX_PROGRAMPATH"+programPath = go =<< getEnv "GIT_ANNEX_DIR" where- go (Just p) = return p+ go (Just dir) = do+ name <- getProgName+ return (dir </> name) go Nothing = do exe <- getExecutablePath p <- if isAbsolute exe@@ -97,3 +101,25 @@ -- Get every parameter git-annex was run with. ps <- liftIO getArgs return (map Param ps ++ cps)++{- Returns a cleaned up environment that lacks path and other settings+ - used to make the standalone builds use their bundled libraries and programs.+ - Useful when calling programs not included in the standalone builds.+ -+ - For a non-standalone build, returns Nothing.+ -}+cleanStandaloneEnvironment :: IO (Maybe [(String, String)])+cleanStandaloneEnvironment = clean <$> getEnvironment+ where+ clean environ+ | null vars = Nothing+ | otherwise = Just $ catMaybes $ map (restoreorig environ) environ+ where+ vars = words $ fromMaybe "" $+ lookup "GIT_ANNEX_STANDLONE_ENV" environ+ restoreorig oldenviron p@(k, _v)+ | k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of+ (Just v')+ | not (null v') -> Just (k, v')+ _ -> Nothing+ | otherwise = Just p
Annex/WorkTree.hs view
@@ -1,6 +1,6 @@ {- git-annex worktree files -- - Copyright 2013-2021 Joey Hess <id@joeyh.name>+ - Copyright 2013-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -14,7 +14,7 @@ import qualified Database.Keys {- Looks up the key corresponding to an annexed file in the work tree,- - by examining what the file links to.+ - by examining what the symlink points to. - - An unlocked file will not have a link on disk, so fall back to - looking for a pointer to a key in git.@@ -31,6 +31,16 @@ , catKeyFileHidden file =<< getCurrentBranch ) +{- Like lookupKey, but only looks at files staged in git, not at unstaged+ - changes in the work tree. This means it's slower, but it also has+ - consistently the same behavior for locked files as for unlocked files.+ -}+lookupKeyStaged :: RawFilePath -> Annex (Maybe Key)+lookupKeyStaged file = catKeyFile file >>= \case+ Just k -> return (Just k)+ Nothing -> catKeyFileHidden file =<< getCurrentBranch++{- Like lookupKey, but does not find keys for hidden files. -} lookupKeyNotHidden :: RawFilePath -> Annex (Maybe Key) lookupKeyNotHidden = lookupKey' catkeyfile where@@ -45,23 +55,6 @@ Just key -> return (Just key) Nothing -> catkeyfile file -{- Modifies an action to only act on files that are already annexed,- - and passes the key on to it. -}-whenAnnexed :: (RawFilePath -> Key -> Annex (Maybe a)) -> RawFilePath -> Annex (Maybe a)-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 =<< lookupKey file--{- Find all annexed files and update the keys database for them.- - - - Normally the keys database is updated incrementally when it's being- - opened, and changes are noticed. Calling this explicitly allows- - running the update at an earlier point.- -- - All that needs to be done is to open the database,- - that will result in Database.Keys.reconcileStaged- - running, and doing the work.- -}+{- Find all annexed files and update the keys database for them. -} scanAnnexedFiles :: Annex ()-scanAnnexedFiles = Database.Keys.runWriter (const noop)+scanAnnexedFiles = Database.Keys.updateDatabase
Assistant/Install.hs view
@@ -171,25 +171,3 @@ #else installFileManagerHooks _ = noop #endif--{- Returns a cleaned up environment that lacks settings used to make the- - standalone builds use their bundled libraries and programs.- - Useful when calling programs not included in the standalone builds.- -- - For a non-standalone build, returns Nothing.- -}-cleanEnvironment :: IO (Maybe [(String, String)])-cleanEnvironment = clean <$> getEnvironment- where- clean environ- | null vars = Nothing- | otherwise = Just $ catMaybes $ map (restoreorig environ) environ- where- vars = words $ fromMaybe "" $- lookup "GIT_ANNEX_STANDLONE_ENV" environ- restoreorig oldenviron p@(k, _v)- | k `elem` vars = case lookup ("ORIG_" ++ k) oldenviron of- (Just v')- | not (null v') -> Just (k, v')- _ -> Nothing- | otherwise = Just p
Assistant/MakeRepo.hs view
@@ -49,7 +49,7 @@ state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath (toRawFilePath dir)- Annex.eval state $ a `finally` stopCoProcesses+ Annex.eval state $ a `finally` quiesce True {- Creates a new repository, and returns its UUID. -} initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID
CHANGELOG view
@@ -1,3 +1,29 @@+git-annex (10.20221103) upstream; urgency=medium++ * Doubled the speed of git-annex drop when operating on many files,+ and of git-annex get when operating on many tiny files.+ * trust, untrust, semitrust, dead: Fix behavior when provided with+ multiple repositories to operate on.+ * trust, untrust, semitrust, dead: When provided with no parameters,+ do not operate on a repository that has an empty name.+ * move: Fix openFile crash with -J+ (Fixes a reversion in 8.20201103)+ * S3: Speed up importing from a large bucket when fileprefix= is set,+ by only asking for files under the prefix.+ * When importing from versioned remotes, fix tracking of the content+ of deleted files.+ * More robust handling of ErrorBusy when writing to sqlite databases.+ * Avoid hanging when a suspended git-annex process is keeping a sqlite+ database locked.+ * Make --batch mode handle unstaged annexed files consistently+ whether the file is unlocked or not. Note that this changes the+ behavior of --batch when it is provided with locked files that are+ in the process of being added to the repository, but have not yet been+ staged in git.+ * Make git-annex enable-tor work when using the linux standalone build.++ -- Joey Hess <id@joeyh.name> Thu, 03 Nov 2022 14:07:31 -0400+ git-annex (10.20221003) upstream; urgency=medium * Avoid displaying warning about git-annex restage needing to be run
CmdLine.hs view
@@ -63,7 +63,7 @@ prepRunCommand cmd annexsetter startup performCommandAction True cmd seek $- shutdown $ cmdnocommit cmd+ quiesce $ cmdnocommit cmd go (Left norepo) = do let ingitrepo = \a -> a =<< Git.Config.global -- Parse command line with full cmdparser first,
CmdLine/Batch.hs view
@@ -186,8 +186,9 @@ matcher <- getMatcher batchFilesKeys fmt $ \(si, v) -> case v of- Right bf -> flip whenAnnexed bf $ \f k ->- checkpresent k $+ Right f -> lookupKeyStaged f >>= \case+ Nothing -> return Nothing+ Just k -> checkpresent k $ startAction seeker si f k Left k -> ifM (matcher (MatchingInfo (mkinfo k))) ( checkpresent k $
CmdLine/GitRemoteTorAnnex.hs view
@@ -17,6 +17,7 @@ import Annex.UUID import P2P.Address import P2P.Auth+import Annex.Action run :: [String] -> IO () run (_remotename:address:[]) = forever $@@ -59,6 +60,8 @@ g <- Annex.gitRepo conn <- liftIO $ connectPeer g (TorAnnex address port) runst <- liftIO $ mkRunState Client- liftIO $ runNetProto runst conn $ auth myuuid authtoken noop >>= \case+ r <- liftIO $ runNetProto runst conn $ auth myuuid authtoken noop >>= \case Just _theiruuid -> connect service stdin stdout Nothing -> giveup $ "authentication failed, perhaps you need to set " ++ p2pAuthTokenEnv+ quiesce False+ return r
CmdLine/Usage.hs view
@@ -60,6 +60,8 @@ paramNumRange = "NUM|RANGE" paramRemote :: String paramRemote = "REMOTE"+paramRepository :: String+paramRepository = "REPOSITORY" paramField :: String paramField = "FIELD" paramGlob :: String
Command.hs view
@@ -11,7 +11,6 @@ ) where import Annex.Common as ReExported-import Annex.WorkTree as ReExported (whenAnnexed, ifAnnexed) import Types.Command as ReExported import Types.DeferredParse as ReExported import CmdLine.Seek as ReExported
Command/Add.hs view
@@ -18,6 +18,7 @@ import Annex.Link import Annex.Tmp import Annex.HashObject+import Annex.WorkTree import Messages.Progress import Git.FilePath import Git.Types@@ -202,7 +203,9 @@ mk <- liftIO $ isPointerFile file maybe (go s) (fixuppointer s) mk where- go s = ifAnnexed file (addpresent s) (add s)+ go s = lookupKey file >>= \case+ Just k -> addpresent s k+ Nothing -> add s add s = starting "add" (ActionItemTreeFile file) si $ skipWhenDryRun dr $ if isSymbolicLink s
Command/AddUrl.hs view
@@ -20,6 +20,7 @@ import Annex.CheckIgnore import Annex.Perms import Annex.UUID+import Annex.WorkTree import Annex.YoutubeDl import Annex.UntrustedFilePath import Logs.Web@@ -183,7 +184,9 @@ performRemote addunlockedmatcher r o uri (toRawFilePath file') sz performRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> RawFilePath -> Maybe Integer -> CommandPerform-performRemote addunlockedmatcher r o uri file sz = ifAnnexed file adduri geturi+performRemote addunlockedmatcher r o uri file sz = lookupKey file >>= \case+ Just k -> adduri k+ Nothing -> geturi where loguri = setDownloader uri OtherDownloader adduri = addUrlChecked o loguri file (Remote.uuid r) checkexistssize@@ -270,7 +273,9 @@ ] performWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> RawFilePath -> Url.UrlInfo -> CommandPerform-performWeb addunlockedmatcher o url file urlinfo = ifAnnexed file addurl geturl+performWeb addunlockedmatcher o url file urlinfo = lookupKey file >>= \case+ Just k -> addurl k+ Nothing -> geturl where geturl = next $ isJust <$> addUrlFile addunlockedmatcher (downloadOptions o) url urlinfo file addurl = addUrlChecked o url file webUUID $ \k ->@@ -335,9 +340,9 @@ tryyoutubedl tmp = youtubeDlFileNameHtmlOnly url >>= \case Right mediafile -> let f = youtubeDlDestFile o file (toRawFilePath mediafile)- in ifAnnexed f- (alreadyannexed (fromRawFilePath f))- (dl f)+ in lookupKey f >>= \case+ Just k -> alreadyannexed (fromRawFilePath f) k+ Nothing -> dl f Left err -> checkRaw (Just err) o Nothing (normalfinish tmp) where dl dest = withTmpWorkDir mediakey $ \workdir -> do
Command/Dead.hs view
@@ -16,7 +16,7 @@ cmd :: Command cmd = command "dead" SectionSetup "hide a lost repository or key"- (paramRepeating paramRemote) (seek <$$> optParser)+ (paramRepeating paramRepository) (seek <$$> optParser) data DeadOptions = DeadRemotes [RemoteName] | DeadKeys [Key]
Command/EnableTor.hs view
@@ -60,9 +60,10 @@ gitannex <- liftIO programPath let ps = [Param (cmdname cmd), Param (show curruserid)] sucommand <- liftIO $ mkSuCommand gitannex ps+ cleanenv <- liftIO $ cleanStandaloneEnvironment maybe noop showLongNote (describePasswordPrompt' sucommand)- ifM (liftIO $ runSuCommand sucommand)+ ifM (liftIO $ runSuCommand sucommand cleanenv) ( next checkHiddenService , giveup $ unwords $ [ "Failed to run as root:" , gitannex ] ++ toCommand ps
Command/Export.hs view
@@ -378,7 +378,7 @@ removeExportedLocation db ek loc flushDbQueue db - -- An versionedExport remote supports removeExportLocation to remove+ -- A versionedExport remote supports removeExportLocation to remove -- the file from the exported tree, but still retains the content -- and allows retrieving it. unless (versionedExport (exportActions r)) $ do
Command/ImportFeed.hs view
@@ -40,6 +40,7 @@ import Annex.UUID import Backend.URL (fromUrl) import Annex.Content+import Annex.WorkTree import Annex.YoutubeDl import Types.MetaData import Logs.MetaData@@ -297,7 +298,9 @@ - to be re-downloaded. -} makeunique url n file = ifM alreadyexists ( ifM forced- ( ifAnnexed (toRawFilePath f) checksameurl tryanother+ ( lookupKey (toRawFilePath f) >>= \case+ Just k -> checksameurl k+ Nothing -> tryanother , tryanother ) , return $ Just f
Command/Info.hs view
@@ -28,6 +28,7 @@ import Annex.Content import Annex.UUID import Annex.CatFile+import Annex.WorkTree import Logs.UUID import Logs.Trust import Logs.Location@@ -174,9 +175,9 @@ Right u -> uuidInfo o u si Left _ -> do relp <- liftIO $ relPathCwdToFile (toRawFilePath p)- ifAnnexed relp- (fileInfo o (fromRawFilePath relp) si)- (treeishInfo o p si)+ lookupKey relp >>= \case+ Just k -> fileInfo o (fromRawFilePath relp) si k+ Nothing -> treeishInfo o p si ) where isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
Command/MetaData.hs view
@@ -155,7 +155,7 @@ startBatch :: (SeekInput, (Either RawFilePath Key, MetaData)) -> CommandStart startBatch (si, (i, (MetaData m))) = case i of Left f -> do- mk <- lookupKey f+ mk <- lookupKeyStaged f case mk of Just k -> go k (mkActionItem (k, AssociatedFile (Just f))) Nothing -> return Nothing
Command/Move.hs view
@@ -379,10 +379,9 @@ -- Only log when there was no copy. unless deststartedwithcopy $ appendLogFile logf lckf logline- return logf+ return (logf, lckf) - cleanup logf = do- lck <- fromRepo gitAnnexMoveLock+ cleanup (logf, lckf) = -- This buffers the log file content in memory. -- The log file length is limited to the number of -- concurrent jobs, times the number of times a move@@ -390,18 +389,17 @@ -- That could grow without bounds given enough time, -- so the log is also truncated to the most recent -- 100 items.- modifyLogFile logf lck+ modifyLogFile logf lckf (filter (/= logline) . reverse . take 100 . reverse) - go logf+ go fs@(logf, lckf) -- Only need to check log when there is a copy. | deststartedwithcopy = do- wasnocopy <- checkLogFile (fromRawFilePath logf)- (== logline)+ wasnocopy <- checkLogFile logf lckf (== logline) if wasnocopy- then go' logf False- else go' logf deststartedwithcopy- | otherwise = go' logf deststartedwithcopy+ then go' fs False+ else go' fs deststartedwithcopy+ | otherwise = go' fs deststartedwithcopy - go' logf deststartedwithcopy' = a $- DestStartedWithCopy deststartedwithcopy' (cleanup logf)+ go' fs deststartedwithcopy' = a $+ DestStartedWithCopy deststartedwithcopy' (cleanup fs)
Command/ReKey.hs view
@@ -16,6 +16,7 @@ import Annex.ReplaceFile import Logs.Location import Annex.InodeSentinal+import Annex.WorkTree import Utility.InodeCache import qualified Utility.RawFilePath as R @@ -61,7 +62,9 @@ (toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey)) start :: SeekInput -> (RawFilePath, Key) -> CommandStart-start si (file, newkey) = ifAnnexed file go stop+start si (file, newkey) = lookupKey file >>= \case+ Just k -> go k+ Nothing -> stop where go oldkey | oldkey == newkey = stop
Command/RecvKey.hs view
@@ -31,9 +31,7 @@ ifM (getViaTmp rsp DefaultVerify key (AssociatedFile Nothing) go) ( do logStatus key InfoPresent- -- forcibly quit after receiving one key,- -- and shutdown cleanly- _ <- shutdown True+ _ <- quiesce True return True , return False )
Command/Reinject.hs view
@@ -13,6 +13,7 @@ import Backend import Types.KeySource import Utility.Metered+import Annex.WorkTree import qualified Git cmd :: Command@@ -45,9 +46,9 @@ startSrcDest ps@(src:dest:[]) | src == dest = stop | otherwise = notAnnexed src' $- ifAnnexed (toRawFilePath dest) - go- (giveup $ src ++ " is not an annexed file")+ lookupKey (toRawFilePath dest) >>= \case+ Just k -> go k+ Nothing -> giveup $ src ++ " is not an annexed file" where src' = toRawFilePath src go key = starting "reinject" ai si $@@ -79,9 +80,9 @@ notAnnexed src a = ifM (fromRepo Git.repoIsLocalBare) ( a- , ifAnnexed src- (giveup $ "cannot used annexed file as src: " ++ fromRawFilePath src)- a+ , lookupKey src >>= \case+ Just _ -> giveup $ "cannot used annexed file as src: " ++ fromRawFilePath src+ Nothing -> a ) perform :: RawFilePath -> Key -> CommandPerform
Command/RmUrl.hs view
@@ -9,6 +9,7 @@ import Command import Logs.Web+import Annex.WorkTree cmd :: Command cmd = notBareRepo $@@ -46,10 +47,12 @@ return $ Right (f', reverse ru) start :: (SeekInput, (FilePath, URLString)) -> CommandStart-start (si, (file, url)) = flip whenAnnexed file' $ \_ key -> do- let ai = mkActionItem (key, AssociatedFile (Just file'))- starting "rmurl" ai si $- next $ cleanup url key+start (si, (file, url)) = lookupKeyStaged file' >>= \case+ Nothing -> stop+ Just key -> do+ let ai = mkActionItem (key, AssociatedFile (Just file'))+ starting "rmurl" ai si $+ next $ cleanup url key where file' = toRawFilePath file
Command/Semitrust.hs view
@@ -14,7 +14,7 @@ cmd :: Command cmd = command "semitrust" SectionSetup "return repository to default trust level"- (paramRepeating paramRemote) (withParams seek)+ (paramRepeating paramRepository) (withParams seek) seek :: CmdParams -> CommandSeek seek = trustCommand "semitrust" SemiTrusted
Command/Sync.hs view
@@ -50,6 +50,7 @@ import Annex.Path import Annex.Wanted import Annex.Content+import Annex.WorkTree import Command.Get (getKey') import qualified Command.Move import qualified Command.Export@@ -765,7 +766,10 @@ seekHelper fst3 ww LsFiles.inRepoDetails l seekincludinghidden origbranch mvar l bloomfeeder =- seekFiltered (const (pure True)) (\(si, f) -> ifAnnexed f (commandAction . gofile bloomfeeder mvar si f) noop) $+ let filterer = \(si, f) -> lookupKey f >>= \case+ Just k -> (commandAction $ gofile bloomfeeder mvar si f k)+ Nothing -> noop+ in seekFiltered (const (pure True)) filterer $ seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l ww = WarnUnmatchLsFiles@@ -916,7 +920,7 @@ _ -> noop Just b -> showLongNote $ unwords [ notupdating- , "because " ++ Git.fromRef b ++ "does not exist."+ , "because " ++ Git.fromRef b ++ " does not exist." , "(As configured by " ++ gitconfig ++ ")" ] where
Command/Trust.hs view
@@ -18,18 +18,18 @@ cmd :: Command cmd = command "trust" SectionSetup "trust a repository"- (paramRepeating paramRemote) (withParams seek)+ (paramRepeating paramRepository) (withParams seek) seek :: CmdParams -> CommandSeek seek = trustCommand "trust" Trusted trustCommand :: String -> TrustLevel -> CmdParams -> CommandSeek-trustCommand c level = withWords (commandAction . start)+trustCommand _ _ [] = giveup "no repository name specified"+trustCommand c level ps = withStrings (commandAction . start) ps where- start ws = do- let name = unwords ws+ start name = do u <- Remote.nameToUUID name- let si = SeekInput ws+ let si = SeekInput [name] starting c (ActionItemOther (Just name)) si (perform name u) perform name uuid = do when (level >= Trusted) $
Command/Uninit.hs view
@@ -18,6 +18,7 @@ import Annex.Content import Annex.Init import Annex.CheckIgnore+import Annex.WorkTree import Utility.FileMode import qualified Utility.RawFilePath as R @@ -50,13 +51,17 @@ l <- workTreeItems ww ps withFilesNotInGit (CheckGitIgnore False)- WarnUnmatchWorkTreeItems - (\(_, f) -> commandAction $ whenAnnexed (startCheckIncomplete . fromRawFilePath) f)+ WarnUnmatchWorkTreeItems+ checksymlinks l withFilesInGitAnnex ww (Command.Unannex.seeker True) l finish where ww = WarnUnmatchLsFiles+ checksymlinks (_, f) = + commandAction $ lookupKey f >>= \case+ Nothing -> stop+ Just k -> startCheckIncomplete (fromRawFilePath f) k {- git annex symlinks that are not checked into git could be left by an - interrupted add. -}
Command/Untrust.hs view
@@ -13,7 +13,7 @@ cmd :: Command cmd = command "untrust" SectionSetup "do not trust a repository"- (paramRepeating paramRemote) (withParams seek)+ (paramRepeating paramRepository) (withParams seek) seek :: CmdParams -> CommandSeek seek = trustCommand "untrust" UnTrusted
Command/WebApp.hs view
@@ -22,6 +22,7 @@ import Utility.Daemon (checkDaemon) import Utility.UserInfo import Annex.Init+import Annex.Path import qualified Git import Git.Types (fromConfigValue) import qualified Git.Config@@ -30,6 +31,7 @@ import Config.Files.AutoStart import Upgrade import Annex.Version+import Annex.Action import Utility.Android import Control.Concurrent@@ -126,8 +128,10 @@ Right state -> void $ Annex.eval state $ do whenM (fromRepo Git.repoIsLocalBare) $ giveup $ d ++ " is a bare git repository, cannot run the webapp in it"- callCommandAction $+ r <- callCommandAction $ start' False o+ quiesce False+ return r cannotStartIn :: FilePath -> String -> IO () cannotStartIn d reason = warningIO $ "unable to start webapp in repository " ++ d ++ ": " ++ reason@@ -219,7 +223,7 @@ #endif hPutStrLn (fromMaybe stdout outh) $ "Launching web browser on " ++ url hFlush stdout- environ <- cleanEnvironment+ environ <- cleanStandaloneEnvironment let p' = p { env = environ , std_out = maybe Inherit UseHandle outh
Database/Handle.hs view
@@ -1,6 +1,6 @@ {- Persistent sqlite database handles. -- - Copyright 2015-2019 Joey Hess <id@joeyh.name>+ - Copyright 2015-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -21,6 +21,7 @@ import Utility.FileSystemEncoding import Utility.Debug import Utility.DebugLocks+import Utility.InodeCache import Database.Persist.Sqlite import qualified Database.Sqlite as Sqlite@@ -38,7 +39,7 @@ {- A DbHandle is a reference to a worker thread that communicates with - the database. It has a MVar which Jobs are submitted to. -}-data DbHandle = DbHandle (Async ()) (MVar Job)+data DbHandle = DbHandle RawFilePath (Async ()) (MVar Job) {- Name of a table that should exist once the database is initialized. -} type TableName = String@@ -48,17 +49,17 @@ openDb :: RawFilePath -> TableName -> IO DbHandle openDb db tablename = do jobs <- newEmptyMVar- worker <- async (workerThread (T.pack (fromRawFilePath db)) tablename jobs)+ worker <- async (workerThread db tablename jobs) -- work around https://github.com/yesodweb/persistent/issues/474 liftIO $ fileEncoding stderr - return $ DbHandle worker jobs+ return $ DbHandle db worker jobs {- This is optional; when the DbHandle gets garbage collected it will - auto-close. -} closeDb :: DbHandle -> IO ()-closeDb (DbHandle worker jobs) = do+closeDb (DbHandle _db worker jobs) = do debugLocks $ putMVar jobs CloseJob wait worker @@ -73,7 +74,7 @@ - it is able to run. -} queryDb :: DbHandle -> SqlPersistM a -> IO a-queryDb (DbHandle _ jobs) a = do+queryDb (DbHandle _db _ jobs) a = do res <- newEmptyMVar putMVar jobs $ QueryJob $ debugLocks $ liftIO . putMVar res =<< tryNonAsync a@@ -82,25 +83,32 @@ {- Writes a change to the database. -- - Writes can fail if another write is happening concurrently.- - So write failures are caught and retried repeatedly for up to 10- - seconds, which should avoid all but the most exceptional problems.+ - Writes can fail when another write is happening concurrently.+ - So write failures are caught and retried.+ -+ - Retries repeatedly for up to 60 seconds. Part that point, it continues+ - retrying only if the database shows signs of being modified by another+ - process at least once each 30 seconds. -} commitDb :: DbHandle -> SqlPersistM () -> IO ()-commitDb h wa = robustly Nothing 100 (commitDb' h wa)+commitDb h@(DbHandle db _ _) wa = + robustly (commitDb' h wa) maxretries emptyDatabaseInodeCache where- robustly :: Maybe SomeException -> Int -> IO (Either SomeException ()) -> IO ()- robustly e 0 _ = error $ "failed to commit changes to sqlite database: " ++ show e- robustly _ n a = do+ robustly a retries ic = do r <- a case r of Right _ -> return ()- Left e -> do- threadDelay 100000 -- 1/10th second- robustly (Just e) (n-1) a+ Left err -> do+ threadDelay briefdelay+ retryHelper "write to" err maxretries db retries ic $ + robustly a+ + briefdelay = 100000 -- 1/10th second + maxretries = 300 :: Int -- 30 seconds of briefdelay+ commitDb' :: DbHandle -> SqlPersistM () -> IO (Either SomeException ())-commitDb' (DbHandle _ jobs) a = do+commitDb' (DbHandle _ _ jobs) a = do debug "Database.Handle" "commitDb start" res <- newEmptyMVar putMVar jobs $ ChangeJob $@@ -117,7 +125,7 @@ | ChangeJob (SqlPersistM ()) | CloseJob -workerThread :: T.Text -> TableName -> MVar Job -> IO ()+workerThread :: RawFilePath -> TableName -> MVar Job -> IO () workerThread db tablename jobs = newconn where newconn = do@@ -144,45 +152,47 @@ getjob :: IO (Either BlockedIndefinitelyOnMVar Job) getjob = try $ takeMVar jobs- --- Like runSqlite, but more robust.------ New database connections can sometimes take a while to become usable.--- This may be due to WAL mode recovering after a crash, or perhaps a bug--- like described in blob 500f777a6ab6c45ca5f9790e0a63575f8e3cb88f.--- So, loop until a select succeeds; once one succeeds the connection will--- stay usable.------ And sqlite sometimes throws ErrorIO when there's not really an IO problem,--- but perhaps just a short read(). That's caught and retried several times.-runSqliteRobustly :: TableName -> T.Text -> (SqlPersistM a) -> IO a++{- Like runSqlite, but more robust.+ -+ - New database connections can sometimes take a while to become usable,+ - and selects will fail with ErrorBusy in the meantime. This may be due to+ - WAL mode recovering after a crash, or a concurrent writer.+ - So, wait until a select succeeds; once one succeeds the connection will+ - stay usable.+ -+ - Also sqlite sometimes throws ErrorIO when there's not really an IO+ - problem, but perhaps just a short read(). So also retry on ErrorIO.+ -+ - Retries repeatedly for up to 60 seconds. Part that point, it continues+ - retrying only if the database shows signs of being modified by another+ - process at least once each 30 seconds.+ -}+runSqliteRobustly :: TableName -> RawFilePath -> (SqlPersistM a) -> IO a runSqliteRobustly tablename db a = do- conn <- opensettle maxretries- go conn maxretries+ conn <- opensettle maxretries emptyDatabaseInodeCache+ go conn maxretries emptyDatabaseInodeCache where- maxretries = 100 :: Int- - rethrow msg e = throwIO $ userError $ show e ++ "(" ++ msg ++ ")"- - go conn retries = do+ go conn retries ic = do r <- try $ runResourceT $ runNoLoggingT $- withSqlConnRobustly (wrapConnection conn) $+ withSqlConnRobustly db (wrapConnection conn) $ runSqlConn a case r of Right v -> return v Left ex@(Sqlite.SqliteException { Sqlite.seError = e })- | e == Sqlite.ErrorIO ->- let retries' = retries - 1- in if retries' < 1- then rethrow "after successful open" ex- else go conn retries'- | otherwise -> rethrow "after successful open" ex+ | e == Sqlite.ErrorIO -> do+ briefdelay+ retryHelper "access" ex maxretries db retries ic $+ go conn+ | otherwise -> rethrow $ errmsg "after successful open" ex - opensettle retries = do- conn <- Sqlite.open db- settle conn retries+ opensettle retries ic = do+ conn <- Sqlite.open tdb+ settle conn retries ic - settle conn retries = do+ tdb = T.pack (fromRawFilePath db)++ settle conn retries ic = do r <- try $ do stmt <- Sqlite.prepare conn nullselect void $ Sqlite.step stmt@@ -190,27 +200,27 @@ case r of Right _ -> return conn Left ex@(Sqlite.SqliteException { Sqlite.seError = e })- | e == Sqlite.ErrorBusy -> do- -- Wait and retry any number of times; it - -- will stop being busy eventually.- briefdelay- settle conn retries- | e == Sqlite.ErrorIO -> do- -- Could be a real IO error,- -- so don't retry indefinitely.- Sqlite.close conn+ | e == Sqlite.ErrorBusy || e == Sqlite.ErrorIO -> do+ when (e == Sqlite.ErrorIO) $+ Sqlite.close conn briefdelay- let retries' = retries - 1- if retries' < 1- then rethrow "while opening database connection" ex- else opensettle retries'- | otherwise -> rethrow "while opening database connection" ex+ retryHelper "open" ex maxretries db retries ic $+ if e == Sqlite.ErrorIO+ then opensettle+ else settle conn+ | otherwise -> rethrow $ errmsg "while opening database connection" ex -- This should succeed for any table. nullselect = T.pack $ "SELECT null from " ++ tablename ++ " limit 1" briefdelay = threadDelay 1000 -- 1/1000th second+ + maxretries = 30000 :: Int -- 30 seconds of briefdelays+ + rethrow = throwIO . userError + errmsg msg e = show e ++ "(" ++ msg ++ ")"+ -- Like withSqlConn, but more robust. withSqlConnRobustly :: (MonadUnliftIO m@@ -219,45 +229,99 @@ , BaseBackend backend ~ SqlBackend , BackendCompatible SqlBackend backend )- => (LogFunc -> IO backend)+ => RawFilePath+ -> (LogFunc -> IO backend) -> (backend -> m a) -> m a-withSqlConnRobustly open f = do+withSqlConnRobustly db open f = do logFunc <- askLoggerIO withRunInIO $ \run -> bracket (open logFunc)- closeRobustly+ (closeRobustly db) (run . f) --- Sqlite can throw ErrorBusy while closing a database; this catches--- the exception and retries.+{- Sqlite can throw ErrorBusy while closing a database; this catches+ - the exception and retries.+ -+ - Retries repeatedly for up to 60 seconds. Part that point, it continues+ - retrying only if the database shows signs of being modified by another+ - process at least once each 30 seconds.+ -} closeRobustly :: (IsPersistBackend backend , BaseBackend backend ~ SqlBackend , BackendCompatible SqlBackend backend )- => backend+ => RawFilePath+ -> backend -> IO ()-closeRobustly conn = go maxretries briefdelay+closeRobustly db conn = go maxretries emptyDatabaseInodeCache where- briefdelay = 1000 -- 1/1000th second-- -- Try up to 14 times; with the delay doubling each time,- -- the maximum delay before giving up is 16 seconds.- maxretries = 14 :: Int-- go retries delay = do+ go retries ic = do r <- try $ close' conn case r of Right () -> return () Left ex@(Sqlite.SqliteException { Sqlite.seError = e }) | e == Sqlite.ErrorBusy -> do- threadDelay delay- let delay' = delay * 2- let retries' = retries - 1- if retries' < 1- then rethrow "while closing database connection" ex- else go retries' delay'- | otherwise -> rethrow "while closing database connection" ex+ threadDelay briefdelay+ retryHelper "close" ex maxretries db retries ic go+ | otherwise -> rethrow $ errmsg "while closing database connection" ex - rethrow msg e = throwIO $ userError $ show e ++ "(" ++ msg ++ ")"+ briefdelay = 1000 -- 1/1000th second+ + maxretries = 30000 :: Int -- 30 seconds of briefdelays+ + rethrow = throwIO . userError++ errmsg msg e = show e ++ "(" ++ msg ++ ")"++{- Retries a sqlite action repeatedly, but not forever. Detects situations+ - when another git-annex process is suspended and has the database locked,+ - and eventually gives up. The retries is the current number of retries+ - that are left. The maxretries is how many retries to make each time+ - the database is seen to have been modified by some other process.+ -}+retryHelper+ :: Show err + => String+ -> err+ -> Int+ -> RawFilePath+ -> Int+ -> DatabaseInodeCache+ -> (Int -> DatabaseInodeCache -> IO a)+ -> IO a+retryHelper action err maxretries db retries ic a = do+ let retries' = retries - 1+ if retries' < 1+ then do+ ic' <- getDatabaseInodeCache db+ if isDatabaseModified ic ic'+ then a maxretries ic'+ else giveup (databaseAccessStalledMsg action db err)+ else a retries' ic++databaseAccessStalledMsg :: Show err => String -> RawFilePath -> err -> String+databaseAccessStalledMsg action db err =+ "Repeatedly unable to " ++ action ++ " sqlite database " ++ fromRawFilePath db + ++ ": " ++ show err ++ ". "+ ++ "Perhaps another git-annex process is suspended and is "+ ++ "keeping this database locked?"++data DatabaseInodeCache = DatabaseInodeCache (Maybe InodeCache) (Maybe InodeCache)++emptyDatabaseInodeCache :: DatabaseInodeCache+emptyDatabaseInodeCache = DatabaseInodeCache Nothing Nothing++getDatabaseInodeCache :: RawFilePath -> IO DatabaseInodeCache+getDatabaseInodeCache db = DatabaseInodeCache+ <$> genInodeCache db noTSDelta+ <*> genInodeCache (db <> "-wal") noTSDelta++isDatabaseModified :: DatabaseInodeCache -> DatabaseInodeCache -> Bool+isDatabaseModified (DatabaseInodeCache a1 b1) (DatabaseInodeCache a2 b2) = + ismodified a1 a2 || ismodified b1 b2+ where+ ismodified (Just a) (Just b) = not (compareStrong a b)+ ismodified Nothing Nothing = False+ ismodified _ _ = True
Database/Keys.hs view
@@ -1,6 +1,6 @@ {- Sqlite database of information about Keys -- - Copyright 2015-2021 Joey Hess <id@joeyh.name>+ - Copyright 2015-2022 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -12,6 +12,7 @@ module Database.Keys ( DbHandle, closeDb,+ flushDb, addAssociatedFile, getAssociatedFiles, getAssociatedFilesIncluding,@@ -24,11 +25,13 @@ removeInodeCache, isInodeKnown, runWriter,+ updateDatabase, ) where import qualified Database.Keys.SQL as SQL import Database.Types import Database.Keys.Handle+import Database.Keys.Tables import qualified Database.Queue as H import Database.Init import Annex.Locations@@ -63,49 +66,53 @@ - If the database is already open, any writes are flushed to it, to ensure - consistency. -- - Any queued writes will be flushed before the read.+ - Any queued writes to the table will be flushed before the read. -}-runReader :: Monoid v => (SQL.ReadHandle -> Annex v) -> Annex v-runReader a = do+runReader :: Monoid v => DbTable -> (SQL.ReadHandle -> Annex v) -> Annex v+runReader t a = do h <- Annex.getRead Annex.keysdbhandle withDbState h go where go DbUnavailable = return (mempty, DbUnavailable)- go st@(DbOpen qh) = do- liftIO $ H.flushDbQueue qh+ go (DbOpen (qh, tableschanged)) = do+ tableschanged' <- if isDbTableChanged tableschanged t+ then do+ liftIO $ H.flushDbQueue qh+ return mempty+ else return tableschanged v <- a (SQL.ReadHandle qh)- return (v, st)+ return (v, DbOpen (qh, tableschanged')) go DbClosed = do- st' <- openDb False DbClosed- v <- case st' of- (DbOpen qh) -> a (SQL.ReadHandle qh)+ st <- openDb False DbClosed+ v <- case st of+ (DbOpen (qh, _)) -> a (SQL.ReadHandle qh) _ -> return mempty- return (v, st')+ return (v, st) -runReaderIO :: Monoid v => (SQL.ReadHandle -> IO v) -> Annex v-runReaderIO a = runReader (liftIO . a)+runReaderIO :: Monoid v => DbTable -> (SQL.ReadHandle -> IO v) -> Annex v+runReaderIO t a = runReader t (liftIO . a) {- Runs an action that writes to the database. Typically this is used to - queue changes, which will be flushed at a later point. - - The database is created if it doesn't exist yet. -}-runWriter :: (SQL.WriteHandle -> Annex ()) -> Annex ()-runWriter a = do+runWriter :: DbTable -> (SQL.WriteHandle -> Annex ()) -> Annex ()+runWriter t a = do h <- Annex.getRead Annex.keysdbhandle withDbState h go where- go st@(DbOpen qh) = do+ go (DbOpen (qh, tableschanged)) = do v <- a (SQL.WriteHandle qh)- return (v, st)+ return (v, DbOpen (qh, addDbTable tableschanged t)) go st = do st' <- openDb True st v <- case st' of- DbOpen qh -> a (SQL.WriteHandle qh)+ DbOpen (qh, _) -> a (SQL.WriteHandle qh) _ -> error "internal" return (v, st') -runWriterIO :: (SQL.WriteHandle -> IO ()) -> Annex ()-runWriterIO a = runWriter (liftIO . a)+runWriterIO :: DbTable -> (SQL.WriteHandle -> IO ()) -> Annex ()+runWriterIO t a = runWriter t (liftIO . a) {- Opens the database, creating it if it doesn't exist yet. -@@ -138,26 +145,29 @@ open db = do qh <- liftIO $ H.openDbQueue db SQL.containedTable- reconcileStaged qh- return $ DbOpen qh+ tc <- reconcileStaged qh+ return $ DbOpen (qh, tc) {- Closes the database if it was open. Any writes will be flushed to it. -- - This does not normally need to be called; the database will auto-close- - when the handle is garbage collected. However, this can be used to- - force a re-read of the database, in case another process has written- - data to it.+ - This does not prevent further use of the database; it will be re-opened+ - as necessary. -} closeDb :: Annex () closeDb = liftIO . closeDbHandle =<< Annex.getRead Annex.keysdbhandle +{- Flushes any queued writes to the database. -}+flushDb :: Annex ()+flushDb = liftIO . flushDbQueue =<< Annex.getRead Annex.keysdbhandle+ addAssociatedFile :: Key -> TopFilePath -> Annex ()-addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile k f+addAssociatedFile k f = runWriterIO AssociatedTable $ SQL.addAssociatedFile k f {- Note that the files returned were once associated with the key, but - some of them may not be any longer. -} getAssociatedFiles :: Key -> Annex [TopFilePath]-getAssociatedFiles k = emptyWhenBare $ runReaderIO $ SQL.getAssociatedFiles k+getAssociatedFiles k = emptyWhenBare $ runReaderIO AssociatedTable $+ SQL.getAssociatedFiles k {- Queries for associated files never return anything when in a bare - repository, since without a work tree there can be no associated files. @@ -183,10 +193,12 @@ {- Gets any keys that are on record as having a particular associated file. - (Should be one or none but the database doesn't enforce that.) -} getAssociatedKey :: TopFilePath -> Annex [Key]-getAssociatedKey f = emptyWhenBare $ runReaderIO $ SQL.getAssociatedKey f+getAssociatedKey f = emptyWhenBare $ runReaderIO AssociatedTable $+ SQL.getAssociatedKey f removeAssociatedFile :: Key -> TopFilePath -> Annex ()-removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile k+removeAssociatedFile k = runWriterIO AssociatedTable .+ SQL.removeAssociatedFile k {- Stats the files, and stores their InodeCaches. -} storeInodeCaches :: Key -> [RawFilePath] -> Annex ()@@ -195,7 +207,7 @@ =<< liftIO (mapM (\f -> genInodeCache f d) fs) addInodeCaches :: Key -> [InodeCache] -> Annex ()-addInodeCaches k is = runWriterIO $ SQL.addInodeCaches k is+addInodeCaches k is = runWriterIO ContentTable $ SQL.addInodeCaches k is {- A key may have multiple InodeCaches; one for the annex object, and one - for each pointer file that is a copy of it.@@ -207,18 +219,19 @@ - for pointer files, but none recorded for the annex object. -} getInodeCaches :: Key -> Annex [InodeCache]-getInodeCaches = runReaderIO . SQL.getInodeCaches+getInodeCaches = runReaderIO ContentTable . SQL.getInodeCaches {- Remove all inodes cached for a key. -} removeInodeCaches :: Key -> Annex ()-removeInodeCaches = runWriterIO . SQL.removeInodeCaches+removeInodeCaches = runWriterIO ContentTable . SQL.removeInodeCaches {- Remove cached inodes, for any key. -} removeInodeCache :: InodeCache -> Annex ()-removeInodeCache = runWriterIO . SQL.removeInodeCache+removeInodeCache = runWriterIO ContentTable . SQL.removeInodeCache isInodeKnown :: InodeCache -> SentinalStatus -> Annex Bool-isInodeKnown i s = or <$> runReaderIO ((:[]) <$$> SQL.isInodeKnown i s)+isInodeKnown i s = or <$> runReaderIO ContentTable + ((:[]) <$$> SQL.isInodeKnown i s) {- Looks at staged changes to annexed files, and updates the keys database, - so that its information is consistent with the state of the repository.@@ -247,18 +260,21 @@ - So when using getAssociatedFiles, have to make sure the file still - is an associated file. -}-reconcileStaged :: H.DbQueue -> Annex ()-reconcileStaged qh = unlessM (Git.Config.isBare <$> gitRepo) $ do- gitindex <- inRepo currentIndexFile- indexcache <- fromRawFilePath <$> calcRepo' gitAnnexKeysDbIndexCache- withTSDelta (liftIO . genInodeCache gitindex) >>= \case- Just cur -> readindexcache indexcache >>= \case- Nothing -> go cur indexcache =<< getindextree- Just prev -> ifM (compareInodeCaches prev cur)- ( noop- , go cur indexcache =<< getindextree- )- Nothing -> noop+reconcileStaged :: H.DbQueue -> Annex DbTablesChanged+reconcileStaged qh = ifM (Git.Config.isBare <$> gitRepo)+ ( return mempty+ , do+ gitindex <- inRepo currentIndexFile+ indexcache <- fromRawFilePath <$> calcRepo' gitAnnexKeysDbIndexCache+ withTSDelta (liftIO . genInodeCache gitindex) >>= \case+ Just cur -> readindexcache indexcache >>= \case+ Nothing -> go cur indexcache =<< getindextree+ Just prev -> ifM (compareInodeCaches prev cur)+ ( return mempty+ , go cur indexcache =<< getindextree+ )+ Nothing -> return mempty+ ) where lastindexref = Ref "refs/annex/last-index" @@ -283,6 +299,7 @@ -- against next time. inRepo $ update' lastindexref newtree fastDebug "Database.Keys" "reconcileStaged end"+ return (DbTablesChanged True True) -- git write-tree will fail if the index is locked or when there is -- a merge conflict. To get up-to-date with the current index, -- diff --staged with the old index tree. The current index tree@@ -304,6 +321,7 @@ void $ updatetodiff g Nothing "--staged" (procmergeconflictdiff mdfeeder) fastDebug "Database.Keys" "reconcileStaged end"+ return (DbTablesChanged True True) updatetodiff g old new processor = do (l, cleanup) <- pipeNullSplit' (diff old new) g@@ -479,3 +497,9 @@ largediff :: Int largediff = 1000 +{- Normally the keys database is updated incrementally when opened,+ - by reconcileStaged. Calling this explicitly allows running the+ - update at an earlier point.+ -}+updateDatabase :: Annex ()+updateDatabase = runWriter ContentTable (const noop)
Database/Keys/Handle.hs view
@@ -15,6 +15,7 @@ ) where import qualified Database.Queue as H+import Database.Keys.Tables import Utility.Exception import Utility.DebugLocks @@ -29,7 +30,7 @@ -- The database can be closed or open, but it also may have been -- tried to open (for read) and didn't exist yet or is not readable.-data DbState = DbClosed | DbOpen H.DbQueue | DbUnavailable+data DbState = DbClosed | DbOpen (H.DbQueue, DbTablesChanged) | DbUnavailable newDbHandle :: IO DbHandle newDbHandle = DbHandle <$> newMVar DbClosed@@ -52,15 +53,17 @@ return v flushDbQueue :: DbHandle -> IO ()-flushDbQueue (DbHandle mvar) = go =<< debugLocks (readMVar mvar)+flushDbQueue h = withDbState h go where- go (DbOpen qh) = H.flushDbQueue qh- go _ = return ()+ go (DbOpen (qh, _)) = do+ H.flushDbQueue qh+ return ((), DbOpen (qh, mempty))+ go st = return ((), st) closeDbHandle :: DbHandle -> IO () closeDbHandle h = withDbState h go where- go (DbOpen qh) = do+ go (DbOpen (qh, _)) = do H.closeDbQueue qh return ((), DbClosed) go st = return ((), st)
+ Database/Keys/Tables.hs view
@@ -0,0 +1,38 @@+{- Keeping track of which tables in the keys database have changed+ -+ - Copyright 2022 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Database.Keys.Tables where++import Data.Monoid+import qualified Data.Semigroup as Sem+import Prelude++data DbTable = AssociatedTable | ContentTable+ deriving (Eq, Show)++data DbTablesChanged = DbTablesChanged+ { associatedTable :: Bool+ , contentTable :: Bool+ }+ deriving (Show)++instance Sem.Semigroup DbTablesChanged where+ a <> b = DbTablesChanged+ { associatedTable = associatedTable a || associatedTable b+ , contentTable = contentTable a || contentTable b+ }++instance Monoid DbTablesChanged where+ mempty = DbTablesChanged False False++addDbTable :: DbTablesChanged -> DbTable -> DbTablesChanged+addDbTable ts AssociatedTable = ts { associatedTable = True }+addDbTable ts ContentTable = ts { contentTable = True }++isDbTableChanged :: DbTablesChanged -> DbTable -> Bool+isDbTableChanged ts AssociatedTable = associatedTable ts+isDbTableChanged ts ContentTable = contentTable ts
Logs/File.hs view
@@ -84,54 +84,32 @@ setAnnexFilePerm (toRawFilePath lf) -- | Checks the content of a log file to see if any line matches.------ This can safely be used while appendLogFile or any atomic--- action is concurrently modifying the file. It does not lock the file,--- for speed, but instead relies on the fact that a log file usually--- ends in a newline.-checkLogFile :: FilePath -> (L.ByteString -> Bool) -> Annex Bool-checkLogFile f matchf = bracket setup cleanup go+checkLogFile :: RawFilePath -> RawFilePath -> (L.ByteString -> Bool) -> Annex Bool+checkLogFile f lck matchf = withSharedLock lck $ bracket setup cleanup go where- setup = liftIO $ tryWhenExists $ openFile f ReadMode+ setup = liftIO $ tryWhenExists $ openFile f' ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = return False go (Just h) = do- !r <- liftIO (any matchf . fullLines <$> L.hGetContents h)+ !r <- liftIO (any matchf . L8.lines <$> L.hGetContents h) return r+ f' = fromRawFilePath f -- | Folds a function over lines of a log file to calculate a value.------ This can safely be used while appendLogFile or any atomic--- action is concurrently modifying the file. It does not lock the file,--- for speed, but instead relies on the fact that a log file usually--- ends in a newline.-calcLogFile :: FilePath -> t -> (L.ByteString -> t -> t) -> Annex t-calcLogFile f start update = bracket setup cleanup go+calcLogFile :: RawFilePath -> RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t+calcLogFile f lck start update = withSharedLock lck $ bracket setup cleanup go where- setup = liftIO $ tryWhenExists $ openFile f ReadMode+ setup = liftIO $ tryWhenExists $ openFile f' ReadMode cleanup Nothing = noop cleanup (Just h) = liftIO $ hClose h go Nothing = return start- go (Just h) = go' start =<< liftIO (fullLines <$> L.hGetContents h)+ go (Just h) = go' start =<< liftIO (L8.lines <$> L.hGetContents h) go' v [] = return v go' v (l:ls) = do let !v' = update l v go' v' ls---- | Gets only the lines that end in a newline. If the last part of a file--- does not, it's assumed to be a new line being logged that is incomplete,--- and is omitted.------ Unlike lines, this does not collapse repeated newlines etc.-fullLines :: L.ByteString -> [L.ByteString]-fullLines = go []- where- go c b = case L8.elemIndex '\n' b of- Nothing -> reverse c- Just n ->- let (l, b') = L.splitAt n b- in go (l:c) (L.drop 1 b')+ f' = fromRawFilePath f -- | Streams lines from a log file, passing each line to the processor, -- and then empties the file at the end.
Logs/Restage.hs view
@@ -47,7 +47,8 @@ calcRestageLog :: t -> ((TopFilePath, InodeCache) -> t -> t) -> Annex t calcRestageLog start update = do logf <- fromRepo gitAnnexRestageLog- calcLogFile (fromRawFilePath logf) start $ \l v -> + lckf <- fromRepo gitAnnexRestageLock+ calcLogFile logf lckf start $ \l v -> case parseRestageLog (decodeBL l) of Just pl -> update pl v Nothing -> v
Remote.hs view
@@ -144,7 +144,7 @@ | otherwise = return $ Just r byName' :: RemoteName -> Annex (Either String Remote)-byName' "" = return $ Left "no remote specified"+byName' "" = return $ Left "no repository name specified" byName' n = go . filter matching <$> remoteList where go [] = Left $ "there is no available git remote named \"" ++ n ++ "\""
Remote/Git.hs view
@@ -355,7 +355,8 @@ ":" ++ show e Annex.getState Annex.repo s <- newLocal r- liftIO $ Annex.eval s $ check `finally` stopCoProcesses+ liftIO $ Annex.eval s $ check+ `finally` quiesce True failedreadlocalconfig = do unless hasuuid $ case Git.remoteName r of@@ -449,7 +450,6 @@ Annex.Content.lockContentForRemoval key cleanup $ \lock -> do Annex.Content.removeAnnex lock cleanup- Annex.Content.saveState True , giveup "remote does not have expected annex.uuid value" ) | Git.repoIsHttp repo = giveup "dropping from http remote not supported"@@ -577,11 +577,9 @@ let checksuccess = liftIO checkio >>= \case Just err -> giveup err Nothing -> return True- res <- logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest ->+ logStatusAfter key $ Annex.Content.getViaTmp rsp verify key file $ \dest -> metered (Just (combineMeterUpdate meterupdate p)) key bwlimit $ \_ p' -> copier object (fromRawFilePath dest) key p' checksuccess verify- Annex.Content.saveState True- return res ) unless res $ giveup "failed to send content to remote"@@ -606,7 +604,7 @@ Annex.eval s $ do Annex.BranchState.disableUpdate ensureInitialized (pure [])- a `finally` stopCoProcesses+ a `finally` quiesce True data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar [(Annex.AnnexState, Annex.AnnexRead)]) @@ -618,8 +616,8 @@ {- Runs an action from the perspective of a local remote. - - The AnnexState is cached for speed and to avoid resource leaks.- - However, coprocesses are stopped after each call to avoid git- - processes hanging around on removable media.+ - However, it is quiesced after each call to avoid git processes+ - hanging around on removable media. - - The remote will be automatically initialized/upgraded first, - when possible.@@ -655,7 +653,7 @@ go ((st, rd), a') = do curro <- Annex.getState Annex.output let act = Annex.run (st { Annex.output = curro }, rd) $- a' `finally` stopCoProcesses+ a' `finally` quiesce True (ret, (st', _rd)) <- liftIO $ act `onException` cache (st, rd) liftIO $ cache (st', rd) return ret
Remote/S3.hs view
@@ -33,7 +33,6 @@ import Network.URI import Control.Monad.Trans.Resource import Control.Monad.Catch-import Data.IORef import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar import Data.Maybe@@ -217,7 +216,7 @@ , renameExport = renameExportS3 hdl this rs info } , importActions = ImportActions- { listImportableContents = listImportableContentsS3 hdl this info+ { listImportableContents = listImportableContentsS3 hdl this info c , importKey = Nothing , retrieveExportWithContentIdentifier = retrieveExportWithContentIdentifierS3 hdl this rs info , storeExportWithContentIdentifier = storeExportWithContentIdentifierS3 hdl this rs info magic@@ -549,8 +548,8 @@ srcobject = T.pack $ bucketExportLocation info src dstobject = T.pack $ bucketExportLocation info dest -listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))-listImportableContentsS3 hv r info =+listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize)))+listImportableContentsS3 hv r info c = withS3Handle hv $ \case Nothing -> giveup $ needS3Creds (uuid r) Just h -> Just <$> go h@@ -559,6 +558,8 @@ ic <- liftIO $ runResourceT $ extractFromResourceT =<< startlist h return (ImportableContentsComplete ic) + fileprefix = T.pack <$> getRemoteConfigValue fileprefixField c+ startlist h | versioning info = do rsp <- sendS3Handle h $ @@ -566,7 +567,8 @@ continuelistversioned h [] rsp | otherwise = do rsp <- sendS3Handle h $ - S3.getBucket (bucket info)+ (S3.getBucket (bucket info))+ { S3.gbPrefix = fileprefix } continuelistunversioned h [] rsp continuelistunversioned h l rsp@@ -574,6 +576,7 @@ rsp' <- sendS3Handle h $ (S3.getBucket (bucket info)) { S3.gbMarker = S3.gbrNextMarker rsp+ , S3.gbPrefix = fileprefix } continuelistunversioned h (rsp:l) rsp' | otherwise = return $@@ -585,6 +588,7 @@ (S3.getBucketObjectVersions (bucket info)) { S3.gbovKeyMarker = S3.gbovrNextKeyMarker rsp , S3.gbovVersionIdMarker = S3.gbovrNextVersionIdMarker rsp+ , S3.gbovPrefix = fileprefix } continuelistversioned h (rsp:l) rsp' | otherwise = return $@@ -1071,11 +1075,10 @@ skipescape c = isUnescapedInURIComponent c genCredentials :: CredPair -> IO AWS.Credentials-genCredentials (keyid, secret) = AWS.Credentials- <$> pure (tobs keyid)- <*> pure (tobs secret)- <*> newIORef []- <*> (fmap tobs <$> getEnv "AWS_SESSION_TOKEN")+genCredentials (keyid, secret) = do+ cr <- AWS.makeCredentials (tobs keyid) (tobs secret)+ tk <- fmap tobs <$> getEnv "AWS_SESSION_TOKEN"+ return (cr { AWS.iamToken = tk }) where tobs = T.encodeUtf8 . T.pack
Test.hs view
@@ -130,9 +130,9 @@ : concatMap mkrepotests testmodes where testmodes = catMaybes- [ canadjust ("v8 adjusted unlocked branch", (testMode opts (RepoVersion 8)) { adjustedUnlockedBranch = True })- , unlesscrippled ("v8 unlocked", (testMode opts (RepoVersion 8)) { unlockedFiles = True })- , unlesscrippled ("v8 locked", testMode opts (RepoVersion 8))+ [ canadjust ("v10 adjusted unlocked branch", (testMode opts (RepoVersion 10)) { adjustedUnlockedBranch = True })+ , unlesscrippled ("v10 unlocked", (testMode opts (RepoVersion 10)) { unlockedFiles = True })+ , unlesscrippled ("v10 locked", testMode opts (RepoVersion 10)) ] remotetestmode = testMode opts (RepoVersion 8) unlesscrippled v
Types/Remote.hs view
@@ -270,9 +270,10 @@ -- Can throw exception if unable to access remote, or if remote -- refuses to remove the content. , removeExport :: Key -> ExportLocation -> a ()- -- Set when the content of a Key stored in the remote to an- -- ExportLocation and then removed with removeExport remains- -- accessible to retrieveKeyFile and checkPresent.+ -- Set when the remote is versioned, so once a Key is stored+ -- to an ExportLocation, a subsequent deletion of that+ -- ExportLocation leaves the key still accessible to retrieveKeyFile+ -- and checkPresent. , versionedExport :: Bool -- Removes an exported directory. Typically the directory will be -- empty, but it could possibly contain files or other directories,
Upgrade/V7.hs view
@@ -16,6 +16,7 @@ import Annex.CatFile import qualified Database.Keys import qualified Database.Keys.SQL+import Database.Keys.Tables import qualified Git.LsFiles as LsFiles import qualified Git import Git.FilePath@@ -114,8 +115,9 @@ Nothing -> noop Just k -> do topf <- inRepo $ toTopFilePath $ toRawFilePath f- Database.Keys.runWriter $ \h -> liftIO $ do+ Database.Keys.runWriter AssociatedTable $ \h -> liftIO $ Database.Keys.SQL.addAssociatedFile k topf h+ Database.Keys.runWriter ContentTable $ \h -> liftIO $ Database.Keys.SQL.addInodeCaches k [ic] h liftIO $ void cleanup Database.Keys.closeDb
Utility/Su.hs view
@@ -57,9 +57,9 @@ describePasswordPrompt' (Just (SuCommand p _ _)) = describePasswordPrompt p describePasswordPrompt' Nothing = Nothing -runSuCommand :: (Maybe SuCommand) -> IO Bool-runSuCommand (Just (SuCommand _ cmd ps)) = boolSystem cmd ps-runSuCommand Nothing = return False+runSuCommand :: (Maybe SuCommand) -> Maybe [(String, String)] -> IO Bool+runSuCommand (Just (SuCommand _ cmd ps)) environ = boolSystemEnv cmd ps environ+runSuCommand Nothing _ = return False -- Generates a SuCommand that runs a command as root, fairly portably. --
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 10.20221003+Version: 10.20221103 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -830,6 +830,7 @@ Database.Init Database.Keys Database.Keys.Handle+ Database.Keys.Tables Database.Keys.SQL Database.Queue Database.Types