git-annex 8.20211123 → 8.20211231
raw patch · 44 files changed
+859/−419 lines, 44 files
Files
- Annex/Branch.hs +169/−77
- Annex/Branch/Transitions.hs +4/−11
- Annex/BranchState.hs +40/−18
- Annex/Concurrent.hs +0/−1
- Annex/Ingest.hs +12/−13
- Annex/Init.hs +4/−1
- Annex/LockPool/PosixOrPid.hs +12/−12
- Annex/MetaData.hs +9/−6
- Annex/PidLock.hs +4/−4
- Annex/Queue.hs +2/−1
- Assistant/DeleteRemote.hs +5/−5
- Assistant/Sync.hs +3/−2
- Assistant/Threads/Merger.hs +3/−2
- CHANGELOG +26/−0
- CmdLine/Seek.hs +17/−4
- Command/AddUrl.hs +21/−19
- Command/Export.hs +14/−5
- Command/FilterBranch.hs +2/−1
- Command/ImportFeed.hs +14/−4
- Command/Info.hs +17/−11
- Command/Log.hs +20/−17
- Command/P2P.hs +3/−23
- Command/Sync.hs +26/−18
- Command/Unused.hs +3/−1
- Git/Command.hs +1/−1
- Git/LsFiles.hs +1/−1
- Git/Queue.hs +46/−12
- Git/Repair.hs +1/−1
- Logs/Location.hs +15/−12
- Logs/Transitions.hs +9/−1
- Remote/Glacier.hs +2/−1
- Test.hs +23/−13
- Test/Framework.hs +22/−1
- Types/BranchState.hs +13/−3
- Types/Transitions.hs +19/−0
- Utility/FileSystemEncoding.hs +8/−8
- Utility/LockFile/PidLock.hs +49/−32
- Utility/LockPool/LockHandle.hs +20/−17
- Utility/LockPool/PidLock.hs +106/−15
- Utility/LockPool/Posix.hs +11/−11
- Utility/LockPool/STM.hs +67/−24
- Utility/LockPool/Windows.hs +7/−7
- doc/git-annex.mdwn +7/−2
- git-annex.cabal +2/−1
Annex/Branch.hs view
@@ -20,6 +20,7 @@ updateTo, get, getHistorical,+ getUnmergedRefs, RegardingUUID(..), change, maybeChange,@@ -27,7 +28,6 @@ createMessage, commit, forceCommit,- getBranch, files, rememberTreeish, performTransitions,@@ -80,6 +80,7 @@ import Logs.Export.Pure import Logs.Difference.Pure import qualified Annex.Queue+import Types.Transitions import Annex.Branch.Transitions import qualified Annex import Annex.Hook@@ -141,17 +142,12 @@ {- Ensures that the branch and index are up-to-date; should be - called before data is read from it. Runs only once per git-annex run. -} update :: Annex BranchState-update = runUpdateOnce $ journalClean <$$> updateTo =<< siblingBranches+update = runUpdateOnce $ updateTo =<< siblingBranches {- Forces an update even if one has already been run. -} forceUpdate :: Annex UpdateMade forceUpdate = updateTo =<< siblingBranches -data UpdateMade = UpdateMade- { refsWereMerged :: Bool- , journalClean :: Bool- }- {- Merges the specified Refs into the index, if they have any changes not - already in it. The Branch names are only used in the commit message; - it's even possible that the provided Branches have not been updated to@@ -167,8 +163,6 @@ - - Also handles performing any Transitions that have not yet been - performed, in either the local branch, or the Refs.- -- - Returns True if any refs were merged in, False otherwise. -} updateTo :: [(Git.Sha, Git.Branch)] -> Annex UpdateMade updateTo pairs = ifM (annexMergeAnnexBranches <$> Annex.getGitConfig)@@ -180,7 +174,6 @@ updateTo' pairs = do -- ensure branch exists, and get its current ref branchref <- getBranch- dirty <- journalDirty gitAnnexJournalDir ignoredrefs <- getIgnoredRefs let unignoredrefs = excludeset ignoredrefs pairs tomerge <- if null unignoredrefs@@ -188,50 +181,60 @@ else do mergedrefs <- getMergedRefs filterM isnewer (excludeset mergedrefs unignoredrefs)- journalcleaned <- if null tomerge- {- Even when no refs need to be merged, the index- - may still be updated if the branch has gotten ahead - - of the index, or just if the journal is dirty. -}- then ifM (needUpdateIndex branchref)- ( lockJournal $ \jl -> do- forceUpdateIndex jl branchref- {- When there are journalled changes- - as well as the branch being updated,- - a commit needs to be done. -}- when dirty $- go branchref dirty [] jl- return True- , if dirty- then ifM (annexAlwaysCommit <$> Annex.getGitConfig)- ( do- lockJournal $ go branchref dirty []- return True- , return False- )- else return True- )- else do- lockJournal $ go branchref dirty tomerge- return True- journalclean <- if journalcleaned- then not <$> privateUUIDsKnown- else pure False- return $ UpdateMade- { refsWereMerged = not (null tomerge)- , journalClean = journalclean - }+ {- In a read-only repository, catching permission denied lets+ - query operations still work, although they will need to do+ - additional work since the refs are not merged. -}+ catchPermissionDenied+ (const (updatefailedperms tomerge))+ (go branchref tomerge) where excludeset s = filter (\(r, _) -> S.notMember r s)+ isnewer (r, _) = inRepo $ Git.Branch.changed fullname r- go branchref dirty tomerge jl = stagejournalwhen dirty jl $ do++ go branchref tomerge = do+ dirty <- journalDirty gitAnnexJournalDir+ journalcleaned <- if null tomerge+ {- Even when no refs need to be merged, the index+ - may still be updated if the branch has gotten ahead + - of the index, or just if the journal is dirty. -}+ then ifM (needUpdateIndex branchref)+ ( lockJournal $ \jl -> do+ forceUpdateIndex jl branchref+ {- When there are journalled changes+ - as well as the branch being updated,+ - a commit needs to be done. -}+ when dirty $+ go' branchref dirty [] jl+ return True+ , if dirty+ then ifM (annexAlwaysCommit <$> Annex.getGitConfig)+ ( lockJournal $ \jl -> do+ go' branchref dirty [] jl+ return True+ , return False+ )+ else return True+ )+ else lockJournal $ \jl -> do+ go' branchref dirty tomerge jl+ return True+ journalclean <- if journalcleaned+ then not <$> privateUUIDsKnown+ else pure False+ return $ UpdateMade+ { refsWereMerged = not (null tomerge)+ , journalClean = journalclean + }+ + go' branchref dirty tomerge jl = stagejournalwhen dirty jl $ do let (refs, branches) = unzip tomerge merge_desc <- if null tomerge then commitMessage else return $ "merging " ++ unwords (map Git.Ref.describe branches) ++ " into " ++ fromRef name- localtransitions <- parseTransitionsStrictly "local"- <$> getLocal transitionsLog+ localtransitions <- getLocalTransitions unless (null tomerge) $ do showSideAction merge_desc mapM_ checkBranchDifferences refs@@ -249,28 +252,86 @@ ) addMergedRefs tomerge invalidateCache+ stagejournalwhen dirty jl a | dirty = stageJournal jl a | otherwise = withIndex a+ + -- Preparing for read-only branch access with unmerged remote refs.+ updatefailedperms tomerge = do+ let refs = map fst tomerge+ -- Gather any transitions that are new to either the+ -- local branch or a remote ref, which will need to be+ -- applied on the fly.+ localts <- getLocalTransitions+ remotets <- mapM getRefTransitions refs+ ts <- if all (localts ==) remotets+ then return []+ else + let tcs = mapMaybe getTransitionCalculator $+ knownTransitionList $+ combineTransitions (localts:remotets)+ in if null tcs+ then return []+ else do+ config <- Annex.getGitConfig+ trustmap <- calcTrustMap <$> getStaged trustLog+ remoteconfigmap <- calcRemoteConfigMap <$> getStaged remoteLog+ return $ map (\c -> c trustmap remoteconfigmap config) tcs+ return $ UpdateFailedPermissions + { refsUnmerged = refs+ , newTransitions = ts+ } {- Gets the content of a file, which may be in the journal, or in the index- - (and committed to the branch).+ - (and committed to the branch). + -+ - Returns an empty string if the file doesn't exist yet. - - Updates the branch if necessary, to ensure the most up-to-date available- - content is returned.+ - content is returned. -- - Returns an empty string if the file doesn't exist yet. -}+ - When permissions prevented updating the branch, reads the content from the+ - journal, plus the branch, plus all unmerged refs. In this case, any+ - transitions that have not been applied to all refs will be applied on+ - the fly.+ -} get :: RawFilePath -> Annex L.ByteString-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+get file = do+ st <- update+ case getCache file st of+ Just content -> return content+ Nothing -> do+ content <- if journalIgnorable st+ then getRef fullname file+ else if null (unmergedRefs st) + then getLocal file+ else unmergedbranchfallback st+ setCache file content+ return content+ where+ unmergedbranchfallback st = do+ l <- getLocal file+ bs <- forM (unmergedRefs st) $ \ref -> getRef ref file+ let content = l <> mconcat bs+ return $ applytransitions (unhandledTransitions st) content+ applytransitions [] content = content+ applytransitions (changer:rest) content = case changer file content of+ PreserveFile -> applytransitions rest content+ ChangeFile builder -> do+ let content' = toLazyByteString builder+ if L.null content'+ -- File is deleted, can't run any other+ -- transitions on it.+ then content'+ else applytransitions rest content' +{- When the git-annex branch is unable to be updated due to permissions,+ - and there are other git-annex branches that have not been merged into+ - it, this gets the refs of those branches. -}+getUnmergedRefs :: Annex [Git.Ref]+getUnmergedRefs = unmergedRefs <$> update+ {- Used to cache the value of a file, which has been read from the branch - using some optimised method. The journal has to be checked, in case - it has a newer version of the file that has not reached the branch yet.@@ -285,7 +346,7 @@ JournalledContent journalcontent -> journalcontent PossiblyStaleJournalledContent journalcontent -> branchcontent <> journalcontent- Annex.BranchState.setCache file content+ setCache file content {- Like get, but does not merge the branch, so the info returned may not - reflect changes in remotes.@@ -451,16 +512,28 @@ commitIndex' jl committedref racemessage basemessage retrynum' [committedref] {- Lists all files on the branch. including ones in the journal- - that have not been committed yet. There may be duplicates in the list. -}-files :: Annex ([RawFilePath], IO Bool)+ - that have not been committed yet. + -+ - There may be duplicates in the list, when the journal has files that+ - have not been written to the branch yet.+ - + - In a read-only repository that has other git-annex branches that have+ - not been merged in, returns Nothing, because it's not possible to+ - efficiently handle that.+ -}+files :: Annex (Maybe ([RawFilePath], IO Bool)) files = do- _ <- update- (bfs, cleanup) <- branchFiles- -- ++ forces the content of the first list to be buffered in- -- memory, so use journalledFiles, which should be much smaller- -- most of the time. branchFiles will stream as the list is consumed.- l <- (++) <$> journalledFiles <*> pure bfs- return (l, cleanup)+ st <- update+ if not (null (unmergedRefs st))+ then return Nothing+ else do+ (bfs, cleanup) <- branchFiles+ -- ++ forces the content of the first list to be+ -- buffered in memory, so use journalledFiles,+ -- which should be much smaller most of the time.+ -- branchFiles will stream as the list is consumed.+ l <- (++) <$> journalledFiles <*> pure bfs+ return (Just (l, cleanup)) {- Lists all files currently in the journal. There may be duplicates in - the list when using a private journal. -}@@ -605,6 +678,11 @@ removeWhenExistsWith (R.removeLink) (toRawFilePath jlogf) openjlog tmpdir = liftIO $ openTmpFileIn tmpdir "jlog" +getLocalTransitions :: Annex Transitions+getLocalTransitions = + parseTransitionsStrictly "local"+ <$> getLocal transitionsLog+ {- This is run after the refs have been merged into the index, - but before the result is committed to the branch. - (Which is why it's passed the contents of the local branches's@@ -623,22 +701,17 @@ -} handleTransitions :: JournalLocked -> Transitions -> [Git.Ref] -> Annex Bool handleTransitions jl localts refs = do- m <- M.fromList <$> mapM getreftransition refs- let remotets = M.elems m+ remotets <- mapM getRefTransitions refs if all (localts ==) remotets then return False else do+ let m = M.fromList (zip refs remotets) let allts = combineTransitions (localts:remotets) let (transitionedrefs, untransitionedrefs) = partition (\r -> M.lookup r m == Just allts) refs performTransitionsLocked jl allts (localts /= allts) transitionedrefs ignoreRefs untransitionedrefs return True- where- getreftransition ref = do- ts <- parseTransitionsStrictly "remote"- <$> catFile ref transitionsLog- return (ref, ts) {- Performs the specified transitions on the contents of the index file, - commits it to the branch, or creates a new branch.@@ -803,13 +876,32 @@ - The action is passed a callback that it can repeatedly call to read - the next file and its contents. When there are no more files, the - callback will return Nothing.+ -+ - In some cases the callback may return the same file more than once,+ - with different content. This happens rarely, only when the journal+ - contains additional information, and the last version of the+ - file it returns is the most current one.+ -+ - In a read-only repository that has other git-annex branches that have+ - not been merged in, returns Nothing, because it's not possible to+ - efficiently handle that. -} overBranchFileContents :: (RawFilePath -> Maybe v) -> (Annex (Maybe (v, RawFilePath, Maybe L.ByteString)) -> Annex a)- -> Annex a+ -> Annex (Maybe a) overBranchFileContents select go = do st <- update+ if not (null (unmergedRefs st))+ then return Nothing+ else Just <$> overBranchFileContents' select go st++overBranchFileContents'+ :: (RawFilePath -> Maybe v)+ -> (Annex (Maybe (v, RawFilePath, Maybe L.ByteString)) -> Annex a)+ -> BranchState+ -> Annex a+overBranchFileContents' select go st = do g <- Annex.gitRepo (l, cleanup) <- inRepo $ Git.LsTree.lsTree Git.LsTree.LsTreeRecursive@@ -819,7 +911,7 @@ buf <- liftIO newEmptyMVar let go' reader = go $ liftIO reader >>= \case Just ((v, f), content) -> do- content' <- checkjournal st f content+ content' <- checkjournal f content return (Just (v, f, content')) Nothing | journalIgnorable st -> return Nothing@@ -836,7 +928,7 @@ `finally` liftIO (void cleanup) where -- Check the journal, in case it did not get committed to the branch- checkjournal st f branchcontent+ checkjournal f branchcontent | journalIgnorable st = return branchcontent | otherwise = getJournalFileStale (GetPrivate True) f >>= return . \case NoJournalledContent -> branchcontent
Annex/Branch/Transitions.hs view
@@ -6,7 +6,6 @@ -} module Annex.Branch.Transitions (- FileTransition(..), getTransitionCalculator, filterBranch, ) where@@ -23,23 +22,17 @@ import Types.UUID import Types.MetaData import Types.Remote+import Types.Transitions import Types.GitConfig (GitConfig) import Types.ProposedAccepted import Annex.SpecialRemote.Config import qualified Data.Map as M import qualified Data.Set as S-import qualified Data.ByteString.Lazy as L import qualified Data.Attoparsec.ByteString.Lazy as A import Data.ByteString.Builder -data FileTransition- = ChangeFile Builder- | PreserveFile--type TransitionCalculator = GitConfig -> RawFilePath -> L.ByteString -> FileTransition--getTransitionCalculator :: Transition -> Maybe (TrustMap -> M.Map UUID RemoteConfig -> TransitionCalculator)+getTransitionCalculator :: Transition -> Maybe (TrustMap -> M.Map UUID RemoteConfig -> GitConfig -> TransitionCalculator) getTransitionCalculator ForgetGitHistory = Nothing getTransitionCalculator ForgetDeadRemotes = Just dropDead @@ -55,7 +48,7 @@ -- the latter uuid, that also needs to be removed. The sameas-uuid -- is not removed from the remote log, for the same reason the trust log -- is not changed.-dropDead :: TrustMap -> M.Map UUID RemoteConfig -> TransitionCalculator+dropDead :: TrustMap -> M.Map UUID RemoteConfig -> GitConfig -> TransitionCalculator dropDead trustmap remoteconfigmap gc f content | f == trustLog = PreserveFile | f == remoteLog = ChangeFile $@@ -78,7 +71,7 @@ | otherwise = l minimizesameasdead' c = M.restrictKeys c (S.singleton sameasUUIDField) -filterBranch :: (UUID -> Bool) -> TransitionCalculator+filterBranch :: (UUID -> Bool) -> GitConfig -> TransitionCalculator filterBranch wantuuid gc f content = case getLogVariety gc f of Just OldUUIDBasedLog -> ChangeFile $ UUIDBased.buildLogOld byteString $
Annex/BranchState.hs view
@@ -2,7 +2,7 @@ - - Runtime state about the git-annex branch, and a small cache. -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -11,8 +11,10 @@ import Annex.Common import Types.BranchState+import Types.Transitions import qualified Annex import Logs+import qualified Git import qualified Data.ByteString.Lazy as L @@ -30,29 +32,49 @@ a changeState $ \s -> s { indexChecked = True } +data UpdateMade + = UpdateMade+ { refsWereMerged :: Bool+ , journalClean :: Bool+ }+ | UpdateFailedPermissions+ { refsUnmerged :: [Git.Sha]+ , newTransitions :: [TransitionCalculator]+ }+ {- Runs an action to update the branch, if it's not been updated before - in this run of git-annex. -- - The action should return True if anything that was in the journal- - before got staged (or if the journal was empty). That lets an opmisation- - be done: The journal then does not need to be checked going forward,- - until new information gets written to it.- - - When interactive access is enabled, the journal is always checked when - reading values from the branch, and so this does not need to update - the branch.+ -+ - When the action leaves the journal clean, by staging anything that+ - was in it, an optimisation is enabled: The journal does not need to+ - be checked going forward, until new information gets written to it.+ -+ - When the action is unable to update the branch due to a permissions+ - problem, -}-runUpdateOnce :: Annex Bool -> Annex BranchState-runUpdateOnce a = do+runUpdateOnce :: Annex UpdateMade -> Annex BranchState+runUpdateOnce update = do st <- getState if branchUpdated st || needInteractiveAccess st then return st else do- journalstaged <- a- let stf = \st' -> st'- { branchUpdated = True- , journalIgnorable = journalstaged - }+ um <- update+ let stf = case um of+ UpdateMade {} -> \st' -> st'+ { branchUpdated = True+ , journalIgnorable = journalClean um+ }+ UpdateFailedPermissions {} -> \st' -> st'+ { branchUpdated = True+ , journalIgnorable = False+ , unmergedRefs = refsUnmerged um+ , unhandledTransitions = newTransitions um+ , cachedFileContents = []+ } changeState stf return (stf st) @@ -98,13 +120,13 @@ | 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+getCache :: RawFilePath -> BranchState -> Maybe L.ByteString+getCache file state = go (cachedFileContents state) where- go [] _ = Nothing- go ((f,c):rest) state+ go [] = Nothing+ go ((f,c):rest) | f == file && not (needInteractiveAccess state) = Just c- | otherwise = go rest state+ | otherwise = go rest invalidateCache :: Annex () invalidateCache = changeState $ \s -> s { cachedFileContents = [] }
Annex/Concurrent.hs view
@@ -14,7 +14,6 @@ import Annex.Common import Annex.Concurrent.Utility import qualified Annex.Queue-import Annex.Action import Types.Concurrency import Types.CatFileHandles import Annex.CatFile
Annex/Ingest.hs view
@@ -184,18 +184,17 @@ ms <- liftIO $ catchMaybeIO $ R.getFileStatus src mcache <- maybe (pure Nothing) (liftIO . toInodeCache delta src) ms case (mcache, inodeCache source) of- (_, Nothing) -> go k mcache ms- (Just newc, Just c) | compareStrong c newc -> go k mcache ms+ (_, Nothing) -> go k mcache+ (Just newc, Just c) | compareStrong c newc -> go k mcache _ -> failure "changed while it was being added" where- go key mcache (Just s)- | lockingFile cfg = golocked key mcache s- | otherwise = gounlocked key mcache s- go _ _ Nothing = failure "failed to generate a key"+ go key mcache+ | lockingFile cfg = golocked key mcache+ | otherwise = gounlocked key mcache - golocked key mcache s =+ golocked key mcache = tryNonAsync (moveAnnex key naf (contentLocation source)) >>= \case- Right True -> success key mcache s + Right True -> success key mcache Right False -> giveup "failed to add content to annex" Left e -> restoreFile (keyFilename source) key e @@ -205,7 +204,7 @@ -- file, so provide it nothing. naf = AssociatedFile Nothing - gounlocked key (Just cache) s = do+ gounlocked key (Just cache) = do -- Remove temp directory hard link first because -- linkToAnnex falls back to copying if a file -- already has a hard link.@@ -215,11 +214,11 @@ LinkAnnexFailed -> failure "failed to link to annex" lar -> do finishIngestUnlocked' key source restage (Just lar)- success key (Just cache) s- gounlocked _ _ _ = failure "failed statting file"+ success key (Just cache)+ gounlocked _ _ = failure "failed statting file" - success k mcache s = do- genMetaData k (keyFilename source) s+ success k mcache = do+ genMetaData k (keyFilename source) (fmap inodeCacheToMtime mcache) return (Just k, mcache) failure msg = do
Annex/Init.hs view
@@ -200,7 +200,10 @@ where needsinit = ifM autoInitializeAllowed ( do- initialize True Nothing Nothing+ tryNonAsync (initialize True Nothing Nothing) >>= \case+ Right () -> noop+ Left e -> giveup $ show e ++ "\n" +++ "git-annex: automatic initialization failed due to above problems" autoEnableSpecialRemotes , giveup "First run: git-annex init" )
Annex/LockPool/PosixOrPid.hs view
@@ -1,7 +1,7 @@ {- Wraps Utility.LockPool, making pid locks be used when git-annex is so - configured. -- - Copyright 2015-2020 Joey Hess <id@joeyh.name>+ - Copyright 2015-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -28,7 +28,7 @@ import qualified Utility.LockPool.LockHandle as H import Utility.LockPool.LockHandle (LockHandle, dropLock) import Utility.LockFile.Posix (openLockFile)-import Utility.LockPool.STM (LockFile)+import Utility.LockPool.STM (LockFile, LockMode(..)) import Utility.LockFile.LockStatus import Config (pidLockFile) import Messages (warning)@@ -36,16 +36,16 @@ import System.Posix lockShared :: Maybe FileMode -> LockFile -> Annex LockHandle-lockShared m f = pidLock m f $ Posix.lockShared m f+lockShared m f = pidLock m f LockShared $ Posix.lockShared m f lockExclusive :: Maybe FileMode -> LockFile -> Annex LockHandle-lockExclusive m f = pidLock m f $ Posix.lockExclusive m f+lockExclusive m f = pidLock m f LockExclusive $ Posix.lockExclusive m f tryLockShared :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)-tryLockShared m f = tryPidLock m f $ Posix.tryLockShared m f+tryLockShared m f = tryPidLock m f LockShared $ Posix.tryLockShared m f tryLockExclusive :: Maybe FileMode -> LockFile -> Annex (Maybe LockHandle)-tryLockExclusive m f = tryPidLock m f $ Posix.tryLockExclusive m f+tryLockExclusive m f = tryPidLock m f LockExclusive $ Posix.tryLockExclusive m f checkLocked :: LockFile -> Annex (Maybe Bool) checkLocked f = Posix.checkLocked f `pidLockCheck` checkpid@@ -67,22 +67,22 @@ pidLockCheck posixcheck pidcheck = debugLocks $ liftIO . maybe posixcheck pidcheck =<< pidLockFile -pidLock :: Maybe FileMode -> LockFile -> IO LockHandle -> Annex LockHandle-pidLock m f posixlock = debugLocks $ go =<< pidLockFile+pidLock :: Maybe FileMode -> LockFile -> LockMode -> IO LockHandle -> Annex LockHandle+pidLock m f lockmode posixlock = debugLocks $ go =<< pidLockFile where go Nothing = liftIO posixlock go (Just pidlock) = do timeout <- annexPidLockTimeout <$> Annex.getGitConfig liftIO $ dummyPosixLock m f- Pid.waitLock timeout pidlock warning+ Pid.waitLock f lockmode timeout pidlock warning -tryPidLock :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle)-tryPidLock m f posixlock = debugLocks $ liftIO . go =<< pidLockFile+tryPidLock :: Maybe FileMode -> LockFile -> LockMode -> IO (Maybe LockHandle) -> Annex (Maybe LockHandle)+tryPidLock m f lockmode posixlock = debugLocks $ liftIO . go =<< pidLockFile where go Nothing = posixlock go (Just pidlock) = do dummyPosixLock m f- Pid.tryLock pidlock+ Pid.tryLock f lockmode pidlock -- The posix lock file is created even when using pid locks, in order to -- avoid complicating any code that might expect to be able to see that
Annex/MetaData.hs view
@@ -37,8 +37,8 @@ - - Also, can generate new metadata, if configured to do so. -}-genMetaData :: Key -> RawFilePath -> FileStatus -> Annex ()-genMetaData key file status = do+genMetaData :: Key -> RawFilePath -> Maybe POSIXTime -> Annex ()+genMetaData key file mmtime = do catKeyFileHEAD file >>= \case Nothing -> noop Just oldkey ->@@ -47,11 +47,14 @@ -- preserve any metadata already on key. whenM (copyMetaData oldkey key <&&> (not <$> onlydatemeta oldkey)) $ warncopied- whenM (annexGenMetaData <$> Annex.getGitConfig) $ do- old <- getCurrentMetaData key- addMetaData key (dateMetaData mtime old)+ whenM (annexGenMetaData <$> Annex.getGitConfig) $+ case mmtime of+ Just mtime -> do+ old <- getCurrentMetaData key+ addMetaData key $+ dateMetaData (posixSecondsToUTCTime mtime) old+ Nothing -> noop where- mtime = posixSecondsToUTCTime $ realToFrac $ modificationTime status warncopied = warning $ "Copied metadata from old version of " ++ fromRawFilePath file ++ " to new version. " ++ "If you don't want this copied metadata, run: git annex metadata --remove-all " ++ fromRawFilePath file
Annex/PidLock.hs view
@@ -1,6 +1,6 @@ {- Pid locking support. -- - Copyright 2014-2020 Joey Hess <id@joeyh.name>+ - Copyright 2014-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -53,7 +53,7 @@ cleanup (go gonopidlock p pidlock) where- setup pidlock = PidP.tryLock pidlock+ setup pidlock = fmap fst <$> PidP.tryLock' pidlock cleanup (Just h) = dropLock h cleanup Nothing = return ()@@ -83,7 +83,7 @@ Nothing -> a Just pidlock -> bracket (setup pidlock) cleanup (go pidlock) where- setup pidlock = liftIO $ PidP.tryLock pidlock+ setup pidlock = liftIO $ fmap fst <$> PidP.tryLock' pidlock cleanup (Just h) = liftIO $ dropLock h cleanup Nothing = return ()@@ -112,7 +112,7 @@ Nothing -> liftIO $ a r Just pidlock -> liftIO $ bracket (setup pidlock) cleanup (go pidlock) where- setup pidlock = PidP.tryLock pidlock+ setup pidlock = fmap fst <$> PidP.tryLock' pidlock cleanup (Just h) = dropLock h cleanup Nothing = return ()
Annex/Queue.hs view
@@ -78,7 +78,8 @@ new :: Annex (Git.Queue.Queue Annex) new = do- q <- Git.Queue.new . annexQueueSize <$> getGitConfig+ sz <- annexQueueSize <$> getGitConfig+ q <- liftIO $ Git.Queue.new sz Nothing store q return q
Assistant/DeleteRemote.hs view
@@ -53,14 +53,14 @@ - in keys in the current branch. -} removableRemote :: UrlRenderer -> UUID -> Assistant ()-removableRemote urlrenderer uuid = do- keys <- getkeys- if null keys- then finishRemovingRemote urlrenderer uuid- else do+removableRemote urlrenderer uuid = getkeys >>= \case+ Just keys+ | null keys -> finishRemovingRemote urlrenderer uuid+ | otherwise -> do r <- fromMaybe (error "unknown remote") <$> liftAnnex (Remote.remoteFromUUID uuid) mapM_ (queueremaining r) keys+ Nothing -> noop where queueremaining r k = queueTransferWhenSmall "remaining object in unwanted remote"
Assistant/Sync.hs view
@@ -225,8 +225,9 @@ , return $ Just r ) else return Nothing- haddiverged <- Annex.Branch.refsWereMerged- <$> liftAnnex Annex.Branch.forceUpdate+ haddiverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case+ u@(Annex.Branch.UpdateMade {}) -> Annex.Branch.refsWereMerged u+ (Annex.Branch.UpdateFailedPermissions {}) -> True forM_ remotes $ \r -> liftAnnex $ Command.Sync.mergeRemote r currentbranch mc def
Assistant/Threads/Merger.hs view
@@ -70,8 +70,9 @@ | ".lock" `isSuffixOf` file = noop | isAnnexBranch file = do branchChanged- diverged <- Annex.Branch.refsWereMerged- <$> liftAnnex Annex.Branch.forceUpdate+ diverged <- liftAnnex Annex.Branch.forceUpdate >>= return . \case+ u@(Annex.Branch.UpdateMade {}) -> Annex.Branch.refsWereMerged u+ (Annex.Branch.UpdateFailedPermissions {}) -> True when diverged $ do updateExportTreeFromLogAll queueDeferredDownloads "retrying deferred download" Later
CHANGELOG view
@@ -1,3 +1,29 @@+git-annex (8.20211231) upstream; urgency=medium++ * Improved support for using git-annex in a read-only repository,+ git-annex branch information from remotes that cannot be merged into+ the git-annex branch will now not crash it, but will be merged in+ memory.+ * addurl, youtube-dl: When --check-raw prevents downloading an url,+ still continue with any downloads that come after it, rather than+ erroring out.+ * Fix locking problems when annex.pidlock is set and concurrency is+ enabled eg with -J.+ * Improve error message display when autoinit fails due to eg, a+ permissions problem.+ * export: Avoid unncessarily re-exporting non-annexed files that were+ already exported.+ * Improve git command queue flushing so that eg, addurl of several+ large files that take time to download will update the index for each+ file, rather than deferring the index updates to the end.+ * sync: Better error message when unable to export to a remote because+ remote.name.annex-tracking-branch is configured to a ref that does not+ exist.+ * Fix build with ghc 9.0.1+ * Fix build with old versions of feed library.++ -- Joey Hess <id@joeyh.name> Fri, 31 Dec 2021 15:03:36 -0400+ git-annex (8.20211123) upstream; urgency=medium * Bugfix: When -J was enabled, getting files could leak an
CmdLine/Seek.hs view
@@ -282,7 +282,9 @@ keyaction Nothing (SeekInput [], k, mkActionItem k) go reader Nothing -> return ()- Annex.Branch.overBranchFileContents getk go+ Annex.Branch.overBranchFileContents getk go >>= \case+ Just r -> return r+ Nothing -> giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents operating on all keys. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)" runkeyaction getks = do keyaction <- mkkeyaction@@ -361,13 +363,14 @@ (process mi ofeeder mdfeeder mdcloser False l) mdprocessertid <- liftIO . async =<< forkState (mdprocess mi mdreader ofeeder ocloser)- if usesLocationLog seeker || matcherNeedsLocationLog mi- then catObjectStream g $ \lfeeder lcloser lreader -> do+ ifM (precachell mi)+ ( catObjectStream g $ \lfeeder lcloser lreader -> do precachertid <- liftIO . async =<< forkState (precacher mi config oreader lfeeder lcloser) precachefinisher mi lreader checktimelimit join (liftIO (wait precachertid))- else finisher mi oreader checktimelimit+ , finisher mi oreader checktimelimit+ ) join (liftIO (wait mdprocessertid)) join (liftIO (wait processertid)) liftIO $ void cleanup@@ -466,6 +469,16 @@ mdprocess mi mdreader ofeeder ocloser Just _ -> mdprocess mi mdreader ofeeder ocloser Nothing -> liftIO $ void ocloser++ -- Precache location logs if it will speed things up.+ --+ -- When there are git-annex branches that are not able to be+ -- merged, the precaching is disabled, since it only looks at the+ -- git-annex branch and not at those.+ precachell mi+ | usesLocationLog seeker || matcherNeedsLocationLog mi =+ null <$> Annex.Branch.getUnmergedRefs+ | otherwise = pure False seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool) seekHelper c ww a (WorkTreeItems l) = do
Command/AddUrl.hs view
@@ -182,7 +182,7 @@ where loguri = setDownloader uri OtherDownloader adduri = addUrlChecked o loguri file (Remote.uuid r) checkexistssize- checkexistssize key = return $ case sz of+ checkexistssize key = return $ Just $ case sz of Nothing -> (True, True, loguri) Just n -> (True, n == fromMaybe n (fromKey keySize key), loguri) geturi = next $ isJust <$> downloadRemoteFile addunlockedmatcher r (downloadOptions o) uri file sz@@ -270,31 +270,31 @@ geturl = next $ isJust <$> addUrlFile addunlockedmatcher (downloadOptions o) url urlinfo file addurl = addUrlChecked o url file webUUID $ \k -> ifM (pure (not (rawOption (downloadOptions o))) <&&> youtubeDlSupported url)- ( return (True, True, setDownloader url YoutubeDownloader)- , checkRaw Nothing (downloadOptions o) $- return (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url)+ ( return (Just (True, True, setDownloader url YoutubeDownloader))+ , checkRaw Nothing (downloadOptions o) Nothing $+ return (Just (Url.urlExists urlinfo, Url.urlSize urlinfo == fromKey keySize k, url)) ) {- Check that the url exists, and has the same size as the key, - and add it as an url to the key. -}-addUrlChecked :: AddUrlOptions -> URLString -> RawFilePath -> UUID -> (Key -> Annex (Bool, Bool, URLString)) -> Key -> CommandPerform+addUrlChecked :: AddUrlOptions -> URLString -> RawFilePath -> UUID -> (Key -> Annex (Maybe (Bool, Bool, URLString))) -> Key -> CommandPerform addUrlChecked o url file u checkexistssize key = ifM ((elem url <$> getUrls key) <&&> (elem u <$> loggedLocations key)) ( do showDestinationFile (fromRawFilePath file) next $ return True- , do- (exists, samesize, url') <- checkexistssize key- if exists && (samesize || relaxedOption (downloadOptions o))- then do+ , checkexistssize key >>= \case+ Just (exists, samesize, url')+ | exists && (samesize || relaxedOption (downloadOptions o)) -> do setUrlPresent key url' logChange key u InfoPresent next $ return True- else do+ | otherwise -> do warning $ "while adding a new url to an already annexed file, " ++ if exists then "url does not have expected file size (use --relaxed to bypass this check) " ++ url else "failed to verify url exists: " ++ url stop+ Nothing -> stop ) {- Downloads an url (except in fast or relaxed mode) and adds it to the@@ -333,7 +333,7 @@ in ifAnnexed f (alreadyannexed (fromRawFilePath f)) (dl f)- Left err -> checkRaw (Just err) o (normalfinish tmp)+ Left err -> checkRaw (Just err) o Nothing (normalfinish tmp) where dl dest = withTmpWorkDir mediakey $ \workdir -> do let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . removeWhenExistsWith R.removeLink)@@ -347,7 +347,7 @@ showDestinationFile (fromRawFilePath dest) addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just (toRawFilePath mediafile)) return $ Just mediakey- Right Nothing -> checkRaw Nothing o (normalfinish tmp)+ Right Nothing -> checkRaw Nothing o Nothing (normalfinish tmp) Left msg -> do cleanuptmp warning msg@@ -364,12 +364,14 @@ warning $ dest ++ " already exists; not overwriting" return Nothing -checkRaw :: (Maybe String) -> DownloadOptions -> Annex a -> Annex a-checkRaw failreason o a- | noRawOption o = giveup $ "Unable to use youtube-dl or a special remote and --no-raw was specified" ++- case failreason of- Just msg -> ": " ++ msg- Nothing -> ""+checkRaw :: (Maybe String) -> DownloadOptions -> a -> Annex a -> Annex a+checkRaw failreason o f a+ | noRawOption o = do+ warning $ "Unable to use youtube-dl or a special remote and --no-raw was specified" +++ case failreason of+ Just msg -> ": " ++ msg+ Nothing -> ""+ return f | otherwise = a {- The destination file is not known at start time unless the user provided@@ -491,7 +493,7 @@ then nomedia else youtubeDlFileName url >>= \case Right mediafile -> usemedia (toRawFilePath mediafile)- Left err -> checkRaw (Just err) o nomedia+ Left err -> checkRaw (Just err) o Nothing nomedia | otherwise = do warning $ "unable to access url: " ++ url return Nothing
Command/Export.hs view
@@ -275,11 +275,20 @@ af = AssociatedFile (Just f) ai = ActionItemTreeFile f si = SeekInput []- notrecordedpresent ek = (||)- <$> liftIO (notElem loc <$> getExportedLocation db ek)- -- If content was removed from the remote, the export db- -- will still list it, so also check location tracking.- <*> (notElem (uuid r) <$> loggedLocations ek)+ notrecordedpresent ek = + ifM (liftIO $ notElem loc <$> getExportedLocation db ek)+ ( return True+ -- When content was lost from the remote and+ -- a fsck noticed that, the export db will still+ -- list it as present in the remote. So also check + -- location tracking. + -- However, git sha keys do not have their locations+ -- tracked, and fsck doesn't check them, so not+ -- for those.+ , if isGitShaKey ek+ then return False+ else notElem (uuid r) <$> loggedLocations ek+ ) performExport :: Remote -> ExportHandle -> Key -> AssociatedFile -> Sha -> ExportLocation -> MVar AllFilled -> CommandPerform performExport r db ek af contentsha loc allfilledvar = do
Command/FilterBranch.hs view
@@ -12,7 +12,8 @@ import Command import qualified Annex import qualified Annex.Branch-import Annex.Branch.Transitions (filterBranch, FileTransition(..))+import Annex.Branch.Transitions+import Types.Transitions import Annex.HashObject import Annex.Tmp import Annex.SpecialRemote.Config
Command/ImportFeed.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} module Command.ImportFeed where @@ -88,7 +89,7 @@ where -- Use parseFeedFromFile rather than reading the file -- ourselves because it goes out of its way to handle encodings.- go tmpf = liftIO (parseFeedFromFile tmpf) >>= \case+ go tmpf = liftIO (parseFeedFromFile' tmpf) >>= \case Nothing -> debugfeedcontent tmpf "parsing the feed failed" Just f -> case findDownloads url f of [] -> debugfeedcontent tmpf "bad feed content; no enclosures to download"@@ -109,6 +110,13 @@ showEndResult =<< feedProblem url (msg ++ " (use --debug --debugfilter=ImportFeed to see the feed content that was downloaded)") +parseFeedFromFile' :: FilePath -> IO (Maybe Feed)+#if MIN_VERSION_feed(1,1,0)+parseFeedFromFile' = parseFeedFromFile+#else+parseFeedFromFile' f = catchMaybeIO (parseFeedFromFile f)+#endif+ data ToDownload = ToDownload { feed :: Feed , feedurl :: URLString@@ -142,7 +150,9 @@ {- Scan all url logs and metadata logs in the branch and find urls - and ItemIds that are already known. -} knownItems :: Annex ([URLString], [ItemId])-knownItems = Annex.Branch.overBranchFileContents select (go [] [])+knownItems = Annex.Branch.overBranchFileContents select (go [] []) >>= \case+ Just r -> return r+ Nothing -> giveup "This repository is read-only." where select f | isUrlLog f = Just ()@@ -194,7 +204,7 @@ let f' = fromRawFilePath f r <- Remote.claimingUrl url if Remote.uuid r == webUUID || rawOption (downloadOptions opts)- then checkRaw Nothing (downloadOptions opts) $ do+ then checkRaw (Just url) (downloadOptions opts) Nothing $ do let dlopts = (downloadOptions opts) -- force using the filename -- chosen here@@ -333,7 +343,7 @@ , downloadlink False ) where- downloadlink started' = checkRaw Nothing (downloadOptions opts) $+ downloadlink started' = checkRaw (Just linkurl) (downloadOptions opts) False $ performDownload' started' addunlockedmatcher opts cache todownload { location = Enclosure linkurl }
Command/Info.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -370,13 +370,17 @@ -- "remote" is in the name for JSON backwards-compatibility repo_annex_keys :: UUID -> Stat-repo_annex_keys u = stat "remote annex keys" $ json show $- countKeys <$> cachedRemoteData u+repo_annex_keys u = stat "remote annex keys" $ \d ->+ cachedRemoteData u >>= \case+ Right rd -> json show (pure (countKeys rd)) d+ Left n-> json id (pure n) d -- "remote" is in the name for JSON backwards-compatibility repo_annex_size :: UUID -> Stat repo_annex_size u = simpleStat "remote annex size" $- showSizeKeys =<< cachedRemoteData u+ cachedRemoteData u >>= \case+ Right d -> showSizeKeys d+ Left n -> pure n known_annex_files :: Bool -> Stat known_annex_files isworktree = @@ -524,20 +528,22 @@ put s { presentData = Just v } return v -cachedRemoteData :: UUID -> StatState KeyInfo+cachedRemoteData :: UUID -> StatState (Either String KeyInfo) cachedRemoteData u = do s <- get case M.lookup u (repoData s) of- Just v -> return v+ Just v -> return (Right v) Nothing -> do let combinedata d uk = finishCheck uk >>= \case Nothing -> return d Just k -> return $ addKey k d- (ks, cleanup) <- lift $ loggedKeysFor' u- v <- lift $ foldM combinedata emptyKeyInfo ks- liftIO $ void cleanup- put s { repoData = M.insert u v (repoData s) }- return v+ lift (loggedKeysFor' u) >>= \case+ Just (ks, cleanup) -> do+ v <- lift $ foldM combinedata emptyKeyInfo ks+ liftIO $ void cleanup+ put s { repoData = M.insert u v (repoData s) }+ return (Right v)+ Nothing -> return (Left "not available in this read-only repository with unmerged git-annex branches") cachedReferencedData :: StatState KeyInfo cachedReferencedData = do
Command/Log.hs view
@@ -1,6 +1,6 @@ {- git-annex command -- - Copyright 2012, 2016 Joey Hess <id@joeyh.name>+ - Copyright 2012-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -82,22 +82,25 @@ mkpassthru n v = [Param ("--" ++ n), Param v] seek :: LogOptions -> CommandSeek-seek o = do- m <- Remote.uuidDescriptions- zone <- liftIO getCurrentTimeZone- let outputter = mkOutputter m zone o- let seeker = AnnexedFileSeeker- { startAction = 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) -> withFilesInGitAnnex ww seeker- =<< workTreeItems ww fs- ([], True) -> commandAction (startAll o outputter)- (_, True) -> giveup "Cannot specify both files and --all"+seek o = ifM (null <$> Annex.Branch.getUnmergedRefs)+ ( do+ m <- Remote.uuidDescriptions+ zone <- liftIO getCurrentTimeZone+ let outputter = mkOutputter m zone o+ let seeker = AnnexedFileSeeker+ { startAction = 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) -> withFilesInGitAnnex ww seeker+ =<< workTreeItems ww fs+ ([], True) -> commandAction (startAll o outputter)+ (_, True) -> giveup "Cannot specify both files and --all"+ , giveup "This repository is read-only, and there are unmerged git-annex branches, which prevents displaying location log changes. (Set annex.merge-annex-branches to false to ignore the unmerged git-annex branches.)"+ ) where ww = WarnUnmatchLsFiles
Command/P2P.hs view
@@ -29,7 +29,6 @@ import Control.Concurrent.Async import qualified Data.Text as T-import Data.Time.Clock.POSIX cmd :: Command cmd = command "p2p" SectionSetup@@ -233,30 +232,11 @@ void $ liftIO $ async $ ui observer producer -- Provide an appid to magic wormhole, to avoid using -- the same channels that other wormhole users use.- --- -- Since a version of git-annex that did not provide an- -- appid is shipping in Debian 9, and having one side- -- provide an appid while the other does not will make- -- wormhole fail, this is deferred until 2021-12-31.- -- After that point, all git-annex's should have been- -- upgraded to include this code, and they will start- -- providing an appid.- --- -- This assumes reasonably good client clocks. If the clock- -- is completely wrong, it won't use the appid at that- -- point, and pairing will fail. On 2021-12-31, minor clock- -- skew may also cause transient problems.- --- -- After 2021-12-31, this can be changed to simply- -- always provide the appid.- now <- liftIO getPOSIXTime- let wormholeparams = if now < 1640950000- then []- else Wormhole.appId "git-annex.branchable.com/p2p-setup"+ let appid = Wormhole.appId "git-annex.branchable.com/p2p-setup" (sendres, recvres) <- liftIO $- Wormhole.sendFile sendf observer wormholeparams+ Wormhole.sendFile sendf observer appid `concurrently`- Wormhole.receiveFile recvf producer wormholeparams+ Wormhole.receiveFile recvf producer appid liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath sendf) if sendres /= True then return SendFailed
Command/Sync.hs view
@@ -888,7 +888,7 @@ Export.closeDb (\db -> Export.writeLockDbWhile db (go' r db)) go' r db = case remoteAnnexTrackingBranch (Remote.gitconfig r) of- Nothing -> nontracking r db+ Nothing -> cannotupdateexport r db Nothing Just b -> do mtree <- inRepo $ Git.Ref.tree b mtbcommitsha <- Command.Export.getExportCommit r b@@ -897,33 +897,41 @@ filteredtree <- Command.Export.filterExport r tree Command.Export.changeExport r db filteredtree Command.Export.fillExport r db filteredtree mtbcommitsha- _ -> nontracking r db+ _ -> cannotupdateexport r db (Just b) - nontracking r db = do+ cannotupdateexport r db mtb = do exported <- getExport (Remote.uuid r)- maybe noop (warnnontracking r exported) currbranch- nontrackingfillexport r db (exportedTreeishes exported) Nothing+ maybe noop (warncannotupdateexport r mtb exported) currbranch+ fillexistingexport r db (exportedTreeishes exported) Nothing - warnnontracking r exported currb = inRepo (Git.Ref.tree currb) >>= \case- Just currt | not (any (== currt) (exportedTreeishes exported)) ->- showLongNote $ unwords- [ "Not updating export to " ++ Remote.name r- , "to reflect changes to the tree, because export"- , "tracking is not enabled. "- , "(Set " ++ gitconfig ++ " to enable it.)"- ]- _ -> noop+ warncannotupdateexport r mtb exported currb = case mtb of+ Nothing -> inRepo (Git.Ref.tree currb) >>= \case+ Just currt | not (any (== currt) (exportedTreeishes exported)) ->+ showLongNote $ unwords+ [ notupdating+ , "to reflect changes to the tree, because export"+ , "tracking is not enabled. "+ , "(Set " ++ gitconfig ++ " to enable it.)"+ ]+ _ -> noop+ Just b -> showLongNote $ unwords+ [ notupdating+ , "because " ++ Git.fromRef b ++ "does not exist."+ , "(As configured by " ++ gitconfig ++ ")"+ ] where gitconfig = show (remoteAnnexConfig r "tracking-branch")+ notupdating = "Not updating export to " ++ Remote.name r - nontrackingfillexport _ _ [] _ = return False- nontrackingfillexport r db (tree:[]) mtbcommitsha = do+ fillexistingexport _ _ [] _ = return False+ fillexistingexport r db (tree:[]) mtbcommitsha = do -- The tree was already filtered when it was exported, so -- does not need be be filtered again now, when we're only- -- filling in any files that did not get transferred.+ -- filling in any files that did not get transferred+ -- to the existing exported tree. let filteredtree = Command.Export.ExportFiltered tree Command.Export.fillExport r db filteredtree mtbcommitsha- nontrackingfillexport r _ _ _ = do+ fillexistingexport r _ _ _ = do warnExportImportConflict r return False
Command/Unused.hs view
@@ -101,7 +101,9 @@ r <- Remote.byUUID u _ <- check "" (remoteUnusedMsg r remotename) (remoteunused u) 0 next $ return True- remoteunused u = excludeReferenced refspec =<< loggedKeysFor u+ remoteunused u = loggedKeysFor u >>= \case+ Just ks -> excludeReferenced refspec ks+ Nothing -> giveup "This repository is read-only." check :: FilePath -> ([(Int, Key)] -> String) -> Annex [Key] -> Int -> Annex Int check file msg a c = do
Git/Command.hs view
@@ -39,7 +39,7 @@ run :: [CommandParam] -> Repo -> IO () run params repo = assertLocal repo $ unlessM (runBool params repo) $- error $ "git " ++ show params ++ " failed"+ giveup $ "git " ++ show params ++ " failed" {- Runs git and forces it to be quiet, throwing an error if it fails. -} runQuiet :: [CommandParam] -> Repo -> IO ()
Git/LsFiles.hs view
@@ -68,7 +68,7 @@ guardSafeForLsFiles :: Repo -> IO a -> IO a guardSafeForLsFiles r a | safeForLsFiles r = a- | otherwise = error $ "git ls-files is unsafe to run on repository " ++ repoDescribe r+ | otherwise = giveup $ "git ls-files is unsafe to run on repository " ++ repoDescribe r data Options = ErrorUnmatch
Git/Queue.hs view
@@ -10,6 +10,7 @@ module Git.Queue ( Queue, new,+ defaultTimelimit, addCommand, addUpdateIndex, addInternalAction,@@ -28,6 +29,8 @@ import qualified Data.Map.Strict as M import Control.Monad.IO.Class+import Data.Time.Clock+import Data.Time.Clock.POSIX {- Queable actions that can be performed in a git repository. -} data Action m@@ -76,6 +79,8 @@ data Queue m = Queue { size :: Int , _limit :: Int+ , _timelimit :: NominalDiffTime+ , _lastchanged :: POSIXTime , items :: M.Map ActionKey (Action m) } @@ -91,9 +96,21 @@ defaultLimit :: Int defaultLimit = 10240 +{- How close together in seconds changes to the queue have to be happening+ - in order for it to keep accumulating actions, rather than running actions+ - immediately. -}+defaultTimelimit :: NominalDiffTime+defaultTimelimit = 60 * 5+ {- Constructor for empty queue. -}-new :: Maybe Int -> Queue m-new lim = Queue 0 (fromMaybe defaultLimit lim) M.empty+new :: Maybe Int -> Maybe NominalDiffTime -> IO (Queue m)+new lim tlim = do+ now <- getPOSIXTime+ return $ Queue 0+ (fromMaybe defaultLimit lim)+ (fromMaybe defaultTimelimit tlim)+ now+ M.empty {- Adds an git command to the queue. -@@ -139,15 +156,30 @@ different (UpdateIndexAction _) = False different _ = True -{- Updates or adds an action in the queue. If the queue already contains a- - different action, it will be flushed; this is to ensure that conflicting- - actions, like add and rm, are run in the right order.-}+{- Updates or adds an action in the queue.+ -+ - If the queue already contains a different action, it will be flushed+ - before adding the action; this is to ensure that conflicting actions,+ - like add and rm, are run in the right order.+ -+ - If the queue's time limit has been exceeded, it will also be flushed,+ - and the action will be run right away.+ -} updateQueue :: MonadIO m => Action m -> (Action m -> Bool) -> Int -> Queue m -> Repo -> m (Queue m)-updateQueue !action different sizeincrease q repo- | null (filter different (M.elems (items q))) = return $ go q- | otherwise = go <$> flush q repo+updateQueue !action different sizeincrease q repo = do+ now <- liftIO getPOSIXTime+ if now - (_lastchanged q) > _timelimit q+ then if isdifferent+ then do+ q' <- flush q repo+ flush (mk q') repo+ else flush (mk q) repo+ else if isdifferent+ then mk <$> flush q repo+ else return $ mk (q { _lastchanged = now }) where- go q' = newq+ isdifferent = not (null (filter different (M.elems (items q))))+ mk q' = newq where !newq = q' { size = newsize@@ -175,17 +207,19 @@ merge origq newq = origq { size = size origq + size newq , items = M.unionWith combineNewOld (items newq) (items origq)+ , _lastchanged = max (_lastchanged origq) (_lastchanged newq) } {- Is a queue large enough that it should be flushed? -} full :: Queue m -> Bool-full (Queue cur lim _) = cur >= lim+full (Queue cur lim _ _ _) = cur >= lim {- Runs a queue on a git repository. -} flush :: MonadIO m => Queue m -> Repo -> m (Queue m)-flush (Queue _ lim m) repo = do+flush (Queue _ lim tlim _ m) repo = do forM_ (M.elems m) $ runAction repo- return $ Queue 0 lim M.empty+ now <- liftIO getPOSIXTime+ return $ Queue 0 lim tlim now M.empty {- Runs an Action on a list of files in a git repository. -
Git/Repair.hs view
@@ -114,7 +114,7 @@ | not (foundBroken missing) = return missing | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do unlessM (boolSystem "git" [Param "init", File tmpdir]) $- error $ "failed to create temp repository in " ++ tmpdir+ giveup $ "failed to create temp repository in " ++ tmpdir tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config") whenM (doesFileExist (repoconfig r)) $
Logs/Location.hs view
@@ -137,15 +137,17 @@ - - Keys that have been marked as dead are not included. -}-loggedKeys :: Annex ([Unchecked Key], IO Bool)+loggedKeys :: Annex (Maybe ([Unchecked Key], IO Bool)) loggedKeys = loggedKeys' (not <$$> checkDead) -loggedKeys' :: (Key -> Annex Bool) -> Annex ([Unchecked Key], IO Bool)+loggedKeys' :: (Key -> Annex Bool) -> Annex (Maybe ([Unchecked Key], IO Bool)) loggedKeys' check = do config <- Annex.getGitConfig- (bfs, cleanup) <- Annex.Branch.files- let l = mapMaybe (defercheck <$$> locationLogFileKey config) bfs- return (l, cleanup)+ Annex.Branch.files >>= \case+ Nothing -> return Nothing+ Just (bfs, cleanup) -> do+ let l = mapMaybe (defercheck <$$> locationLogFileKey config) bfs+ return (Just (l, cleanup)) where defercheck k = Unchecked $ ifM (check k) ( return (Just k)@@ -157,14 +159,15 @@ - - This does not stream well; use loggedKeysFor' for lazy streaming. -}-loggedKeysFor :: UUID -> Annex [Key]-loggedKeysFor u = do- (l, cleanup) <- loggedKeysFor' u- l' <- catMaybes <$> mapM finishCheck l- liftIO $ void cleanup- return l'+loggedKeysFor :: UUID -> Annex (Maybe [Key])+loggedKeysFor u = loggedKeysFor' u >>= \case+ Nothing -> return Nothing+ Just (l, cleanup) -> do+ l' <- catMaybes <$> mapM finishCheck l+ liftIO $ void cleanup+ return (Just l') -loggedKeysFor' :: UUID -> Annex ([Unchecked Key], IO Bool)+loggedKeysFor' :: UUID -> Annex (Maybe ([Unchecked Key], IO Bool)) loggedKeysFor' u = loggedKeys' isthere where isthere k = do
Logs/Transitions.hs view
@@ -7,7 +7,7 @@ - done that is listed in the remote branch by checking that the local - branch contains the same transition, with the same or newer start time. -- - Copyright 2013-2019 Joey Hess <id@joeyh.name>+ - Copyright 2013-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -19,6 +19,9 @@ import Annex.Common import Annex.VectorClock import Logs.Line+import qualified Git+import Git.Types (fromRef)+import Annex.CatFile import qualified Data.Set as S import Data.Either@@ -100,3 +103,8 @@ recordTransitions :: (RawFilePath -> (L.ByteString -> Builder) -> Annex ()) -> Transitions -> Annex () recordTransitions changer t = changer transitionsLog $ buildTransitions . S.union t . parseTransitionsStrictly "local"++getRefTransitions :: Git.Ref -> Annex Transitions+getRefTransitions ref = + parseTransitionsStrictly (fromRef ref) + <$> catFile ref transitionsLog
Remote/Glacier.hs view
@@ -28,6 +28,7 @@ import Annex.UUID import Utility.Env import Types.ProposedAccepted+import Utility.Hash (IncrementalVerifier) type Vault = String type Archive = FilePath@@ -175,7 +176,7 @@ forceSuccessProcess cmd pid go' _ _ _ _ _ = error "internal" -retrieve :: Remote -> Retriever+retrieve :: forall a. Remote -> Key -> MeterUpdate -> Maybe IncrementalVerifier -> (ContentSource -> Annex a) -> Annex a retrieve = byteRetriever . retrieve' retrieve' :: forall a. Remote -> Key -> (L.ByteString -> Annex a) -> Annex a
Test.hs view
@@ -76,7 +76,6 @@ import qualified Utility.Format import qualified Utility.Verifiable import qualified Utility.Process-import qualified Utility.Process.Transcript import qualified Utility.Misc import qualified Utility.InodeCache import qualified Utility.Env@@ -312,7 +311,7 @@ unitTests note = testGroup ("Unit Tests " ++ note) [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras- , testCase "readonly" test_readonly+ , testCase "readonly remote" test_readonly_remote , testCase "ignore deleted files" test_ignore_deleted_files , testCase "metadata" test_metadata , testCase "export_import" test_export_import@@ -432,18 +431,15 @@ annexed_present wormannexedfile checkbackend wormannexedfile backendWORM -test_readonly :: Assertion-test_readonly =+test_readonly_remote :: Assertion+test_readonly_remote = #ifndef mingw32_HOST_OS withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do pair r1 r2 indir r1 $ do git_annex "get" [annexedfile] "get failed in first repo"- {- chmod may fail, or not be available, or the- - filesystem not support permissions. -}- void $ Utility.Process.Transcript.processTranscript- "chmod" ["-R", "-w", r1] Nothing+ make_readonly r1 indir r2 $ do git_annex "sync" ["r1", "--no-push"] "sync with readonly repo" git_annex "get" [annexedfile, "--from", "r1"] "get from readonly repo"@@ -469,6 +465,9 @@ git_annex "metadata" ["-s", "foo=bar", annexedfile] "set metadata" git_annex_expectoutput "find" ["--metadata", "foo=bar"] [annexedfile] git_annex_expectoutput "find" ["--metadata", "foo=other"] []+ readonly_query $ do+ 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@@ -1139,10 +1138,12 @@ test_find = intmpclonerepo $ do annexed_notpresent annexedfile git_annex_expectoutput "find" [] []+ readonly_query $ git_annex_expectoutput "find" [] [] git_annex "get" [annexedfile] "get" annexed_present annexedfile annexed_notpresent sha1annexedfile git_annex_expectoutput "find" [] [annexedfile]+ readonly_query $ git_annex_expectoutput "find" [] [annexedfile] git_annex_expectoutput "find" ["--exclude", annexedfile, "--and", "--exclude", sha1annexedfile] [] git_annex_expectoutput "find" ["--include", annexedfile] [annexedfile] git_annex_expectoutput "find" ["--not", "--in", "origin"] []@@ -1164,14 +1165,19 @@ test_info :: Assertion test_info = intmpclonerepo $ do- json <- BU8.fromString <$> git_annex_output "info" ["--json"]- case Utility.Aeson.eitherDecode json :: Either String Utility.Aeson.Value of- Right _ -> return ()- Left e -> assertFailure e+ isjson+ readonly_query isjson+ where+ isjson = do+ json <- BU8.fromString <$> git_annex_output "info" ["--json"]+ case Utility.Aeson.eitherDecode json :: Either String Utility.Aeson.Value of+ Right _ -> return ()+ Left e -> assertFailure e test_version :: Assertion-test_version = intmpclonerepo $+test_version = intmpclonerepo $ do git_annex "version" [] "version"+ readonly_query $ git_annex "version" [] "readonly version" test_sync :: Assertion test_sync = intmpclonerepo $ do@@ -1697,11 +1703,15 @@ test_whereis = intmpclonerepo $ do annexed_notpresent annexedfile git_annex "whereis" [annexedfile] "whereis on non-present file"+ readonly_query $ + git_annex "whereis" [annexedfile] "readonly whereis on non-present file" git_annex "untrust" ["origin"] "untrust" git_annex_shouldfail "whereis" [annexedfile] "whereis should exit nonzero on non-present file only present in untrusted repo" git_annex "get" [annexedfile] "get" annexed_present annexedfile git_annex "whereis" [annexedfile] "whereis on present file"+ readonly_query $+ git_annex "whereis" [annexedfile] "readonly whereis on present file" test_hook_remote :: Assertion test_hook_remote = intmpclonerepo $ do
Test/Framework.hs view
@@ -1,6 +1,6 @@ {- git-annex test suite framework -- - Copyright 2010-2020 Joey Hess <id@joeyh.name>+ - Copyright 2010-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -640,3 +640,24 @@ when (r /= r2) $ git "remote" ["add", "r2", "../../" ++ r2] "remote add" ++{- Runs a query in the current repository, but first makes the repository+ - read-only. The write bit is added back at the end, so when possible, + - include multiple tests within a single call for efficiency. -}+readonly_query :: Assertion -> Assertion+readonly_query = bracket_ (make_readonly ".") (make_writeable ".")+ +{- Not guaranteed to do anything: + - chmod may fail, or not be available, or the filesystem not support+ - permissions. -}+make_readonly :: FilePath -> IO ()+make_readonly d = void $+ Utility.Process.Transcript.processTranscript+ "chmod" ["-R", "-w", d] Nothing++{- The write bit is added back for the current user, but not for other+ - users, even though make_readonly removes any other user's write bits. -}+make_writeable :: FilePath -> IO ()+make_writeable d = void $+ Utility.Process.Transcript.processTranscript+ "chmod" ["-R", "u+w", d] Nothing
Types/BranchState.hs view
@@ -1,6 +1,6 @@ {- git-annex BranchState data type -- - Copyright 2011-2020 Joey Hess <id@joeyh.name>+ - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -}@@ -8,17 +8,27 @@ module Types.BranchState where import Common+import qualified Git+import Types.Transitions import qualified Data.ByteString.Lazy as L data BranchState = BranchState { branchUpdated :: Bool- -- ^ has the branch been updated this run?+ -- ^ has the branch been updated this run? (Or an update tried and+ -- failed due to permissions.) , indexChecked :: Bool -- ^ has the index file been checked to exist? , journalIgnorable :: Bool -- ^ can reading the journal be skipped, while still getting -- sufficiently up-to-date information from the branch?+ , unmergedRefs :: [Git.Sha]+ -- ^ when the branch was not able to be updated due to permissions,+ -- these other git refs contain unmerged information and need to be+ -- queried, along with the index and the journal.+ , unhandledTransitions :: [TransitionCalculator]+ -- ^ when the branch was not able to be updated due to permissions,+ -- this is transitions that need to be applied when making queries. , cachedFileContents :: [(RawFilePath, L.ByteString)] -- ^ contents of a few files recently read from the branch , needInteractiveAccess :: Bool@@ -29,4 +39,4 @@ } startBranchState :: BranchState-startBranchState = BranchState False False False [] False+startBranchState = BranchState False False False [] [] [] False
+ Types/Transitions.hs view
@@ -0,0 +1,19 @@+{- git-annex transitions data types+ -+ - Copyright 2021 Joey Hess <id@joeyh.name>+ -+ - Licensed under the GNU AGPL version 3 or higher.+ -}++module Types.Transitions where++import Utility.RawFilePath++import qualified Data.ByteString.Lazy as L+import Data.ByteString.Builder++data FileTransition+ = ChangeFile Builder+ | PreserveFile++type TransitionCalculator = RawFilePath -> L.ByteString -> FileTransition
Utility/FileSystemEncoding.hs view
@@ -86,10 +86,10 @@ decodeBS :: S.ByteString -> FilePath #ifndef mingw32_HOST_OS--- This is a copy of code from System.FilePath.Internal.decodeFilePath.--- However, older versions of that library truncated at NUL, which this--- must not do, because it may end up used on something other than a unix--- filepath.+-- This does the same thing as System.FilePath.ByteString.decodeFilePath,+-- with an identical implementation. However, older versions of that library+-- truncated at NUL, which this must not do, because it may end up used on+-- something other than a unix filepath. {-# NOINLINE decodeBS #-} decodeBS b = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding@@ -100,10 +100,10 @@ encodeBS :: FilePath -> S.ByteString #ifndef mingw32_HOST_OS--- This is a copy of code from System.FilePath.Internal.encodeFilePath.--- However, older versions of that library truncated at NUL, which this--- must not do, because it may end up used on something other than a unix--- filepath.+-- This does the same thing as System.FilePath.ByteString.encodeFilePath,+-- with an identical implementation. However, older versions of that library+-- truncated at NUL, which this must not do, because it may end up used on+-- something other than a unix filepath. {-# NOINLINE encodeBS #-} encodeBS f = unsafePerformIO $ do enc <- Encoding.getFileSystemEncoding
Utility/LockFile/PidLock.hs view
@@ -1,6 +1,6 @@ {- pid-based lock files -- - Copyright 2015-2020 Joey Hess <id@joeyh.name>+ - Copyright 2015-2021 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -8,9 +8,12 @@ {-# LANGUAGE OverloadedStrings #-} module Utility.LockFile.PidLock (+ PidLockFile, LockHandle, tryLock, waitLock,+ waitedLock,+ alreadyLocked, dropLock, LockStatus(..), getLockStatus,@@ -51,13 +54,13 @@ import Control.Applicative import Prelude -type LockFile = RawFilePath+type PidLockFile = RawFilePath data LockHandle- = LockHandle LockFile FileStatus SideLockHandle+ = LockHandle PidLockFile FileStatus SideLockHandle | ParentLocked -type SideLockHandle = Maybe (LockFile, Posix.LockHandle)+type SideLockHandle = Maybe (RawFilePath, Posix.LockHandle) data PidLock = PidLock { lockingPid :: ProcessID@@ -70,13 +73,13 @@ <$> getProcessID <*> getHostName -readPidLock :: LockFile -> IO (Maybe PidLock)+readPidLock :: PidLockFile -> IO (Maybe PidLock) readPidLock lockfile = (readish =<<) <$> catchMaybeIO (readFile (fromRawFilePath lockfile)) -- To avoid races when taking over a stale pid lock, a side lock is used. -- This is a regular posix exclusive lock.-trySideLock :: LockFile -> (SideLockHandle -> IO a) -> IO a+trySideLock :: PidLockFile -> (SideLockHandle -> IO a) -> IO a trySideLock lockfile a = do sidelock <- sideLockFile lockfile mlck <- catchDefaultIO Nothing $ @@ -111,7 +114,7 @@ -- The side lock is put in /dev/shm. This will work on most any -- Linux system, even if its whole root filesystem doesn't support posix -- locks. /tmp is used as a fallback.-sideLockFile :: LockFile -> IO LockFile+sideLockFile :: PidLockFile -> IO RawFilePath sideLockFile lockfile = do f <- fromRawFilePath <$> absPath lockfile let base = intercalate "_" (splitDirectories (makeRelative "/" f))@@ -134,7 +137,7 @@ -- -- If a parent process is holding the lock, determined by a -- "PIDLOCK_lockfile" environment variable, does not block either.-tryLock :: LockFile -> IO (Maybe LockHandle)+tryLock :: PidLockFile -> IO (Maybe LockHandle) tryLock lockfile = do abslockfile <- absPath lockfile lockenv <- pidLockEnv abslockfile@@ -149,19 +152,16 @@ setFileMode tmp' (combineModes readModes) hPutStr h . show =<< mkPidLock hClose h- let failedlock st = do- dropLock $ LockHandle tmp' st sidelock+ let failedlock = do+ dropSideLock sidelock removeWhenExistsWith removeLink tmp' return Nothing let tooklock st = return $ Just $ LockHandle abslockfile st sidelock- ifM (linkToLock sidelock tmp' abslockfile)- ( do+ linkToLock sidelock tmp' abslockfile >>= \case+ Just lckst -> do removeWhenExistsWith removeLink tmp'- -- May not have made a hard link, so stat- -- the lockfile- lckst <- getFileStatus abslockfile tooklock lckst- , do+ Nothing -> do v <- readPidLock abslockfile hn <- getHostName tmpst <- getFileStatus tmp'@@ -174,8 +174,7 @@ -- stale, and can take it over. rename tmp' abslockfile tooklock tmpst- _ -> failedlock tmpst- )+ _ -> failedlock -- Linux's open(2) man page recommends linking a pid lock into place, -- as the most portable atomic operation that will fail if@@ -187,8 +186,8 @@ -- -- However, not all filesystems support hard links. So, first probe -- to see if they are supported. If not, use open with O_EXCL.-linkToLock :: SideLockHandle -> RawFilePath -> RawFilePath -> IO Bool-linkToLock Nothing _ _ = return False+linkToLock :: SideLockHandle -> RawFilePath -> RawFilePath -> IO (Maybe FileStatus)+linkToLock Nothing _ _ = return Nothing linkToLock (Just _) src dest = do let probe = src <> ".lnk" v <- tryIO $ createLink src probe@@ -197,10 +196,13 @@ Right _ -> do _ <- tryIO $ createLink src dest ifM (catchBoolIO checklinked)- ( catchBoolIO $ not <$> checkInsaneLustre dest- , return False+ ( ifM (catchBoolIO $ not <$> checkInsaneLustre dest)+ ( catchMaybeIO $ getFileStatus dest+ , return Nothing+ )+ , return Nothing )- Left _ -> catchBoolIO $ do+ Left _ -> catchMaybeIO $ do let setup = do fd <- openFd dest WriteOnly (Just $ combineModes readModes)@@ -209,7 +211,7 @@ let cleanup = hClose let go h = readFile (fromRawFilePath src) >>= hPutStr h bracket setup cleanup go- return True+ getFileStatus dest where checklinked = do x <- getSymbolicLinkStatus src@@ -255,8 +257,8 @@ -- -- After the first second waiting, runs the callback to display a message, -- so the user knows why it's stalled.-waitLock :: MonadIO m => Seconds -> LockFile -> (String -> m ()) -> m LockHandle-waitLock (Seconds timeout) lockfile displaymessage = go timeout+waitLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> (Bool -> IO ()) -> m LockHandle+waitLock (Seconds timeout) lockfile displaymessage sem = go timeout where go n | n > 0 = liftIO (tryLock lockfile) >>= \case@@ -265,11 +267,26 @@ displaymessage $ "waiting for pid lock file " ++ fromRawFilePath lockfile ++ " which is held by another process (or may be stale)" liftIO $ threadDelaySeconds (Seconds 1) go (pred n)- Just lckh -> return lckh+ Just lckh -> do+ liftIO $ sem True+ return lckh | otherwise = do- displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile- giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile+ liftIO $ sem False+ waitedLock (Seconds timeout) lockfile displaymessage +waitedLock :: MonadIO m => Seconds -> PidLockFile -> (String -> m ()) -> m a+waitedLock (Seconds timeout) lockfile displaymessage = do+ displaymessage $ show timeout ++ " second timeout exceeded while waiting for pid lock file " ++ fromRawFilePath lockfile+ giveup $ "Gave up waiting for pid lock file " ++ fromRawFilePath lockfile++-- | Use when the pid lock has already been taken by another thread of the+-- same process.+alreadyLocked :: MonadIO m => PidLockFile -> m LockHandle+alreadyLocked lockfile = liftIO $ do+ abslockfile <- absPath lockfile+ st <- getFileStatus abslockfile+ return $ LockHandle abslockfile st Nothing+ dropLock :: LockHandle -> IO () dropLock (LockHandle lockfile _ sidelock) = do -- Drop side lock first, at which point the pid lock will be@@ -278,10 +295,10 @@ removeWhenExistsWith removeLink lockfile dropLock ParentLocked = return () -getLockStatus :: LockFile -> IO LockStatus+getLockStatus :: PidLockFile -> IO LockStatus getLockStatus = maybe StatusUnLocked (StatusLockedBy . lockingPid) <$$> readPidLock -checkLocked :: LockFile -> IO (Maybe Bool)+checkLocked :: PidLockFile -> IO (Maybe Bool) checkLocked lockfile = conv <$> getLockStatus lockfile where conv (StatusLockedBy _) = Just True@@ -289,7 +306,7 @@ -- Checks that the lock file still exists, and is the same file that was -- locked to get the LockHandle.-checkSaneLock :: LockFile -> LockHandle -> IO Bool+checkSaneLock :: PidLockFile -> LockHandle -> IO Bool checkSaneLock lockfile (LockHandle _ st _) = go =<< catchMaybeIO (getFileStatus lockfile) where
Utility/LockPool/LockHandle.hs view
@@ -1,6 +1,6 @@ {- Handles for lock pools. -- - Copyright 2015-2020 Joey Hess <id@joeyh.name>+ - Copyright 2015-2021 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -8,7 +8,7 @@ {-# LANGUAGE CPP #-} module Utility.LockPool.LockHandle (- LockHandle,+ LockHandle(..), FileLockOps(..), dropLock, #ifndef mingw32_HOST_OS@@ -25,7 +25,6 @@ import Control.Concurrent.STM import Control.Monad.Catch import Control.Monad.IO.Class (liftIO, MonadIO)-import Control.Applicative import Prelude data LockHandle = LockHandle P.LockHandle FileLockOps@@ -52,38 +51,42 @@ :: (MonadIO m, MonadMask m) => P.LockPool -> LockFile- -> (P.LockPool -> LockFile -> STM P.LockHandle)- -> (LockFile -> m FileLockOps)- -> m LockHandle+ -> (P.LockPool -> LockFile -> STM (P.LockHandle, P.FirstLock))+ -> (LockFile -> P.FirstLock -> m (FileLockOps, t))+ -> m (LockHandle, t) makeLockHandle pool file pa fa = bracketOnError setup cleanup go where setup = debugLocks $ liftIO $ atomically (pa pool file)- cleanup ph = debugLocks $ liftIO $ P.releaseLock ph- go ph = liftIO . mkLockHandle ph =<< fa file+ cleanup (ph, _) = debugLocks $ liftIO $ P.releaseLock ph+ go (ph, firstlock) = do+ (flo, t) <- fa file firstlock+ h <- liftIO $ mkLockHandle ph flo+ return (h, t) tryMakeLockHandle :: (MonadIO m, MonadMask m) => P.LockPool -> LockFile- -> (P.LockPool -> LockFile -> STM (Maybe P.LockHandle))- -> (LockFile -> m (Maybe FileLockOps))- -> m (Maybe LockHandle)+ -> (P.LockPool -> LockFile -> STM (Maybe (P.LockHandle, P.FirstLock)))+ -> (LockFile -> P.FirstLock -> m (Maybe (FileLockOps, t)))+ -> m (Maybe (LockHandle, t)) tryMakeLockHandle pool file pa fa = bracketOnError setup cleanup go where setup = liftIO $ atomically (pa pool file) cleanup Nothing = return ()- cleanup (Just ph) = liftIO $ P.releaseLock ph+ cleanup (Just (ph, _)) = liftIO $ P.releaseLock ph go Nothing = return Nothing- go (Just ph) = do- mfo <- fa file+ go (Just (ph, firstlock)) = do+ mfo <- fa file firstlock case mfo of Nothing -> do- liftIO $ cleanup (Just ph)+ liftIO $ cleanup (Just (ph, firstlock)) return Nothing- Just fo -> liftIO $ Just <$> mkLockHandle ph fo+ Just (fo, t) -> do+ h <- liftIO $ mkLockHandle ph fo+ return (Just (h, t)) mkLockHandle :: P.LockHandle -> FileLockOps -> IO LockHandle mkLockHandle ph fo = do atomically $ P.registerCloseLockFile ph (fDropLock fo) return $ LockHandle ph fo-
Utility/LockPool/PidLock.hs view
@@ -1,6 +1,6 @@ {- Pid locks, using lock pools. -- - Copyright 2015-2020 Joey Hess <id@joeyh.name>+ - Copyright 2015-2021 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -10,6 +10,7 @@ LockHandle, waitLock, tryLock,+ tryLock', checkLocked, getLockStatus, LockStatus(..),@@ -26,30 +27,114 @@ import System.IO import System.Posix+import Control.Concurrent.STM import Data.Maybe+import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Applicative import Prelude --- Takes a pid lock, blocking until the lock is available or the timeout.+-- Does locking using a pid lock, blocking until the lock is available+-- or the Seconds timeout if the pid lock is held by another process.+--+-- There are two levels of locks. A STM lock is used to handle+-- fine-grained locking amoung threads, locking a specific lockfile,+-- but only in memory. The pid lock handles locking between processes.+--+-- The pid lock is only taken once, and LockShared is used for it,+-- so multiple threads can have it locked. Only the first thread+-- will create the pid lock, and it remains until all threads drop+-- their locks. waitLock :: (MonadIO m, MonadMask m)- => Seconds- -> LockFile+ => LockFile+ -> LockMode+ -> Seconds+ -> F.PidLockFile -> (String -> m ()) -> m LockHandle-waitLock timeout file displaymessage = makeLockHandle P.lockPool file- -- LockShared for STM lock, because a pid lock can be the top-level- -- lock with various other STM level locks gated behind it.- (\p f -> P.waitTakeLock p f LockShared)- (\f -> mk <$> F.waitLock timeout f displaymessage)+waitLock finelockfile lockmode timeout pidlockfile displaymessage = do+ fl <- takefinelock+ pl <- takepidlock+ `onException` liftIO (dropLock fl)+ registerPostRelease fl pl+ return fl+ where+ takefinelock = fst <$> makeLockHandle P.lockPool finelockfile+ (\p f -> P.waitTakeLock p f lockmode)+ (\_ _ -> pure (stmonlyflo, ()))+ -- A shared STM lock is taken for each use of the pid lock,+ -- but only the first thread to take it actually creates the pid+ -- lock file.+ takepidlock = makeLockHandle P.lockPool pidlockfile+ (\p f -> P.waitTakeLock p f LockShared)+ (\f (P.FirstLock firstlock firstlocksem) -> if firstlock+ then waitlock f firstlocksem+ else liftIO (atomically $ readTMVar firstlocksem) >>= \case+ P.FirstLockSemWaited True -> alreadylocked f+ P.FirstLockSemTried True -> alreadylocked f+ P.FirstLockSemWaited False -> F.waitedLock timeout f displaymessage+ P.FirstLockSemTried False -> waitlock f firstlocksem+ )+ waitlock f firstlocksem = do+ h <- F.waitLock timeout f displaymessage $+ void . atomically . tryPutTMVar firstlocksem . P.FirstLockSemWaited+ return (mkflo h, Just h)+ alreadylocked f = do+ lh <- F.alreadyLocked f+ return (mkflo lh, Nothing) +registerPostRelease :: MonadIO m => LockHandle -> (LockHandle, Maybe F.LockHandle) -> m ()+registerPostRelease (LockHandle flh _) (pl@(LockHandle plh _), mpidlock) = do+ -- After the fine-grained lock gets dropped (and any shared locks+ -- of it are also dropped), drop the associated pid lock.+ liftIO $ atomically $+ P.registerPostReleaseLock flh (dropLock pl)+ -- When the last thread to use the pid lock has dropped it,+ -- close the pid lock file itself.+ case mpidlock of+ Just pidlock -> liftIO $ atomically $+ P.registerPostReleaseLock plh (F.dropLock pidlock)+ Nothing -> return ()+ -- Tries to take a pid lock, but does not block.-tryLock :: LockFile -> IO (Maybe LockHandle)-tryLock file = tryMakeLockHandle P.lockPool file+tryLock :: LockFile -> LockMode -> F.PidLockFile -> IO (Maybe LockHandle)+tryLock finelockfile lockmode pidlockfile = takefinelock >>= \case+ Just fl -> tryLock' pidlockfile >>= \case+ Just pl -> do+ registerPostRelease fl pl+ return (Just fl)+ Nothing -> do+ dropLock fl+ return Nothing+ Nothing -> return Nothing+ where+ takefinelock = fmap fst <$> tryMakeLockHandle P.lockPool finelockfile+ (\p f -> P.tryTakeLock p f lockmode)+ (\_ _ -> pure (Just (stmonlyflo, ())))++tryLock' :: F.PidLockFile -> IO (Maybe (LockHandle, Maybe F.LockHandle))+tryLock' pidlockfile = tryMakeLockHandle P.lockPool pidlockfile (\p f -> P.tryTakeLock p f LockShared)- (\f -> fmap mk <$> F.tryLock f)+ (\f (P.FirstLock firstlock firstlocksem) -> if firstlock+ then do+ mlh <- F.tryLock f+ void $ atomically $ tryPutTMVar firstlocksem + (P.FirstLockSemTried (isJust mlh))+ case mlh of+ Just lh -> return (Just (mkflo lh, Just lh))+ Nothing -> return Nothing+ else liftIO (atomically $ readTMVar firstlocksem) >>= \case+ P.FirstLockSemWaited True -> alreadylocked f+ P.FirstLockSemTried True -> alreadylocked f+ P.FirstLockSemWaited False -> return Nothing+ P.FirstLockSemTried False -> return Nothing+ )+ where+ alreadylocked f = do+ lh <- F.alreadyLocked f+ return (Just (mkflo lh, Nothing)) checkLocked :: LockFile -> IO (Maybe Bool) checkLocked file = P.getLockStatus P.lockPool file@@ -61,8 +146,14 @@ (StatusLockedBy <$> getProcessID) (F.getLockStatus file) -mk :: F.LockHandle -> FileLockOps-mk h = FileLockOps- { fDropLock = F.dropLock h+mkflo :: F.LockHandle -> FileLockOps+mkflo h = FileLockOps+ { fDropLock = return () , fCheckSaneLock = \f -> F.checkSaneLock f h+ }+ +stmonlyflo :: FileLockOps+stmonlyflo = FileLockOps+ { fDropLock = return ()+ , fCheckSaneLock = const (return True) }
Utility/LockPool/Posix.hs view
@@ -33,27 +33,27 @@ -- Takes a shared lock, blocking until the lock is available. lockShared :: Maybe FileMode -> LockFile -> IO LockHandle-lockShared mode file = makeLockHandle P.lockPool file+lockShared mode file = fst <$> makeLockHandle P.lockPool file (\p f -> P.waitTakeLock p f LockShared)- (\f -> mk <$> F.lockShared mode f)+ (\f _ -> mk <$> F.lockShared mode f) -- Takes an exclusive lock, blocking until the lock is available. lockExclusive :: Maybe FileMode -> LockFile -> IO LockHandle-lockExclusive mode file = makeLockHandle P.lockPool file+lockExclusive mode file = fst <$> makeLockHandle P.lockPool file (\p f -> P.waitTakeLock p f LockExclusive)- (\f -> mk <$> F.lockExclusive mode f)+ (\f _ -> mk <$> F.lockExclusive mode f) -- Tries to take a shared lock, but does not block. tryLockShared :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)-tryLockShared mode file = tryMakeLockHandle P.lockPool file+tryLockShared mode file = fmap fst <$> tryMakeLockHandle P.lockPool file (\p f -> P.tryTakeLock p f LockShared)- (\f -> fmap mk <$> F.tryLockShared mode f)+ (\f _ -> fmap mk <$> F.tryLockShared mode f) -- Tries to take an exclusive lock, but does not block. tryLockExclusive :: Maybe FileMode -> LockFile -> IO (Maybe LockHandle)-tryLockExclusive mode file = tryMakeLockHandle P.lockPool file+tryLockExclusive mode file = fmap fst <$> tryMakeLockHandle P.lockPool file (\p f -> P.tryTakeLock p f LockExclusive)- (\f -> fmap mk <$> F.tryLockExclusive mode f)+ (\f _ -> fmap mk <$> F.tryLockExclusive mode f) -- Returns Nothing when the file doesn't exist, for cases where -- that is different from it not being locked.@@ -67,8 +67,8 @@ (StatusLockedBy <$> getProcessID) (F.getLockStatus file) -mk :: F.LockHandle -> FileLockOps-mk h = FileLockOps+mk :: F.LockHandle -> (FileLockOps, ())+mk h = (FileLockOps { fDropLock = F.dropLock h , fCheckSaneLock = \f -> F.checkSaneLock f h- }+ }, ())
Utility/LockPool/STM.hs view
@@ -1,6 +1,6 @@ {- STM implementation of lock pools. -- - Copyright 2015-2020 Joey Hess <id@joeyh.name>+ - Copyright 2015-2021 Joey Hess <id@joeyh.name> - - License: BSD-2-clause -}@@ -11,12 +11,15 @@ LockFile, LockMode(..), LockHandle,+ FirstLock(..),+ FirstLockSemVal(..), waitTakeLock, tryTakeLock, getLockStatus, releaseLock, CloseLockFile, registerCloseLockFile,+ registerPostReleaseLock, ) where import Utility.Monad@@ -26,9 +29,6 @@ import qualified Data.Map.Strict as M import Control.Concurrent.STM import Control.Exception-import Control.Monad-import Control.Applicative-import Prelude type LockFile = RawFilePath @@ -39,12 +39,29 @@ -- closed. type LockHandle = TMVar (LockPool, LockFile, CloseLockFile) -type LockCount = Integer+-- When a shared lock is taken, this will only be true for the first+-- process, not subsequent processes. The first process should+-- fill the FirstLockSem after doing any IO actions to finish lock setup+-- and subsequent processes can block on that getting filled to know+-- when the lock is fully set up.+data FirstLock = FirstLock Bool FirstLockSem -data LockStatus = LockStatus LockMode LockCount+type FirstLockSem = TMVar FirstLockSemVal +data FirstLockSemVal = FirstLockSemWaited Bool | FirstLockSemTried Bool++type LockCount = Integer++-- Action that closes the underlying lock file. When this is used+-- in a LockHandle, it closes a resource that is specific to that+-- LockHandle (such as eg a file handle), but does not release+-- any other shared locks. When this is used in a LockStatus,+-- it closes a resource that should only be closed when there are no+-- other shared locks. type CloseLockFile = IO () +data LockStatus = LockStatus LockMode LockCount FirstLockSem CloseLockFile+ -- This TMVar is normally kept full. type LockPool = TMVar (M.Map LockFile LockStatus) @@ -62,32 +79,54 @@ -- the same shared lock should not be blocked on the exclusive lock. -- Keeping the whole Map in a TMVar accomplishes this, at the expense of -- sometimes retrying after unrelated changes in the map.-waitTakeLock :: LockPool -> LockFile -> LockMode -> STM LockHandle+waitTakeLock :: LockPool -> LockFile -> LockMode -> STM (LockHandle, FirstLock) waitTakeLock pool file mode = maybe retry return =<< tryTakeLock pool file mode -- Avoids blocking if another thread is holding a conflicting lock.-tryTakeLock :: LockPool -> LockFile -> LockMode -> STM (Maybe LockHandle)+tryTakeLock :: LockPool -> LockFile -> LockMode -> STM (Maybe (LockHandle, FirstLock)) tryTakeLock pool file mode = do m <- takeTMVar pool- let success v = do+ let success firstlock v = do putTMVar pool (M.insert file v m)- Just <$> newTMVar (pool, file, noop)+ tmv <- newTMVar (pool, file, noop)+ return (Just (tmv, firstlock)) case M.lookup file m of- Just (LockStatus mode' n)- | mode == LockShared && mode' == LockShared ->- success $ LockStatus mode (succ n)+ Just (LockStatus mode' n firstlocksem postreleaselock)+ | mode == LockShared && mode' == LockShared -> do+ fl@(FirstLock _ firstlocksem') <- if n == 0+ then FirstLock True <$> newEmptyTMVar+ else pure (FirstLock False firstlocksem)+ success fl $ LockStatus mode (succ n) firstlocksem' postreleaselock | n > 0 -> do putTMVar pool m return Nothing- _ -> success $ LockStatus mode 1+ _ -> do+ firstlocksem <- newEmptyTMVar+ success (FirstLock True firstlocksem) $+ LockStatus mode 1 firstlocksem noop -- Call after waitTakeLock or tryTakeLock, to register a CloseLockFile--- action to run when releasing the lock.+-- action to run when releasing the lock. This action should only+-- close the lock file associated with the LockHandle, while+-- leaving any other shared locks of the same file open. registerCloseLockFile :: LockHandle -> CloseLockFile -> STM () registerCloseLockFile h closelockfile = do (p, f, c) <- takeTMVar h putTMVar h (p, f, c >> closelockfile) +-- Register an action that should be run only once a lock has been+-- released. When there are multiple shared locks of the same file,+-- the action will only be run after all are released.+registerPostReleaseLock :: LockHandle -> CloseLockFile -> STM ()+registerPostReleaseLock h postreleaselock = do+ (p, f, _) <- readTMVar h+ m <- takeTMVar p+ case M.lookup f m of+ Nothing -> putTMVar p m+ Just (LockStatus mode cnt firstlocksem c) -> do+ let c' = c >> postreleaselock+ putTMVar p $ M.insert f (LockStatus mode cnt firstlocksem c') m+ -- Checks if a lock is being held. If it's held by the current process, -- runs the getdefault action; otherwise runs the checker action. --@@ -101,7 +140,7 @@ v <- atomically $ do m <- takeTMVar pool let threadlocked = case M.lookup file m of- Just (LockStatus _ n) | n > 0 -> True+ Just (LockStatus _ n _ _) | n > 0 -> True _ -> False if threadlocked then do@@ -112,25 +151,29 @@ Nothing -> getdefault Just restore -> bracket_ (return ()) restore checker --- Only runs action to close underlying lock file when this is the last--- user of the lock, and when the lock has not already been closed.+-- Releases the lock. When it is a shared lock, it may remain locked by+-- other LockHandles. -- -- Note that the lock pool is left empty while the CloseLockFile action -- is run, to avoid race with another thread trying to open the same lock--- file.+-- file. However, the pool is full again when the PostReleaseLock action+-- runs. releaseLock :: LockHandle -> IO () releaseLock h = go =<< atomically (tryTakeTMVar h) where go (Just (pool, file, closelockfile)) = do- m <- atomically $ do+ (m, postreleaselock) <- atomically $ do m <- takeTMVar pool return $ case M.lookup file m of- Just (LockStatus mode n)- | n == 1 -> (M.delete file m)+ Just (LockStatus mode n firstlocksem postreleaselock)+ | n == 1 -> (M.delete file m, postreleaselock) | otherwise ->- (M.insert file (LockStatus mode (pred n)) m)- Nothing -> m+ (M.insert file (LockStatus mode (pred n) firstlocksem postreleaselock) m, noop)+ Nothing -> (m, noop) () <- closelockfile atomically $ putTMVar pool m+ -- This action may access the pool, so run it only+ -- after the pool is restored.+ postreleaselock -- The LockHandle was already closed. go Nothing = return ()
Utility/LockPool/Windows.hs view
@@ -22,9 +22,9 @@ {- Tries to lock a file with a shared lock, which allows other processes to - also lock it shared. Fails if the file is exclusively locked. -} lockShared :: LockFile -> IO (Maybe LockHandle)-lockShared file = tryMakeLockHandle P.lockPool file+lockShared file = fmap fst <$> tryMakeLockHandle P.lockPool file (\p f -> P.tryTakeLock p f LockShared)- (\f -> fmap mk <$> F.lockShared f)+ (\f _ -> fmap mk <$> F.lockShared f) {- Tries to take an exclusive lock on a file. Fails if another process has - a shared or exclusive lock.@@ -33,16 +33,16 @@ - read or write by any other process. So for advisory locking of a file's - content, a separate LockFile should be used. -} lockExclusive :: LockFile -> IO (Maybe LockHandle)-lockExclusive file = tryMakeLockHandle P.lockPool file+lockExclusive file = fmap fst <$> tryMakeLockHandle P.lockPool file (\p f -> P.tryTakeLock p f LockExclusive)- (\f -> fmap mk <$> F.lockExclusive f)+ (\f _ -> fmap mk <$> F.lockExclusive f) {- If the initial lock fails, this is a BUSY wait, and does not - guarentee FIFO order of waiters. In other news, Windows is a POS. -} waitToLock :: IO (Maybe lockhandle) -> IO lockhandle waitToLock = F.waitToLock -mk :: F.LockHandle -> FileLockOps-mk h = FileLockOps+mk :: F.LockHandle -> (FileLockOps, ())+mk h = (FileLockOps { fDropLock = F.dropLock h- }+ }, ())
doc/git-annex.mdwn view
@@ -1061,8 +1061,13 @@ are automatically merged into the local git-annex branch, so that git-annex has the most up-to-date possible knowledge. - To avoid that merging, set this to "false". This can be useful- particularly when you don't have write permission to the repository.+ To avoid that merging, set this to "false". ++ This can be useful particularly when you don't have write permission+ to the repository. While git-annex is mostly able to work in a read-only+ repository with unmerged git-annex branches, some things do not work,+ and when it does work it will be slower due to needing to look at each of+ the unmerged branches. * `annex.private`
git-annex.cabal view
@@ -1,5 +1,5 @@ Name: git-annex-Version: 8.20211123+Version: 8.20211231 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess <id@joeyh.name>@@ -1052,6 +1052,7 @@ Types.Transfer Types.Transferrer Types.TransferrerPool+ Types.Transitions Types.TrustLevel Types.UUID Types.UrlContents