diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -19,10 +19,8 @@ getState, changeState, withState, - setFlag, setField, setOutput, - getFlag, getField, addCleanupAction, gitRepo, @@ -123,6 +121,13 @@ , debugenabled :: Bool , debugselector :: DebugSelector , ciphers :: TMVar (M.Map StorableCipher Cipher) + , fast :: Bool + , force :: Bool + , forcenumcopies :: Maybe NumCopies + , forcemincopies :: Maybe MinCopies + , forcebackend :: Maybe String + , useragent :: Maybe String + , desktopnotify :: DesktopNotify } newAnnexRead :: GitConfig -> IO AnnexRead @@ -144,6 +149,13 @@ , debugenabled = annexDebug c , debugselector = debugSelectorFromGitConfig c , ciphers = cm + , fast = False + , force = False + , forcebackend = Nothing + , forcenumcopies = Nothing + , forcemincopies = Nothing + , useragent = Nothing + , desktopnotify = mempty } -- Values that can change while running an Annex action. @@ -159,8 +171,6 @@ , remotes :: [Types.Remote.RemoteA Annex] , output :: MessageState , concurrency :: ConcurrencySetting - , force :: Bool - , fast :: Bool , daemon :: Bool , branchstate :: BranchState , repoqueue :: Maybe (Git.Queue.Queue Annex) @@ -168,11 +178,8 @@ , hashobjecthandle :: Maybe HashObjectHandle , checkattrhandle :: Maybe (ResourcePool CheckAttrHandle) , checkignorehandle :: Maybe (ResourcePool CheckIgnoreHandle) - , forcebackend :: Maybe String , globalnumcopies :: Maybe NumCopies , globalmincopies :: Maybe MinCopies - , forcenumcopies :: Maybe NumCopies - , forcemincopies :: Maybe MinCopies , limit :: ExpandableMatcher Annex , timelimit :: Maybe (Duration, POSIXTime) , sizelimit :: Maybe (TVar Integer) @@ -184,18 +191,15 @@ , trustmap :: Maybe TrustMap , groupmap :: Maybe GroupMap , lockcache :: LockCache - , flags :: M.Map String Bool , fields :: M.Map String String , cleanupactions :: M.Map CleanupAction (Annex ()) , sentinalstatus :: Maybe SentinalStatus - , useragent :: Maybe String , errcounter :: Integer , skippedfiles :: Bool , adjustedbranchrefreshcounter :: Integer , unusedkeys :: Maybe (S.Set Key) , tempurls :: M.Map Key URLString , existinghooks :: M.Map Git.Hook.Hook Bool - , desktopnotify :: DesktopNotify , workers :: Maybe (TMVar (WorkerPool (AnnexState, AnnexRead))) , cachedcurrentbranch :: (Maybe (Maybe Git.Branch, Maybe Adjustment)) , cachedgitenv :: Maybe (AltIndexFile, FilePath, [(String, String)]) @@ -220,8 +224,6 @@ , remotes = [] , output = o , concurrency = ConcurrencyCmdLine NonConcurrent - , force = False - , fast = False , daemon = False , branchstate = startBranchState , repoqueue = Nothing @@ -229,11 +231,8 @@ , hashobjecthandle = Nothing , checkattrhandle = Nothing , checkignorehandle = Nothing - , forcebackend = Nothing , globalnumcopies = Nothing , globalmincopies = Nothing - , forcenumcopies = Nothing - , forcemincopies = Nothing , limit = BuildingMatcher [] , timelimit = Nothing , sizelimit = Nothing @@ -245,18 +244,15 @@ , trustmap = Nothing , groupmap = Nothing , lockcache = M.empty - , flags = M.empty , fields = M.empty , cleanupactions = M.empty , sentinalstatus = Nothing - , useragent = Nothing , errcounter = 0 , skippedfiles = False , adjustedbranchrefreshcounter = 0 , unusedkeys = Nothing , tempurls = M.empty , existinghooks = M.empty - , desktopnotify = mempty , workers = Nothing , cachedcurrentbranch = Nothing , cachedgitenv = Nothing @@ -327,11 +323,6 @@ mvar <- fst <$> ask liftIO $ modifyMVar mvar modifier -{- Sets a flag to True -} -setFlag :: String -> Annex () -setFlag flag = changeState $ \st -> - st { flags = M.insert flag True $ flags st } - {- Sets a field to a value -} setField :: String -> String -> Annex () setField field value = changeState $ \st -> @@ -347,10 +338,6 @@ setOutput o = changeState $ \st -> let m = output st in st { output = m { outputType = adjustOutputType (outputType m) o } } - -{- Checks if a flag was set. -} -getFlag :: String -> Annex Bool -getFlag flag = fromMaybe False . M.lookup flag <$> getState flags {- Gets the value of a field. -} getField :: String -> Annex (Maybe String) diff --git a/Annex/AdjustedBranch.hs b/Annex/AdjustedBranch.hs --- a/Annex/AdjustedBranch.hs +++ b/Annex/AdjustedBranch.hs @@ -207,7 +207,7 @@ go currbranch = do let origbranch = fromAdjustedBranch currbranch let adjbranch = adjBranch $ originalToAdjusted origbranch adj - ifM (inRepo (Git.Ref.exists adjbranch) <&&> (not <$> Annex.getState Annex.force)) + ifM (inRepo (Git.Ref.exists adjbranch) <&&> (not <$> Annex.getRead Annex.force)) ( do mapM_ (warning . unwords) [ [ "adjusted branch" diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -1,6 +1,6 @@ {- management of the git-annex branch - - - Copyright 2011-2021 Joey Hess + - Copyright 2011-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,6 +23,8 @@ getUnmergedRefs, RegardingUUID(..), change, + ChangeOrAppend(..), + changeOrAppend, maybeChange, commitMessage, createMessage, @@ -48,7 +50,7 @@ import Control.Concurrent.MVar import qualified System.FilePath.ByteString as P -import Annex.Common +import Annex.Common hiding (append) import Types.BranchState import Annex.BranchState import Annex.Journal @@ -404,6 +406,56 @@ in when (v /= b) $ set jl ru file b _ -> noop +data ChangeOrAppend t = Change t | Append t + +{- Applies a function that can either modify the content of the file, + - or append to the file. Appending can be more efficient when several + - lines are written to a file in succession. + - + - When annex.alwayscompact=false, the function is not passed the content + - of the journal file when the journal file already exists, and whatever + - value it provides is always appended to the journal file. That avoids + - reading the journal file, and so can be faster when many lines are being + - written to it. The information that is recorded will be effectively the + - same, only obsolate log lines will not get compacted. + - + - Currently, only appends when annex.alwayscompact=false. That is to + - avoid appending when an older version of git-annex is also in use in the + - same repository. An interrupted append could leave the journal file in a + - state that would confuse the older version. This is planned to be + - changed in a future repository version. + -} +changeOrAppend :: Journalable content => RegardingUUID -> RawFilePath -> (L.ByteString -> ChangeOrAppend content) -> Annex () +changeOrAppend ru file f = lockJournal $ \jl -> + checkCanAppendJournalFile jl ru file >>= \case + Just appendable -> ifM (annexAlwaysCompact <$> Annex.getGitConfig) + ( do + oldc <- getToChange ru file + case f oldc of + Change newc -> set jl ru file newc + Append toappend -> + set jl ru file $ + oldc <> journalableByteString toappend + -- Use this instead in v11 + -- or whatever. + -- append jl file appendable toappend + , case f mempty of + -- Append even though a change was + -- requested; since mempty was passed in, + -- the lines requested to change are + -- minimized. + Change newc -> append jl file appendable newc + Append toappend -> append jl file appendable toappend + ) + Nothing -> do + oldc <- getToChange ru file + case f oldc of + Change newc -> set jl ru file newc + -- Journal file does not exist yet, so + -- cannot append and have to write it all. + Append toappend -> set jl ru file $ + oldc <> journalableByteString toappend + {- Only get private information when the RegardingUUID is itself private. -} getToChange :: RegardingUUID -> RawFilePath -> Annex L.ByteString getToChange ru f = flip getLocal' f . GetPrivate =<< regardingPrivateUUID ru @@ -426,6 +478,14 @@ -- evaluating a Journalable Builder twice, which is not very -- efficient. Instead, assume that it's not common to need to read -- a log file immediately after writing it. + invalidateCache + +{- Appends content to the journal file. -} +append :: Journalable content => JournalLocked -> RawFilePath -> AppendableJournalFile -> content -> Annex () +append jl f appendable toappend = do + journalChanged + appendJournalFile jl appendable toappend + fastDebug "Annex.Branch" ("append " ++ fromRawFilePath f) invalidateCache {- Commit message used when making a commit of whatever data has changed diff --git a/Annex/BranchState.hs b/Annex/BranchState.hs --- a/Annex/BranchState.hs +++ b/Annex/BranchState.hs @@ -2,7 +2,7 @@ - - Runtime state about the git-annex branch, and a small cache. - - - Copyright 2011-2021 Joey Hess + - Copyright 2011-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -54,7 +54,7 @@ - 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, + - problem, the journal is still read every time. -} runUpdateOnce :: Annex UpdateMade -> Annex BranchState runUpdateOnce update = do @@ -92,9 +92,9 @@ -- so avoid an unnecessary write to the MVar that changeState -- would do. -- - -- This assumes that another thread is not changing journalIgnorable + -- This assumes that another thread is not setting journalIgnorable -- at the same time, but since runUpdateOnce is the only - -- thing that changes it, and it only runs once, that + -- thing that sets it, and it only runs once, that -- should not happen. st <- getState when (journalIgnorable st) $ @@ -109,8 +109,10 @@ - will be seen. -} enableInteractiveBranchAccess :: Annex () -enableInteractiveBranchAccess = changeState $ - \s -> s { needInteractiveAccess = True } +enableInteractiveBranchAccess = changeState $ \s -> s + { needInteractiveAccess = True + , journalIgnorable = False + } setCache :: RawFilePath -> L.ByteString -> Annex () setCache file content = changeState $ \s -> s diff --git a/Annex/CheckIgnore.hs b/Annex/CheckIgnore.hs --- a/Annex/CheckIgnore.hs +++ b/Annex/CheckIgnore.hs @@ -25,7 +25,7 @@ checkIgnored :: CheckGitIgnore -> RawFilePath -> Annex Bool checkIgnored (CheckGitIgnore False) _ = pure False checkIgnored (CheckGitIgnore True) file = - ifM (Annex.getState Annex.force) + ifM (Annex.getRead Annex.force) ( pure False , withCheckIgnoreHandle $ \h -> liftIO $ Git.checkIgnored h file ) diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -107,7 +107,7 @@ {- Allows specifying the size of the key, if it's known, which is useful - as not all keys know their size. -} checkDiskSpace' :: Integer -> Maybe RawFilePath -> Key -> Integer -> Bool -> Annex Bool -checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getState Annex.force) +checkDiskSpace' need destdir key alreadythere samefilesystem = ifM (Annex.getRead Annex.force) ( return True , do -- We can't get inprogress and free at the same diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -325,7 +325,7 @@ - checked in, CheckGitIgnore True has no effect. -} gitAddParams :: CheckGitIgnore -> Annex [CommandParam] -gitAddParams (CheckGitIgnore True) = ifM (Annex.getState Annex.force) +gitAddParams (CheckGitIgnore True) = ifM (Annex.getRead Annex.force) ( return [Param "-f"] , return [] ) diff --git a/Annex/Journal.hs b/Annex/Journal.hs --- a/Annex/Journal.hs +++ b/Annex/Journal.hs @@ -4,12 +4,16 @@ - git-annex branch. Among other things, it ensures that if git-annex is - interrupted, its recorded data is not lost. - - - Copyright 2011-2021 Joey Hess + - All files in the journal must be a series of lines separated by + - newlines. - + - Copyright 2011-2022 Joey Hess + - - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} module Annex.Journal where @@ -20,6 +24,7 @@ import Annex.Tmp import Annex.LockFile import Utility.Directory.Stream +import qualified Utility.RawFilePath as R import qualified Data.Set as S import qualified Data.ByteString.Lazy as L @@ -71,9 +76,9 @@ - Using the journal, rather than immediatly staging content to the index - avoids git needing to rewrite the index after every change. - - - The file in the journal is updated atomically, which allows - - getJournalFileStale to always return a consistent journal file - - content, although possibly not the most current one. + - The file in the journal is updated atomically. This avoids an + - interrupted write truncating information that was earlier read from the + - file, and so losing data. -} setJournalFile :: Journalable content => JournalLocked -> RegardingUUID -> RawFilePath -> content -> Annex () setJournalFile _jl ru file content = withOtherTmp $ \tmp -> do @@ -81,15 +86,60 @@ ( return gitAnnexPrivateJournalDir , return gitAnnexJournalDir ) - createAnnexDirectory jd -- journal file is written atomically let jfile = journalFile file let tmpfile = tmp P. jfile - liftIO $ do - withFile (fromRawFilePath tmpfile) WriteMode $ \h -> - writeJournalHandle h content - moveFile tmpfile (jd P. jfile) + liftIO $ withFile (fromRawFilePath tmpfile) WriteMode $ \h -> + writeJournalHandle h content + let mv = liftIO $ moveFile tmpfile (jd P. jfile) + -- avoid overhead of creating the journal directory when it already + -- exists + mv `catchIO` (const (createAnnexDirectory jd >> mv)) +newtype AppendableJournalFile = AppendableJournalFile (RawFilePath, RawFilePath) + +{- If the journal file does not exist, it cannot be appended to, because + - that would overwrite whatever content the file has in the git-annex + - branch. -} +checkCanAppendJournalFile :: JournalLocked -> RegardingUUID -> RawFilePath -> Annex (Maybe AppendableJournalFile) +checkCanAppendJournalFile _jl ru file = do + jd <- fromRepo =<< ifM (regardingPrivateUUID ru) + ( return gitAnnexPrivateJournalDir + , return gitAnnexJournalDir + ) + let jfile = jd P. journalFile file + ifM (liftIO $ R.doesPathExist jfile) + ( return (Just (AppendableJournalFile (jd, jfile))) + , return Nothing + ) + +{- Appends content to an existing journal file. + - + - Appends are not necessarily atomic, though short appends often are. + - So, when this is interrupted, it can leave only part of the content + - written to the file. To deal with that situation, both this and + - getJournalFileStale check if the file ends with a newline, and if + - not discard the incomplete line. + - + - Due to the lack of atomicity, this should not be used when multiple + - lines need to be written to the file as an atomic unit. + -} +appendJournalFile :: Journalable content => JournalLocked -> AppendableJournalFile -> content -> Annex () +appendJournalFile _jl (AppendableJournalFile (jd, jfile)) content = do + let write = liftIO $ withFile (fromRawFilePath jfile) ReadWriteMode $ \h -> do + sz <- hFileSize h + when (sz /= 0) $ do + hSeek h SeekFromEnd (-1) + lastchar <- B.hGet h 1 + unless (lastchar == "\n") $ do + hSeek h AbsoluteSeek 0 + goodpart <- L.length . discardIncompleteAppend + <$> L.hGet h (fromIntegral sz) + hSetFileSize h (fromIntegral goodpart) + hSeek h SeekFromEnd 0 + writeJournalHandle h content + write `catchIO` (const (createAnnexDirectory jd >> write)) + data JournalledContent = NoJournalledContent | JournalledContent L.ByteString @@ -109,15 +159,17 @@ data GetPrivate = GetPrivate Bool {- Without locking, this is not guaranteed to be the most recent - - version of the file in the journal, so should not be used as a basis for - - changes. + - content of the file in the journal, so should not be used as a basis for + - making changes to the file. - - The file is read strictly so that its content can safely be fed into - - an operation that modifies the file. While setJournalFile doesn't - - write directly to journal files and so probably avoids problems with - - writing to the same file that's being read, but there could be - - concurrency or other issues with a lazy read, and the minor loss of - - laziness doesn't matter much, as the files are not very large. + - an operation that modifies the file (when getJournalFile calls this). + - The minor loss of laziness doesn't matter much, as the files are not + - very large. + - + - To recover from an append of a line that is interrupted part way through + - (or is in progress when this is called), if the file content does not end + - with a newline, it is truncated back to the previous newline. -} getJournalFileStale :: GetPrivate -> RawFilePath -> Annex JournalledContent getJournalFileStale (GetPrivate getprivate) file = do @@ -144,7 +196,22 @@ where jfile = journalFile file getfrom d = catchMaybeIO $ - L.fromStrict <$> B.readFile (fromRawFilePath (d P. jfile)) + discardIncompleteAppend . L.fromStrict + <$> B.readFile (fromRawFilePath (d P. jfile)) + +-- Note that this forces read of the whole lazy bytestring. +discardIncompleteAppend :: L.ByteString -> L.ByteString +discardIncompleteAppend v + | L.null v = v + | L.last v == nl = v + | otherwise = dropwhileend (/= nl) v + where + nl = fromIntegral (ord '\n') +#if MIN_VERSION_bytestring(0,11,2) + dropwhileend = L.dropWhileEnd +#else + dropwhileend p = L.reverse . L.dropWhile p . L.reverse +#endif {- List of existing journal files in a journal directory, but without locking, - may miss new ones just being added, or may have false positives if the diff --git a/Annex/Notification.hs b/Annex/Notification.hs --- a/Annex/Notification.hs +++ b/Annex/Notification.hs @@ -34,7 +34,7 @@ notifyTransfer direction t a = case descTransfrerrable t of Nothing -> a NotifyWitness Just desc -> do - wanted <- Annex.getState Annex.desktopnotify + wanted <- Annex.getRead Annex.desktopnotify if (notifyStart wanted || notifyFinish wanted) then do client <- liftIO DBus.Client.connectSession @@ -57,7 +57,7 @@ notifyDrop (AssociatedFile Nothing) _ = noop #ifdef WITH_DBUS_NOTIFICATIONS notifyDrop (AssociatedFile (Just f)) ok = do - wanted <- Annex.getState Annex.desktopnotify + wanted <- Annex.getRead Annex.desktopnotify when (notifyFinish wanted) $ liftIO $ do client <- DBus.Client.connectSession void $ Notify.notify client (droppedNote ok (fromRawFilePath f)) diff --git a/Annex/NumCopies.hs b/Annex/NumCopies.hs --- a/Annex/NumCopies.hs +++ b/Annex/NumCopies.hs @@ -57,11 +57,11 @@ {- Value forced on the command line by --numcopies. -} getForcedNumCopies :: Annex (Maybe NumCopies) -getForcedNumCopies = Annex.getState Annex.forcenumcopies +getForcedNumCopies = Annex.getRead Annex.forcenumcopies {- Value forced on the command line by --mincopies. -} getForcedMinCopies :: Annex (Maybe MinCopies) -getForcedMinCopies = Annex.getState Annex.forcemincopies +getForcedMinCopies = Annex.getRead Annex.forcemincopies {- NumCopies value from any of the non-.gitattributes configuration - sources. -} diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -48,7 +48,7 @@ defaultUserAgent = "git-annex/" ++ BuildInfo.packageversion getUserAgent :: Annex U.UserAgent -getUserAgent = Annex.getState $ +getUserAgent = Annex.getRead $ fromMaybe defaultUserAgent . Annex.useragent getUrlOptions :: Annex U.UrlOptions diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -118,7 +118,7 @@ -- and any files in the workdir that it may have partially downloaded -- before. youtubeDlMaxSize :: FilePath -> Annex (Either String [CommandParam]) -youtubeDlMaxSize workdir = ifM (Annex.getState Annex.force) +youtubeDlMaxSize workdir = ifM (Annex.getRead Annex.force) ( return $ Right [] , liftIO (getDiskFree workdir) >>= \case Just have -> do diff --git a/Assistant/Install.hs b/Assistant/Install.hs --- a/Assistant/Install.hs +++ b/Assistant/Install.hs @@ -184,7 +184,6 @@ clean environ | null vars = Nothing | otherwise = Just $ catMaybes $ map (restoreorig environ) environ - | otherwise = Nothing where vars = words $ fromMaybe "" $ lookup "GIT_ANNEX_STANDLONE_ENV" environ diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -57,7 +57,7 @@ | canWatch = do #ifndef mingw32_HOST_OS liftIO Lsof.setup - unlessM (liftIO (inSearchPath "lsof") <||> Annex.getState Annex.force) + unlessM (liftIO (inSearchPath "lsof") <||> Annex.getRead Annex.force) needLsof #else noop diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -207,13 +207,13 @@ unless tarok $ error $ "failed to untar " ++ distributionfile sanitycheck $ tmpdir installBase - installby rename newdir (tmpdir installBase) + installby R.rename newdir (tmpdir installBase) let deleteold = do deleteFromManifest olddir makeorigsymlink olddir return (newdir "git-annex", deleteold) installby a dstdir srcdir = - mapM_ (\x -> a x (dstdir takeFileName x)) + mapM_ (\x -> a (toRawFilePath x) (toRawFilePath (dstdir takeFileName x))) =<< dirContents srcdir #endif sanitycheck dir = diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs --- a/Assistant/WebApp/Configurators/Local.hs +++ b/Assistant/WebApp/Configurators/Local.hs @@ -45,6 +45,7 @@ import qualified Data.Map as M import Data.Char import Data.Ord +import Data.Kind import qualified Text.Hamlet as Hamlet data RepositoryPath = RepositoryPath Text @@ -54,7 +55,7 @@ - - Validates that the path entered is not empty, and is a safe value - to use as a repository. -} -repositoryPathField :: forall (m :: * -> *). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text +repositoryPathField :: forall (m :: Type -> Type). (MonadIO m, HandlerSite m ~ WebApp) => Bool -> Field m Text repositoryPathField autofocus = Field { fieldParse = \l _ -> parse l , fieldEnctype = UrlEncoded diff --git a/Backend.hs b/Backend.hs --- a/Backend.hs +++ b/Backend.hs @@ -44,7 +44,7 @@ where cache = do n <- maybe (annexBackend <$> Annex.getGitConfig) (return . Just) - =<< Annex.getState Annex.forcebackend + =<< Annex.getRead Annex.forcebackend b <- case n of Just name | valid name -> lookupname name _ -> pure (Prelude.head builtinList) @@ -79,7 +79,7 @@ - That can be configured on a per-file basis in the gitattributes file, - or forced with --backend. -} chooseBackend :: RawFilePath -> Annex (Maybe Backend) -chooseBackend f = Annex.getState Annex.forcebackend >>= go +chooseBackend f = Annex.getRead Annex.forcebackend >>= go where go Nothing = maybeLookupBackendVariety . parseKeyVariety . encodeBS =<< checkAttr "annex.backend" f diff --git a/Backend/Hash.hs b/Backend/Hash.hs --- a/Backend/Hash.hs +++ b/Backend/Hash.hs @@ -120,7 +120,7 @@ checkKeyChecksum :: Hash -> Key -> RawFilePath -> Annex Bool checkKeyChecksum hash key file = catchIOErrorType HardwareFault hwfault $ do - fast <- Annex.getState Annex.fast + fast <- Annex.getRead Annex.fast exists <- liftIO $ R.doesPathExist file case (exists, fast) of (True, False) -> do diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,30 @@ +git-annex (10.20220724) upstream; urgency=medium + + * filter-process: Fix a bug involving handling of empty files, + that caused git to kill git-annex filter-process. + * add: Fix reversion when adding an annex link that has been moved to + another directory. (Introduced in version 10.20220624) + * Added annex.alwayscompact setting which can be unset to speed up + writes to the git-annex branch in some cases. See its documentation + for important notes on when it's appropariate to use. + * adb: Added configuration setting oldandroid=true to avoid using + find -printf, which was first supported in Android around 2019-2020. + This may need to be enabled for old android devices that used to work + without it being set, since version 10.20220222 started using + find -printf. + * --backend is no longer a global option, and is only accepted by + commands that actually need it. + * Improve handling of parallelization with -J when copying content + from/to a git remote that is a local path. + * S3: Avoid writing or checking the uuid file in the S3 bucket when + importtree=yes or exporttree=yes. + * Fix a reversion that prevented --batch commands (and the assistant) + from noticing data written to the journal by other commands. + * Fix building with the Assistant build flag disabled but the Webapp + build flag enabled. + + -- Joey Hess Mon, 25 Jul 2022 12:55:38 -0400 + git-annex (10.20220624) upstream; urgency=medium * init: Added --no-autoenable option. diff --git a/CmdLine.hs b/CmdLine.hs --- a/CmdLine.hs +++ b/CmdLine.hs @@ -53,14 +53,14 @@ where go (Right g) = do g' <- Git.Config.read g - (cmd, seek, globalsetter) <- parsewith False cmdparser + (cmd, seek, annexsetter) <- parsewith False cmdparser (\a -> a (Just g')) O.handleParseResult - state <- applyAnnexReadSetter globalsetter <$> Annex.new g' + state <- applyAnnexReadSetter annexsetter <$> Annex.new g' Annex.eval state $ do checkEnvironment forM_ fields $ uncurry Annex.setField - prepRunCommand cmd globalsetter + prepRunCommand cmd annexsetter startup performCommandAction True cmd seek $ shutdown $ cmdnocommit cmd @@ -101,7 +101,7 @@ Just n -> n:args {- Parses command line, selecting one of the commands from the list. -} -parseCmd :: String -> String -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, GlobalSetter) +parseCmd :: String -> String -> CmdParams -> [Command] -> (Command -> O.Parser v) -> O.ParserResult (Command, v, AnnexSetter) parseCmd progname progdesc allargs allcmds getparser = O.execParserPure (O.prefs O.idm) pinfo allargs where @@ -114,7 +114,7 @@ mkparser c = (,,) <$> pure c <*> getparser c - <*> parserGlobalOptions (cmdglobaloptions c) + <*> parserAnnexOptions (cmdannexoptions c) synopsis n d = n ++ " - " ++ d intro = mconcat $ concatMap (\l -> [H.text l, H.line]) (synopsis progname progdesc : commandList allcmds) @@ -141,14 +141,14 @@ | "-" `isPrefixOf` a = findname as (a:c) | otherwise = (Just a, reverse c ++ as) --- | Note that the GlobalSetter must have already had its annexReadSetter +-- | Note that the AnnexSetter must have already had its annexReadSetter -- applied before entering the Annex monad to run this; that cannot be -- changed while running in the Annex monad. -prepRunCommand :: Command -> GlobalSetter -> Annex () -prepRunCommand cmd globalsetter = do +prepRunCommand :: Command -> AnnexSetter -> Annex () +prepRunCommand cmd annexsetter = do when (cmdnomessages cmd) $ Annex.setOutput QuietOutput - annexStateSetter globalsetter + annexStateSetter annexsetter whenM (Annex.getRead Annex.debugenabled) $ enableDebugOutput @@ -186,7 +186,7 @@ , cmdparamdesc = "[PARAMS]" , cmdsection = SectionAddOn , cmddesc = "addon command" - , cmdglobaloptions = [] + , cmdannexoptions = [] , cmdinfomod = O.forwardOptions , cmdparser = parse , cmdnorepo = Just parse diff --git a/CmdLine/AnnexSetter.hs b/CmdLine/AnnexSetter.hs new file mode 100644 --- /dev/null +++ b/CmdLine/AnnexSetter.hs @@ -0,0 +1,36 @@ +{- git-annex options that are stored in Annex + - + - Copyright 2015-2021 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module CmdLine.AnnexSetter where + +import Common +import Annex +import Types.DeferredParse + +import Options.Applicative + +setAnnexState :: Annex () -> AnnexSetter +setAnnexState a = AnnexSetter a id + +setAnnexRead :: (AnnexRead -> AnnexRead) -> AnnexSetter +setAnnexRead f = AnnexSetter (return ()) f + +annexFlag :: AnnexSetter -> Mod FlagFields AnnexSetter -> AnnexOption +annexFlag = flag' + +annexOption :: (v -> AnnexSetter) -> Parser v -> AnnexOption +annexOption mk parser = mk <$> parser + +-- | Combines a bunch of AnnexOptions together into a Parser +-- that returns a AnnexSetter that can be used to set all the options that +-- are enabled. +parserAnnexOptions :: [AnnexOption] -> Parser AnnexSetter +parserAnnexOptions [] = pure mempty +parserAnnexOptions l = mconcat <$> many (foldl1 (<|>) l) + +applyAnnexReadSetter :: AnnexSetter -> (AnnexState, AnnexRead) -> (AnnexState, AnnexRead) +applyAnnexReadSetter gs (st, rd) = (st, annexReadSetter gs rd) diff --git a/CmdLine/GitAnnex.hs b/CmdLine/GitAnnex.hs --- a/CmdLine/GitAnnex.hs +++ b/CmdLine/GitAnnex.hs @@ -130,7 +130,7 @@ import qualified Command.Benchmark cmds :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [Command] -cmds testoptparser testrunner mkbenchmarkgenerator = map addGitAnnexGlobalOptions $ +cmds testoptparser testrunner mkbenchmarkgenerator = map addGitAnnexCommonOptions $ [ Command.Help.cmd , Command.Add.cmd , Command.Get.cmd @@ -245,8 +245,8 @@ mkbenchmarkgenerator $ cmds testoptparser testrunner (\_ _ -> return noop) ] -addGitAnnexGlobalOptions :: Command -> Command -addGitAnnexGlobalOptions c = c { cmdglobaloptions = gitAnnexGlobalOptions ++ cmdglobaloptions c } +addGitAnnexCommonOptions :: Command -> Command +addGitAnnexCommonOptions c = c { cmdannexoptions = gitAnnexCommonOptions ++ cmdannexoptions c } run :: Parser TestOptions -> TestRunner -> MkBenchmarkGenerator -> [String] -> IO () run testoptparser testrunner mkbenchmarkgenerator args = go envmodes diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -34,77 +34,77 @@ import qualified Limit.Wanted import CmdLine.Option import CmdLine.Usage -import CmdLine.GlobalSetter +import CmdLine.AnnexSetter import qualified Backend import qualified Types.Backend as Backend import Utility.HumanTime import Utility.DataUnits import Annex.Concurrent --- Global options that are accepted by all git-annex sub-commands, +-- Options that are accepted by all git-annex sub-commands, -- although not always used. -gitAnnexGlobalOptions :: [GlobalOption] -gitAnnexGlobalOptions = commonGlobalOptions ++ - [ globalOption (setAnnexState . setnumcopies) $ option auto +gitAnnexCommonOptions :: [AnnexOption] +gitAnnexCommonOptions = commonOptions ++ + [ annexOption setnumcopies $ option auto ( long "numcopies" <> short 'N' <> metavar paramNumber <> help "override desired number of copies" <> hidden ) - , globalOption (setAnnexState . setmincopies) $ option auto + , annexOption setmincopies $ option auto ( long "mincopies" <> short 'N' <> metavar paramNumber <> help "override minimum number of copies" <> hidden ) - , globalOption (setAnnexState . Remote.forceTrust Trusted) $ strOption + , annexOption (setAnnexState . Remote.forceTrust Trusted) $ strOption ( long "trust" <> metavar paramRemote <> help "deprecated, does not override trust setting" <> hidden <> completeRemotes ) - , globalOption (setAnnexState . Remote.forceTrust SemiTrusted) $ strOption + , annexOption (setAnnexState . Remote.forceTrust SemiTrusted) $ strOption ( long "semitrust" <> metavar paramRemote <> help "override trust setting back to default" <> hidden <> completeRemotes ) - , globalOption (setAnnexState . Remote.forceTrust UnTrusted) $ strOption + , annexOption (setAnnexState . Remote.forceTrust UnTrusted) $ strOption ( long "untrust" <> metavar paramRemote <> help "override trust setting to untrusted" <> hidden <> completeRemotes ) - , globalOption (setAnnexState . setgitconfig) $ strOption + , annexOption (setAnnexState . setgitconfig) $ strOption ( long "config" <> short 'c' <> metavar "NAME=VALUE" <> help "override git configuration setting" <> hidden ) - , globalOption (setAnnexState . setuseragent) $ strOption + , annexOption setuseragent $ strOption ( long "user-agent" <> metavar paramName <> help "override default User-Agent" <> hidden ) - , globalFlag (setAnnexState $ toplevelWarning False "--trust-glacier no longer has any effect") + , annexFlag (setAnnexState $ toplevelWarning False "--trust-glacier no longer has any effect") ( long "trust-glacier" <> help "deprecated, does not trust Amazon Glacier inventory" <> hidden ) - , globalFlag (setAnnexState $ setdesktopnotify mkNotifyFinish) + , annexFlag (setdesktopnotify mkNotifyFinish) ( long "notify-finish" <> help "show desktop notification after transfer finishes" <> hidden ) - , globalFlag (setAnnexState $ setdesktopnotify mkNotifyStart) + , annexFlag (setdesktopnotify mkNotifyStart) ( long "notify-start" <> help "show desktop notification after transfer starts" <> hidden ) ] where - setnumcopies n = Annex.changeState $ \s -> s { Annex.forcenumcopies = Just $ configuredNumCopies n } - setmincopies n = Annex.changeState $ \s -> s { Annex.forcemincopies = Just $ configuredMinCopies n } - setuseragent v = Annex.changeState $ \s -> s { Annex.useragent = Just v } + setnumcopies n = setAnnexRead $ \rd -> rd { Annex.forcenumcopies = Just $ configuredNumCopies n } + setmincopies n = setAnnexRead $ \rd -> rd { Annex.forcemincopies = Just $ configuredMinCopies n } + setuseragent v = setAnnexRead $ \rd -> rd { Annex.useragent = Just v } + setdesktopnotify v = setAnnexRead $ \rd -> rd { Annex.desktopnotify = Annex.desktopnotify rd <> v } setgitconfig v = Annex.addGitConfigOverride v - setdesktopnotify v = Annex.changeState $ \s -> s { Annex.desktopnotify = Annex.desktopnotify s <> v } {- Parser that accepts all non-option params. -} cmdParams :: CmdParamsDesc -> Parser CmdParams @@ -229,7 +229,7 @@ parseKey = maybe (Fail.fail "invalid key") return . deserializeKey -- Options to match properties of annexed files. -annexedMatchingOptions :: [GlobalOption] +annexedMatchingOptions :: [AnnexOption] annexedMatchingOptions = concat [ keyMatchingOptions' , fileMatchingOptions' Limit.LimitAnnexFiles @@ -239,86 +239,86 @@ ] -- Matching options that can operate on keys as well as files. -keyMatchingOptions :: [GlobalOption] +keyMatchingOptions :: [AnnexOption] keyMatchingOptions = keyMatchingOptions' ++ combiningOptions ++ timeLimitOption ++ sizeLimitOption -keyMatchingOptions' :: [GlobalOption] +keyMatchingOptions' :: [AnnexOption] keyMatchingOptions' = - [ globalOption (setAnnexState . Limit.addIn) $ strOption + [ annexOption (setAnnexState . Limit.addIn) $ strOption ( long "in" <> short 'i' <> metavar paramRemote <> help "match files present in a remote" <> hidden <> completeRemotes ) - , globalOption (setAnnexState . Limit.addCopies) $ strOption + , annexOption (setAnnexState . Limit.addCopies) $ strOption ( long "copies" <> short 'C' <> metavar paramRemote <> help "skip files with fewer copies" <> hidden ) - , globalOption (setAnnexState . Limit.addLackingCopies False) $ strOption + , annexOption (setAnnexState . Limit.addLackingCopies False) $ strOption ( long "lackingcopies" <> metavar paramNumber <> help "match files that need more copies" <> hidden ) - , globalOption (setAnnexState . Limit.addLackingCopies True) $ strOption + , annexOption (setAnnexState . Limit.addLackingCopies True) $ strOption ( long "approxlackingcopies" <> metavar paramNumber <> help "match files that need more copies (faster)" <> hidden ) - , globalOption (setAnnexState . Limit.addInBackend) $ strOption + , annexOption (setAnnexState . Limit.addInBackend) $ strOption ( long "inbackend" <> short 'B' <> metavar paramName <> help "match files using a key-value backend" <> hidden <> completeBackends ) - , globalFlag (setAnnexState Limit.addSecureHash) + , annexFlag (setAnnexState Limit.addSecureHash) ( long "securehash" <> help "match files using a cryptographically secure hash" <> hidden ) - , globalOption (setAnnexState . Limit.addInAllGroup) $ strOption + , annexOption (setAnnexState . Limit.addInAllGroup) $ strOption ( long "inallgroup" <> metavar paramGroup <> help "match files present in all remotes in a group" <> hidden ) - , globalOption (setAnnexState . Limit.addMetaData) $ strOption + , annexOption (setAnnexState . Limit.addMetaData) $ strOption ( long "metadata" <> metavar "FIELD=VALUE" <> help "match files with attached metadata" <> hidden ) - , globalFlag (setAnnexState Limit.Wanted.addWantGet) + , annexFlag (setAnnexState Limit.Wanted.addWantGet) ( long "want-get" <> help "match files the repository wants to get" <> hidden ) - , globalFlag (setAnnexState Limit.Wanted.addWantDrop) + , annexFlag (setAnnexState Limit.Wanted.addWantDrop) ( long "want-drop" <> help "match files the repository wants to drop" <> hidden ) - , globalOption (setAnnexState . Limit.addAccessedWithin) $ + , annexOption (setAnnexState . Limit.addAccessedWithin) $ option (eitherReader parseDuration) ( long "accessedwithin" <> metavar paramTime <> help "match files accessed within a time interval" <> hidden ) - , globalOption (setAnnexState . Limit.addMimeType) $ strOption + , annexOption (setAnnexState . Limit.addMimeType) $ strOption ( long "mimetype" <> metavar paramGlob <> help "match files by mime type" <> hidden ) - , globalOption (setAnnexState . Limit.addMimeEncoding) $ strOption + , annexOption (setAnnexState . Limit.addMimeEncoding) $ strOption ( long "mimeencoding" <> metavar paramGlob <> help "match files by mime encoding" <> hidden ) - , globalFlag (setAnnexState Limit.addUnlocked) + , annexFlag (setAnnexState Limit.addUnlocked) ( long "unlocked" <> help "match files that are unlocked" <> hidden ) - , globalFlag (setAnnexState Limit.addLocked) + , annexFlag (setAnnexState Limit.addLocked) ( long "locked" <> help "match files that are locked" <> hidden @@ -326,44 +326,44 @@ ] -- Options to match files which may not yet be annexed. -fileMatchingOptions :: Limit.LimitBy -> [GlobalOption] +fileMatchingOptions :: Limit.LimitBy -> [AnnexOption] fileMatchingOptions lb = fileMatchingOptions' lb ++ combiningOptions ++ timeLimitOption -fileMatchingOptions' :: Limit.LimitBy -> [GlobalOption] +fileMatchingOptions' :: Limit.LimitBy -> [AnnexOption] fileMatchingOptions' lb = - [ globalOption (setAnnexState . Limit.addExclude) $ strOption + [ annexOption (setAnnexState . Limit.addExclude) $ strOption ( long "exclude" <> short 'x' <> metavar paramGlob <> help "skip files matching the glob pattern" <> hidden ) - , globalOption (setAnnexState . Limit.addInclude) $ strOption + , annexOption (setAnnexState . Limit.addInclude) $ strOption ( long "include" <> short 'I' <> metavar paramGlob <> help "limit to files matching the glob pattern" <> hidden ) - , globalOption (setAnnexState . Limit.addExcludeSameContent) $ strOption + , annexOption (setAnnexState . Limit.addExcludeSameContent) $ strOption ( long "excludesamecontent" <> short 'x' <> metavar paramGlob <> help "skip files whose content is the same as another file matching the glob pattern" <> hidden ) - , globalOption (setAnnexState . Limit.addIncludeSameContent) $ strOption + , annexOption (setAnnexState . Limit.addIncludeSameContent) $ strOption ( long "includesamecontent" <> short 'I' <> metavar paramGlob <> help "limit to files whose content is the same as another file matching the glob pattern" <> hidden ) - , globalOption (setAnnexState . Limit.addLargerThan lb) $ strOption + , annexOption (setAnnexState . Limit.addLargerThan lb) $ strOption ( long "largerthan" <> metavar paramSize <> help "match files larger than a size" <> hidden ) - , globalOption (setAnnexState . Limit.addSmallerThan lb) $ strOption + , annexOption (setAnnexState . Limit.addSmallerThan lb) $ strOption ( long "smallerthan" <> metavar paramSize <> help "match files smaller than a size" <> hidden ) ] -combiningOptions :: [GlobalOption] +combiningOptions :: [AnnexOption] combiningOptions = [ longopt "not" "negate next option" , longopt "and" "both previous and next option must match" @@ -372,19 +372,19 @@ , shortopt ')' "close group of options" ] where - longopt o h = globalFlag (setAnnexState $ Limit.addSyntaxToken o) + longopt o h = annexFlag (setAnnexState $ Limit.addSyntaxToken o) ( long o <> help h <> hidden ) - shortopt o h = globalFlag (setAnnexState $ Limit.addSyntaxToken [o]) + shortopt o h = annexFlag (setAnnexState $ Limit.addSyntaxToken [o]) ( short o <> help h <> hidden ) -jsonOptions :: [GlobalOption] +jsonOptions :: [AnnexOption] jsonOptions = - [ globalFlag (setAnnexState $ Annex.setOutput (JSONOutput stdjsonoptions)) + [ annexFlag (setAnnexState $ Annex.setOutput (JSONOutput stdjsonoptions)) ( long "json" <> short 'j' <> help "enable JSON output" <> hidden ) - , globalFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonerrormessagesoptions)) + , annexFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonerrormessagesoptions)) ( long "json-error-messages" <> help "include error messages in JSON" <> hidden @@ -397,9 +397,9 @@ } jsonerrormessagesoptions = stdjsonoptions { jsonErrorMessages = True } -jsonProgressOption :: [GlobalOption] +jsonProgressOption :: [AnnexOption] jsonProgressOption = - [ globalFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonoptions)) + [ annexFlag (setAnnexState $ Annex.setOutput (JSONOutput jsonoptions)) ( long "json-progress" <> help "include progress in JSON output" <> hidden @@ -413,9 +413,9 @@ -- Note that a command that adds this option should wrap its seek -- action in `allowConcurrentOutput`. -jobsOption :: [GlobalOption] +jobsOption :: [AnnexOption] jobsOption = - [ globalOption (setAnnexState . setConcurrency . ConcurrencyCmdLine) $ + [ annexOption (setAnnexState . setConcurrency . ConcurrencyCmdLine) $ option (maybeReader parseConcurrency) ( long "jobs" <> short 'J' <> metavar (paramNumber `paramOr` "cpus") @@ -424,9 +424,9 @@ ) ] -timeLimitOption :: [GlobalOption] +timeLimitOption :: [AnnexOption] timeLimitOption = - [ globalOption settimelimit $ option (eitherReader parseDuration) + [ annexOption settimelimit $ option (eitherReader parseDuration) ( long "time-limit" <> short 'T' <> metavar paramTime <> help "stop after the specified amount of time" <> hidden @@ -438,9 +438,9 @@ let cutoff = start + durationToPOSIXTime duration Annex.changeState $ \s -> s { Annex.timelimit = Just (duration, cutoff) } -sizeLimitOption :: [GlobalOption] +sizeLimitOption :: [AnnexOption] sizeLimitOption = - [ globalOption setsizelimit $ option (maybeReader (readSize dataUnits)) + [ annexOption setsizelimit $ option (maybeReader (readSize dataUnits)) ( long "size-limit" <> metavar paramSize <> help "total size of annexed files to process" <> hidden @@ -450,6 +450,18 @@ setsizelimit n = setAnnexState $ do v <- liftIO $ newTVarIO n Annex.changeState $ \s -> s { Annex.sizelimit = Just v } + +backendOption :: [AnnexOption] +backendOption = + [ annexOption setforcebackend $ strOption + ( long "backend" <> short 'b' <> metavar paramName + <> help "specify key-value backend to use" + <> hidden + ) + ] + where + setforcebackend v = setAnnexRead $ + \rd -> rd { Annex.forcebackend = Just v } data DaemonOptions = DaemonOptions { foregroundDaemonOption :: Bool diff --git a/CmdLine/GitAnnexShell.hs b/CmdLine/GitAnnexShell.hs --- a/CmdLine/GitAnnexShell.hs +++ b/CmdLine/GitAnnexShell.hs @@ -11,7 +11,7 @@ import qualified Git.Construct import qualified Git.Config import CmdLine -import CmdLine.GlobalSetter +import CmdLine.AnnexSetter import Command import Annex.UUID import CmdLine.GitAnnexShell.Checks @@ -37,7 +37,7 @@ , (ServeReadWrite, allcmds) ] where - readonlycmds = map addGlobalOptions + readonlycmds = map addAnnexOptions [ Command.ConfigList.cmd , gitAnnexShellCheck Command.NotifyChanges.cmd -- p2pstdio checks the enviroment variables to @@ -46,10 +46,10 @@ , gitAnnexShellCheck Command.InAnnex.cmd , gitAnnexShellCheck Command.SendKey.cmd ] - appendcmds = readonlycmds ++ map addGlobalOptions + appendcmds = readonlycmds ++ map addAnnexOptions [ gitAnnexShellCheck Command.RecvKey.cmd ] - allcmds = appendcmds ++ map addGlobalOptions + allcmds = appendcmds ++ map addAnnexOptions [ gitAnnexShellCheck Command.DropKey.cmd , Command.GCryptSetup.cmd ] @@ -63,16 +63,16 @@ cmdsList :: [Command] cmdsList = nub $ concat $ M.elems cmdsMap -addGlobalOptions :: Command -> Command -addGlobalOptions c = c { cmdglobaloptions = globalOptions ++ cmdglobaloptions c } +addAnnexOptions :: Command -> Command +addAnnexOptions c = c { cmdannexoptions = commonShellOptions ++ cmdannexoptions c } -globalOptions :: [GlobalOption] -globalOptions = - globalOption (setAnnexState . checkUUID) (strOption +commonShellOptions :: [AnnexOption] +commonShellOptions = + annexOption (setAnnexState . checkUUID) (strOption ( long "uuid" <> metavar paramUUID <> help "local repository uuid" )) - : commonGlobalOptions + : commonOptions where checkUUID expected = getUUID >>= check where diff --git a/CmdLine/GlobalSetter.hs b/CmdLine/GlobalSetter.hs deleted file mode 100644 --- a/CmdLine/GlobalSetter.hs +++ /dev/null @@ -1,36 +0,0 @@ -{- git-annex global options - - - - Copyright 2015-2021 Joey Hess - - - - Licensed under the GNU AGPL version 3 or higher. - -} - -module CmdLine.GlobalSetter where - -import Common -import Annex -import Types.DeferredParse - -import Options.Applicative - -setAnnexState :: Annex () -> GlobalSetter -setAnnexState a = GlobalSetter a id - -setAnnexRead :: (AnnexRead -> AnnexRead) -> GlobalSetter -setAnnexRead f = GlobalSetter (return ()) f - -globalFlag :: GlobalSetter -> Mod FlagFields GlobalSetter -> GlobalOption -globalFlag = flag' - -globalOption :: (v -> GlobalSetter) -> Parser v -> GlobalOption -globalOption mk parser = mk <$> parser - --- | Combines a bunch of GlobalOptions together into a Parser --- that returns a GlobalSetter that can be used to set all the options that --- are enabled. -parserGlobalOptions :: [GlobalOption] -> Parser GlobalSetter -parserGlobalOptions [] = pure mempty -parserGlobalOptions l = mconcat <$> many (foldl1 (<|>) l) - -applyAnnexReadSetter :: GlobalSetter -> (AnnexState, AnnexRead) -> (AnnexState, AnnexRead) -applyAnnexReadSetter gs (st, rd) = (st, annexReadSetter gs rd) diff --git a/CmdLine/Option.hs b/CmdLine/Option.hs --- a/CmdLine/Option.hs +++ b/CmdLine/Option.hs @@ -11,8 +11,7 @@ import Options.Applicative -import CmdLine.Usage -import CmdLine.GlobalSetter +import CmdLine.AnnexSetter import qualified Annex import Types.Messages import Types.DeferredParse @@ -22,58 +21,50 @@ import Utility.FileSystemEncoding import Annex.Debug --- Global options accepted by both git-annex and git-annex-shell sub-commands. -commonGlobalOptions :: [GlobalOption] -commonGlobalOptions = - [ globalFlag (setAnnexState $ setforce True) +-- Options accepted by both git-annex and git-annex-shell sub-commands. +commonOptions :: [AnnexOption] +commonOptions = + [ annexFlag (setforce True) ( long "force" <> help "allow actions that may lose annexed data" <> hidden ) - , globalFlag (setAnnexState $ setfast True) + , annexFlag (setfast True) ( long "fast" <> short 'F' <> help "avoid slow operations" <> hidden ) - , globalFlag (setAnnexState $ Annex.setOutput QuietOutput) + , annexFlag (setAnnexState $ Annex.setOutput QuietOutput) ( long "quiet" <> short 'q' <> help "avoid verbose output" <> hidden ) - , globalFlag (setAnnexState $ Annex.setOutput NormalOutput) + , annexFlag (setAnnexState $ Annex.setOutput NormalOutput) ( long "verbose" <> short 'v' <> help "allow verbose output (default)" <> hidden ) - , globalFlag (setdebug True) + , annexFlag (setdebug True) ( long "debug" <> short 'd' <> help "show debug messages" <> hidden ) - , globalFlag (setdebug False) + , annexFlag (setdebug False) ( long "no-debug" <> help "don't show debug messages" <> hidden ) - , globalOption setdebugfilter $ strOption + , annexOption setdebugfilter $ strOption ( long "debugfilter" <> metavar "NAME[,NAME..]" <> help "show debug messages coming from a module" <> hidden ) - , globalOption setforcebackend $ strOption - ( long "backend" <> short 'b' <> metavar paramName - <> help "specify key-value backend to use" - <> hidden - ) ] where - setforce v = Annex.changeState $ \s -> s { Annex.force = v } + setforce v = setAnnexRead $ \rd -> rd { Annex.force = v } - setfast v = Annex.changeState $ \s -> s { Annex.fast = v } + setfast v = setAnnexRead $ \rd -> rd { Annex.fast = v } - setforcebackend v = setAnnexState $ - Annex.changeState $ \s -> s { Annex.forcebackend = Just v } - setdebug v = mconcat [ setAnnexRead $ \rd -> rd { Annex.debugenabled = v } -- Also set in git config so it will be passed on to any diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -64,7 +64,7 @@ seekHelper fst3 ww LsFiles.inRepoDetails l withFilesInGitAnnexNonRecursive :: WarnUnmatchWhen -> String -> AnnexedFileSeeker -> WorkTreeItems -> CommandSeek -withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.getState Annex.force) +withFilesInGitAnnexNonRecursive ww needforce a (WorkTreeItems l) = ifM (Annex.getRead Annex.force) ( withFilesInGitAnnex ww a (WorkTreeItems l) , if null l then giveup needforce @@ -90,7 +90,7 @@ withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek withFilesNotInGit (CheckGitIgnore ci) ww a l = do - force <- Annex.getState Annex.force + force <- Annex.getRead Annex.force let include_ignored = force || not ci seekFiltered (const (pure True)) a $ seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -18,7 +18,7 @@ import CmdLine.Usage as ReExported import CmdLine.Action as ReExported import CmdLine.Option as ReExported -import CmdLine.GlobalSetter as ReExported +import CmdLine.AnnexSetter as ReExported import CmdLine.GitAnnex.Options as ReExported import CmdLine.Batch as ReExported import Options.Applicative as ReExported hiding (command) @@ -69,9 +69,9 @@ noRepo :: (String -> Parser (IO ())) -> Command -> Command noRepo a c = c { cmdnorepo = Just (a (cmdparamdesc c)) } -{- Adds global options to a command. -} -withGlobalOptions :: [[GlobalOption]] -> Command -> Command -withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os } +{- Adds Annex options to a command. -} +withAnnexOptions :: [[AnnexOption]] -> Command -> Command +withAnnexOptions os c = c { cmdannexoptions = cmdannexoptions c ++ concat os } {- For start stage to indicate what will be done. -} starting:: MkActionItem actionitem => String -> actionitem -> SeekInput -> CommandPerform -> CommandStart diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -30,16 +30,17 @@ import qualified Utility.RawFilePath as R import qualified System.FilePath.ByteString as P -import System.PosixCompat.Files +import System.PosixCompat.Files (fileSize) cmd :: Command cmd = notBareRepo $ - withGlobalOptions opts $ + withAnnexOptions opts $ command "add" SectionCommon "add files to annex" paramPaths (seek <$$> optParser) where opts = - [ jobsOption + [ backendOption + , jobsOption , jsonOptions , jsonProgressOption , fileMatchingOptions LimitDiskFiles @@ -89,7 +90,7 @@ s <- liftIO $ R.getSymbolicLinkStatus file ifM (pure (annexdotfiles || not (dotfile file)) <&&> (checkFileMatcher largematcher file - <||> Annex.getState Annex.force)) + <||> Annex.getRead Annex.force)) ( start si file addunlockedmatcher , if includingsmall then ifM (annexAddSmallFiles <$> Annex.getGitConfig) @@ -209,7 +210,7 @@ starting "add" (ActionItemTreeFile file) si $ addingExistingLink file key $ withOtherTmp $ \tmp -> do - let tmpf = tmp P. file + let tmpf = tmp P. P.takeFileName file liftIO $ moveFile file tmpf ifM (isSymbolicLink <$> liftIO (R.getSymbolicLinkStatus tmpf)) ( do diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -37,7 +37,12 @@ import qualified System.FilePath.ByteString as P cmd :: Command -cmd = notBareRepo $ withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $ +cmd = notBareRepo $ withAnnexOptions + [ jobsOption + , jsonOptions + , jsonProgressOption + , backendOption + ] $ command "addurl" SectionCommon "add urls to annex" (paramRepeating paramUrl) (seek <$$> optParser) @@ -191,7 +196,7 @@ downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd o file $ \canadd -> do let urlkey = Backend.URL.fromUrl uri sz createWorkTreeDirectory (parentDir file) - ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) + ifM (Annex.getRead Annex.fast <||> pure (relaxedOption o)) ( do addWorkTree canadd addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing return (Just urlkey) @@ -305,7 +310,7 @@ -} addUrlFile :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> RawFilePath -> Annex (Maybe Key) addUrlFile addunlockedmatcher o url urlinfo file = - ifM (Annex.getState Annex.fast <||> pure (relaxedOption o)) + ifM (Annex.getRead Annex.fast <||> pure (relaxedOption o)) ( nodownloadWeb addunlockedmatcher o url urlinfo file , downloadWeb addunlockedmatcher o url urlinfo file ) diff --git a/Command/CalcKey.hs b/Command/CalcKey.hs --- a/Command/CalcKey.hs +++ b/Command/CalcKey.hs @@ -14,10 +14,11 @@ cmd :: Command cmd = noCommit $ noMessages $ dontCheck repoExists $ - command "calckey" SectionPlumbing - "calulate key for a file" - (paramRepeating paramFile) - (batchable run (pure ())) + withAnnexOptions [backendOption] $ + command "calckey" SectionPlumbing + "calulate key for a file" + (paramRepeating paramFile) + (batchable run (pure ())) run :: () -> SeekInput -> String -> Annex Bool run _ _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -14,7 +14,7 @@ import Annex.NumCopies cmd :: Command -cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ +cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ command "copy" SectionCommon "copy content of files to/from another repository" paramPaths (seek <--< optParser) diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -22,7 +22,7 @@ import Annex.Notification cmd :: Command -cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ +cmd = withAnnexOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ command "drop" SectionCommon "remove content of files from repository" paramPaths (seek <$$> optParser) @@ -201,7 +201,7 @@ -> (Maybe SafeDropProof -> CommandPerform, CommandPerform) -> CommandPerform doDrop pcc dropfrom contentlock key afile numcopies mincopies skip preverified check (dropaction, nodropaction) = - ifM (Annex.getState Annex.force) + ifM (Annex.getRead Annex.force) ( dropaction Nothing , ifM (checkRequiredContent pcc dropfrom key afile) ( verifyEnoughCopiesToDrop nolocmsg key diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -13,7 +13,7 @@ import Annex.Content cmd :: Command -cmd = noCommit $ withGlobalOptions [jsonOptions] $ +cmd = noCommit $ withAnnexOptions [jsonOptions] $ command "dropkey" SectionPlumbing "drops annexed content for specified keys" (paramRepeating paramKey) @@ -31,7 +31,7 @@ seek :: DropKeyOptions -> CommandSeek seek o = do - unlessM (Annex.getState Annex.force) $ + unlessM (Annex.getRead Annex.force) $ giveup "dropkey can cause data loss; use --force if you're sure you want to do this" case batchOption o of NoBatch -> withKeys (commandAction . start) (toDrop o) diff --git a/Command/DropUnused.hs b/Command/DropUnused.hs --- a/Command/DropUnused.hs +++ b/Command/DropUnused.hs @@ -53,7 +53,7 @@ Nothing -> ifM (inAnnex key) ( droplocal , ifM (objectFileExists key) - ( ifM (Annex.getState Annex.force) + ( ifM (Annex.getRead Annex.force) ( droplocal , do warning "Annexed object has been modified and dropping it would probably lose the only copy. Run this command with --force if you want to drop it anyway." diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -20,7 +20,7 @@ cmd :: Command cmd = noCommit $ noMessages $ dontCheck repoExists $ - withGlobalOptions [jsonOptions] $ + withAnnexOptions [jsonOptions] $ command "examinekey" SectionPlumbing "prints information from a key" (paramRepeating paramKey) diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -44,7 +44,7 @@ import Control.Concurrent cmd :: Command -cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption] $ +cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption] $ command "export" SectionCommon "export a tree of files to a special remote" paramTreeish (seek <$$> optParser) @@ -96,7 +96,7 @@ db <- openDb (uuid r) writeLockDbWhile db $ do changeExport r db tree - unlessM (Annex.getState Annex.fast) $ do + unlessM (Annex.getRead Annex.fast) $ do void $ fillExport r db tree mtbcommitsha closeDb db @@ -518,9 +518,7 @@ Nothing | issymlink -> catKey sha >>= \case Just _ -> return (Just ti) - Nothing - | issymlink -> excluded - | otherwise -> return (Just ti) + Nothing -> excluded | otherwise -> return (Just ti) Just matcher -> catKey sha >>= \case Just k -> checkmatcher matcher k diff --git a/Command/FilterBranch.hs b/Command/FilterBranch.hs --- a/Command/FilterBranch.hs +++ b/Command/FilterBranch.hs @@ -36,7 +36,7 @@ import qualified System.FilePath.ByteString as P cmd :: Command -cmd = noMessages $ withGlobalOptions [annexedMatchingOptions] $ +cmd = noMessages $ withAnnexOptions [annexedMatchingOptions] $ command "filter-branch" SectionMaintenance "filter information from the git-annex branch" paramPaths (seek <$$> optParser) diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -21,12 +21,12 @@ import Utility.DataUnits cmd :: Command -cmd = notBareRepo $ withGlobalOptions [annexedMatchingOptions] $ mkCommand $ +cmd = notBareRepo $ withAnnexOptions [annexedMatchingOptions] $ mkCommand $ command "find" SectionQuery "lists available files" paramPaths (seek <$$> optParser) mkCommand :: Command -> Command -mkCommand = noCommit . noMessages . withGlobalOptions [jsonOptions] +mkCommand = noCommit . noMessages . withAnnexOptions [jsonOptions] data FindOptions = FindOptions { findThese :: CmdParams diff --git a/Command/FindRef.hs b/Command/FindRef.hs --- a/Command/FindRef.hs +++ b/Command/FindRef.hs @@ -12,7 +12,7 @@ import qualified Git cmd :: Command -cmd = withGlobalOptions [annexedMatchingOptions] $ Find.mkCommand $ +cmd = withAnnexOptions [annexedMatchingOptions] $ Find.mkCommand $ command "findref" SectionPlumbing "lists files in a git ref (deprecated)" paramRef (seek <$$> Find.optParser) diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -25,7 +25,7 @@ #endif cmd :: Command -cmd = noCommit $ withGlobalOptions [annexedMatchingOptions] $ +cmd = noCommit $ withAnnexOptions [annexedMatchingOptions] $ command "fix" SectionMaintenance "fix up links to annexed content" paramPaths (withParams seek) diff --git a/Command/Forget.hs b/Command/Forget.hs --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -40,7 +40,7 @@ let ts = if dropDead o then addTransition c ForgetDeadRemotes basets else basets - perform ts =<< Annex.getState Annex.force + perform ts =<< Annex.getRead Annex.force where ai = ActionItemOther (Just (fromRef Branch.name)) si = SeekInput [] diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -22,7 +22,7 @@ import Network.URI cmd :: Command -cmd = notBareRepo $ withGlobalOptions [jsonOptions] $ +cmd = notBareRepo $ withAnnexOptions [jsonOptions] $ command "fromkey" SectionPlumbing "adds a file using a specific key" (paramRepeating (paramPair paramKey paramPath)) (seek <$$> optParser) @@ -46,7 +46,7 @@ -- older way of enabling batch input, does not support BatchNull (NoBatch, []) -> seekBatch matcher (BatchFormat BatchLine (BatchKeys False)) (NoBatch, ps) -> do - force <- Annex.getState Annex.force + force <- Annex.getRead Annex.force withPairs (commandAction . start matcher force) ps seekBatch :: AddUnlockedMatcher -> BatchFormat -> CommandSeek diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -51,7 +51,7 @@ import qualified System.FilePath.ByteString as P cmd :: Command -cmd = withGlobalOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ +cmd = withAnnexOptions [jobsOption, jsonOptions, annexedMatchingOptions] $ command "fsck" SectionMaintenance "find and fix problems" paramPaths (seek <$$> optParser) @@ -164,7 +164,7 @@ Nothing -> go True Nothing Just (Right verification) -> go True (Just (tmpfile, verification)) Just (Left _) -> do - warning "failed to download file from remote" + warning (decodeBS (actionItemDesc ai) ++ ": failed to download file from remote") void $ go True Nothing return False dispatch (Right False) = go False Nothing @@ -195,7 +195,7 @@ getfile tmp = ifM (checkDiskSpace (Just (P.takeDirectory tmp)) key 0 True) ( ifM (getcheap tmp) ( return (Just (Right UnVerified)) - , ifM (Annex.getState Annex.fast) + , ifM (Annex.getRead Annex.fast) ( return Nothing , Just <$> tryNonAsync (getfile' tmp) ) diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -181,11 +181,11 @@ runFuzzAction (FuzzDelete (FuzzFile f)) = liftIO $ removeWhenExistsWith R.removeLink (toRawFilePath f) runFuzzAction (FuzzMove (FuzzFile src) (FuzzFile dest)) = liftIO $ - rename src dest + R.rename (toRawFilePath src) (toRawFilePath dest) runFuzzAction (FuzzDeleteDir (FuzzDir d)) = liftIO $ removeDirectoryRecursive d runFuzzAction (FuzzMoveDir (FuzzDir src) (FuzzDir dest)) = liftIO $ - rename src dest + R.rename (toRawFilePath src) (toRawFilePath dest) runFuzzAction (FuzzPause d) = randomDelay d genFuzzAction :: Annex FuzzAction diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -15,7 +15,7 @@ import qualified Command.Move cmd :: Command -cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ +cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ command "get" SectionCommon "make content of annexed files available" paramPaths (seek <$$> optParser) diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -40,14 +40,15 @@ cmd :: Command cmd = notBareRepo $ - withGlobalOptions opts $ + withAnnexOptions opts $ command "import" SectionCommon "add a tree of files to the repository" (paramPaths ++ "|BRANCH") (seek <$$> optParser) where opts = - [ jobsOption + [ backendOption + , jobsOption , jsonOptions , jsonProgressOption -- These options are only used when importing from a @@ -173,13 +174,13 @@ Nothing -> importfilechecked ld k Just s | isDirectory s -> notoverwriting "(is a directory)" - | isSymbolicLink s -> ifM (Annex.getState Annex.force) + | isSymbolicLink s -> ifM (Annex.getRead Annex.force) ( do liftIO $ removeWhenExistsWith R.removeLink destfile importfilechecked ld k , notoverwriting "(is a symlink)" ) - | otherwise -> ifM (Annex.getState Annex.force) + | otherwise -> ifM (Annex.getRead Annex.force) ( do liftIO $ removeWhenExistsWith R.removeLink destfile importfilechecked ld k diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -51,7 +51,7 @@ import Logs cmd :: Command -cmd = notBareRepo $ +cmd = notBareRepo $ withAnnexOptions [backendOption] $ command "importfeed" SectionCommon "import files from podcast feeds" (paramRepeating paramUrl) (seek <$$> optParser) @@ -135,7 +135,7 @@ } getCache :: Maybe String -> Annex Cache -getCache opttemplate = ifM (Annex.getState Annex.force) +getCache opttemplate = ifM (Annex.getRead Annex.force) ( ret S.empty S.empty , do showStart "importfeed" "gathering known urls" (SeekInput []) @@ -246,12 +246,12 @@ -- to avoid adding it a second time. let quviurl = setDownloader linkurl QuviDownloader checkknown mediaurl $ checkknown quviurl $ - ifM (Annex.getState Annex.fast <||> pure (relaxedOption (downloadOptions opts))) + ifM (Annex.getRead Annex.fast <||> pure (relaxedOption (downloadOptions opts))) ( addmediafast linkurl mediaurl mediakey , downloadmedia linkurl mediaurl mediakey ) where - forced = Annex.getState Annex.force + forced = Annex.getRead Annex.force {- Avoids downloading any items that are already known to be - associated with a file in the annex, unless forced. -} diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -97,7 +97,7 @@ type StatState = StateT StatInfo Annex cmd :: Command -cmd = noCommit $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $ +cmd = noCommit $ withAnnexOptions [jsonOptions, annexedMatchingOptions] $ command "info" SectionQuery "information about an item or the repository" (paramRepeating paramItem) (seek <$$> optParser) @@ -238,7 +238,7 @@ selStats :: [Stat] -> [Stat] -> Annex [Stat] selStats fast_stats slow_stats = do - fast <- Annex.getState Annex.fast + fast <- Annex.getRead Annex.fast return $ if fast then fast_stats else fast_stats ++ slow_stats @@ -597,7 +597,7 @@ getDirStatInfo :: InfoOptions -> FilePath -> Annex StatInfo getDirStatInfo o dir = do - fast <- Annex.getState Annex.fast + fast <- Annex.getRead Annex.fast matcher <- Limit.getMatcher (presentdata, referenceddata, numcopiesstats, repodata) <- Command.Unused.withKeysFilesReferencedIn dir initial @@ -625,7 +625,7 @@ getTreeStatInfo :: InfoOptions -> Git.Ref -> Annex (Maybe StatInfo) getTreeStatInfo o r = do - fast <- Annex.getState Annex.fast + fast <- Annex.getRead Annex.fast -- git lstree filenames start with a leading "./" that prevents -- matching, and also things like --include are supposed to -- match relative to the current directory, which does not make diff --git a/Command/List.hs b/Command/List.hs --- a/Command/List.hs +++ b/Command/List.hs @@ -22,7 +22,7 @@ import Utility.Tuple cmd :: Command -cmd = noCommit $ withGlobalOptions [annexedMatchingOptions] $ +cmd = noCommit $ withAnnexOptions [annexedMatchingOptions] $ command "list" SectionQuery "show which remotes contain files" paramPaths (seek <$$> optParser) diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -22,7 +22,7 @@ import qualified Utility.RawFilePath as R cmd :: Command -cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $ +cmd = withAnnexOptions [jsonOptions, annexedMatchingOptions] $ command "lock" SectionCommon "undo unlock command" paramPaths (withParams seek) @@ -50,7 +50,7 @@ go Nothing = ifM (isUnmodified key file) ( cont - , ifM (Annex.getState Annex.force) + , ifM (Annex.getRead Annex.force) ( cont , errorModified ) diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -36,7 +36,7 @@ type Outputter = LogChange -> POSIXTime -> [UUID] -> Annex () cmd :: Command -cmd = withGlobalOptions [annexedMatchingOptions] $ +cmd = withAnnexOptions [annexedMatchingOptions] $ command "log" SectionQuery "shows location log" paramPaths (seek <$$> optParser) diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -52,7 +52,7 @@ liftIO $ writeFile file (drawMap rs trustmap umap) next $ - ifM (Annex.getState Annex.fast) + ifM (Annex.getRead Annex.fast) ( runViewer file [] , runViewer file [ ("xdot", [File file]) diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -25,7 +25,7 @@ import Control.Concurrent cmd :: Command -cmd = withGlobalOptions [jsonOptions, annexedMatchingOptions] $ +cmd = withAnnexOptions [jsonOptions, annexedMatchingOptions] $ command "metadata" SectionMetaData "sets or gets metadata of a file" paramPaths (seek <$$> optParser) diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -20,7 +20,7 @@ import Utility.Metered cmd :: Command -cmd = withGlobalOptions [annexedMatchingOptions] $ +cmd = withAnnexOptions [backendOption, annexedMatchingOptions] $ command "migrate" SectionUtility "switch data to different backend" paramPaths (seek <$$> optParser) @@ -50,7 +50,7 @@ start :: MigrateOptions -> SeekInput -> RawFilePath -> Key -> CommandStart start o si file key = do - forced <- Annex.getState Annex.force + forced <- Annex.getRead Annex.force v <- Backend.getBackend (fromRawFilePath file) key case v of Nothing -> stop diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -17,7 +17,7 @@ import Types.Transfer cmd :: Command -cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ +cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ command "mirror" SectionCommon "mirror content of files to/from another repository" paramPaths (seek <--< optParser) diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -25,7 +25,7 @@ import qualified Data.ByteString.Lazy as L cmd :: Command -cmd = withGlobalOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ +cmd = withAnnexOptions [jobsOption, jsonOptions, jsonProgressOption, annexedMatchingOptions] $ command "move" SectionCommon "move content of files to/from another repository" paramPaths (seek <--< optParser) @@ -118,7 +118,7 @@ toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart toStart' dest removewhen afile key ai si = do - fast <- Annex.getState Annex.fast + fast <- Annex.getRead Annex.fast if fast && removewhen == RemoveNever then ifM (expectedPresent dest key) ( stop @@ -334,7 +334,7 @@ , unlessforced DropWorse ) where - unlessforced r = ifM (Annex.getState Annex.force) + unlessforced r = ifM (Annex.getRead Annex.force) ( return DropAllowed , return r ) diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -216,7 +216,7 @@ Just k -> void $ logStatusAfter k $ getViaTmpFromDisk RetrievalVerifiableKeysSecure AlwaysVerify k (AssociatedFile Nothing) $ \dest -> unVerified $ liftIO $ catchBoolIO $ do - rename f (fromRawFilePath dest) + R.rename (toRawFilePath f) dest return True -- Under Windows, uftp uses key containers, which are not files on the diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -75,7 +75,7 @@ ifM (inAnnex oldkey) ( unlessM (linkKey file oldkey newkey) $ giveup "failed creating link from old to new key" - , unlessM (Annex.getState Annex.force) $ + , unlessM (Annex.getRead Annex.force) $ giveup $ fromRawFilePath file ++ " is not available (use --force to override)" ) next $ cleanup file newkey diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -13,7 +13,7 @@ import qualified Remote cmd :: Command -cmd = withGlobalOptions [jsonOptions] $ command "registerurl" +cmd = withAnnexOptions [jsonOptions] $ command "registerurl" SectionPlumbing "registers an url for a key" (paramPair paramKey paramUrl) (seek <$$> optParser) diff --git a/Command/Reinject.hs b/Command/Reinject.hs --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -16,10 +16,11 @@ import qualified Git cmd :: Command -cmd = command "reinject" SectionUtility - "inject content of file back into annex" - (paramRepeating (paramPair "SRC" "DEST")) - (seek <$$> optParser) +cmd = withAnnexOptions [backendOption] $ + command "reinject" SectionUtility + "inject content of file back into annex" + (paramRepeating (paramPair "SRC" "DEST")) + (seek <$$> optParser) data ReinjectOptions = ReinjectOptions { params :: CmdParams diff --git a/Command/Repair.hs b/Command/Repair.hs --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -27,7 +27,7 @@ start :: CommandStart start = starting "repair" (ActionItemOther Nothing) (SeekInput []) $ - next $ runRepair =<< Annex.getState Annex.force + next $ runRepair =<< Annex.getRead Annex.force runRepair :: Bool -> Annex Bool runRepair forced = do diff --git a/Command/Status.hs b/Command/Status.hs --- a/Command/Status.hs +++ b/Command/Status.hs @@ -13,7 +13,7 @@ cmd :: Command cmd = notBareRepo $ noCommit $ noMessages $ - withGlobalOptions [jsonOptions] $ + withAnnexOptions [jsonOptions] $ command "status" SectionCommon "show the working tree status" paramPaths (seek <$$> optParser) diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -83,7 +83,7 @@ import Data.Char cmd :: Command -cmd = withGlobalOptions [jobsOption] $ +cmd = withAnnexOptions [jobsOption, backendOption] $ command "sync" SectionCommon "synchronize local repository with remotes" (paramRepeating paramRemote) (seek <--< optParser) @@ -324,7 +324,7 @@ syncRemotes' :: [String] -> [Remote] -> Annex [Remote] syncRemotes' ps available = - ifM (Annex.getState Annex.fast) ( fastest <$> wanted , wanted ) + ifM (Annex.getRead Annex.fast) ( fastest <$> wanted , wanted ) where wanted | null ps = filterM good (concat $ Remote.byCost available) diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -74,7 +74,7 @@ start :: TestRemoteOptions -> CommandStart start o = starting "testremote" (ActionItemOther (Just (testRemote o))) si $ do - fast <- Annex.getState Annex.fast + fast <- Annex.getRead Annex.fast cache <- liftIO newRemoteVariantCache r <- either giveup (disableExportTree cache) =<< Remote.byName' (testRemote o) diff --git a/Command/Trust.hs b/Command/Trust.hs --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -33,7 +33,7 @@ starting c (ActionItemOther (Just name)) si (perform name u) perform name uuid = do when (level >= Trusted) $ - unlessM (Annex.getState Annex.force) $ + unlessM (Annex.getRead Annex.force) $ giveup $ trustedNeedsForce name trustSet uuid level when (level == DeadTrusted) $ diff --git a/Command/Unannex.hs b/Command/Unannex.hs --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -20,30 +20,30 @@ import qualified Utility.RawFilePath as R cmd :: Command -cmd = withGlobalOptions [annexedMatchingOptions] $ +cmd = withAnnexOptions [annexedMatchingOptions] $ command "unannex" SectionUtility "undo accidental add command" paramPaths (withParams seek) seek :: CmdParams -> CommandSeek -seek ps = withFilesInGitAnnex ww seeker =<< workTreeItems ww ps +seek ps = withFilesInGitAnnex ww (seeker False) =<< workTreeItems ww ps where ww = WarnUnmatchLsFiles -seeker :: AnnexedFileSeeker -seeker = AnnexedFileSeeker - { startAction = start +seeker :: Bool -> AnnexedFileSeeker +seeker fast = AnnexedFileSeeker + { startAction = start fast , checkContentPresent = Just True , usesLocationLog = False } -start :: SeekInput -> RawFilePath -> Key -> CommandStart -start si file key = +start :: Bool -> SeekInput -> RawFilePath -> Key -> CommandStart +start fast si file key = starting "unannex" (mkActionItem (key, file)) si $ - perform file key + perform fast file key -perform :: RawFilePath -> Key -> CommandPerform -perform file key = do +perform :: Bool -> RawFilePath -> Key -> CommandPerform +perform fast file key = do Annex.Queue.addCommand [] "rm" [ Param "--cached" , Param "--force" @@ -58,7 +58,7 @@ -- (cached in git). Just key' -> do cleanupdb - next $ cleanup file key' + next $ cleanup fast file key' -- If the file is unlocked, it can be unmodified or not and -- does not need to be replaced either way. Nothing -> do @@ -71,11 +71,11 @@ maybe noop Database.Keys.removeInodeCache =<< withTSDelta (liftIO . genInodeCache file) -cleanup :: RawFilePath -> Key -> CommandCleanup -cleanup file key = do +cleanup :: Bool -> RawFilePath -> Key -> CommandCleanup +cleanup fast file key = do liftIO $ removeFile (fromRawFilePath file) src <- calcRepo (gitAnnexLocation key) - ifM (Annex.getState Annex.fast) + ifM (pure fast <||> Annex.getRead Annex.fast) ( do -- Only make a hard link if the annexed file does not -- already have other hard links pointing at it. This diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -8,7 +8,6 @@ module Command.Uninit where import Command -import qualified Annex import qualified Git import qualified Git.Command import qualified Git.Ref @@ -54,8 +53,7 @@ WarnUnmatchWorkTreeItems (\(_, f) -> commandAction $ whenAnnexed (startCheckIncomplete . fromRawFilePath) f) l - Annex.changeState $ \s -> s { Annex.fast = True } - withFilesInGitAnnex ww Command.Unannex.seeker l + withFilesInGitAnnex ww (Command.Unannex.seeker True) l finish where ww = WarnUnmatchLsFiles diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -25,7 +25,7 @@ editcmd = mkcmd "edit" "same as unlock" mkcmd :: String -> String -> Command -mkcmd n d = withGlobalOptions [jsonOptions, annexedMatchingOptions] $ +mkcmd n d = withAnnexOptions [jsonOptions, annexedMatchingOptions] $ command n SectionCommon d paramPaths (withParams seek) seek :: CmdParams -> CommandSeek diff --git a/Command/UnregisterUrl.hs b/Command/UnregisterUrl.hs --- a/Command/UnregisterUrl.hs +++ b/Command/UnregisterUrl.hs @@ -14,7 +14,7 @@ import Command.RegisterUrl (seekBatch, start, optParser, RegisterUrlOptions(..)) cmd :: Command -cmd = withGlobalOptions [jsonOptions] $ command "unregisterurl" +cmd = withAnnexOptions [jsonOptions] $ command "unregisterurl" SectionPlumbing "unregisters an url for a key" (paramPair paramKey paramUrl) (seek <$$> optParser) diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -77,7 +77,7 @@ checkUnused :: RefSpec -> CommandPerform checkUnused refspec = chain 0 - [ check "" unusedMsg $ findunused =<< Annex.getState Annex.fast + [ check "" unusedMsg $ findunused =<< Annex.getRead Annex.fast , check "bad" staleBadMsg $ staleKeysPrune gitAnnexBadDir False , check "tmp" staleTmpMsg $ staleKeysPrune gitAnnexTmpObjectDir True ] diff --git a/Command/WhereUsed.hs b/Command/WhereUsed.hs --- a/Command/WhereUsed.hs +++ b/Command/WhereUsed.hs @@ -24,7 +24,7 @@ import qualified Data.ByteString.Lazy as L cmd :: Command -cmd = noCommit $ withGlobalOptions [annexedMatchingOptions] $ +cmd = noCommit $ withAnnexOptions [annexedMatchingOptions] $ command "whereused" SectionQuery "lists repositories that have file content" paramNothing (seek <$$> optParser) diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -23,7 +23,7 @@ import qualified Data.Vector as V cmd :: Command -cmd = noCommit $ withGlobalOptions [jsonOptions, annexedMatchingOptions] $ +cmd = noCommit $ withAnnexOptions [jsonOptions, annexedMatchingOptions] $ command "whereis" SectionQuery "lists repositories that have file content" paramPaths (seek <$$> optParser) diff --git a/Common.hs b/Common.hs --- a/Common.hs +++ b/Common.hs @@ -13,7 +13,7 @@ import System.FilePath as X import System.IO as X hiding (FilePath) import System.Exit as X -import System.PosixCompat.Files as X hiding (fileSize, removeLink) +import System.PosixCompat.Files as X hiding (fileSize, removeLink, rename) import Utility.Misc as X import Utility.Exception as X diff --git a/Database/Init.hs b/Database/Init.hs --- a/Database/Init.hs +++ b/Database/Init.hs @@ -45,7 +45,7 @@ setAnnexFilePerm tmpdb liftIO $ do void $ tryIO $ removeDirectoryRecursive (fromRawFilePath dbdir) - rename (fromRawFilePath tmpdbdir) (fromRawFilePath dbdir) + R.rename tmpdbdir dbdir {- Make sure that the database uses WAL mode, to prevent readers - from blocking writers, and prevent a writer from blocking readers. diff --git a/Git/FilterProcess.hs b/Git/FilterProcess.hs --- a/Git/FilterProcess.hs +++ b/Git/FilterProcess.hs @@ -162,7 +162,9 @@ send b' = let (pktline, rest) = encodePktLine b' in do - writePktLine stdout pktline + if isFlushPkt pktline + then return () + else writePktLine stdout pktline case rest of Just b'' -> send b'' Nothing -> writePktLine stdout flushPkt diff --git a/Logs/Presence.hs b/Logs/Presence.hs --- a/Logs/Presence.hs +++ b/Logs/Presence.hs @@ -6,7 +6,7 @@ - A line of the log will look like: "date N INFO" - Where N=1 when the INFO is present, 0 otherwise. - - - Copyright 2010-2021 Joey Hess + - Copyright 2010-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -35,10 +35,13 @@ addLog' :: Annex.Branch.RegardingUUID -> RawFilePath -> LogStatus -> LogInfo -> CandidateVectorClock -> Annex () addLog' ru file logstatus loginfo c = - Annex.Branch.change ru file $ \b -> + Annex.Branch.changeOrAppend ru file $ \b -> let old = parseLog b line = genLine logstatus loginfo c old - in buildLog $ compactLog (line : old) + in if isNewInfo line old + then Annex.Branch.Append $ buildLog [line] + else Annex.Branch.Change $ buildLog $ + compactLog (line : old) {- When a LogLine already exists with the same status and info, but an - older timestamp, that LogLine is preserved, rather than updating the log diff --git a/Logs/Presence/Pure.hs b/Logs/Presence/Pure.hs --- a/Logs/Presence/Pure.hs +++ b/Logs/Presence/Pure.hs @@ -1,6 +1,6 @@ {- git-annex presence log, pure operations - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -90,6 +90,12 @@ logMap :: [LogLine] -> LogMap logMap = foldr insertNewerLogLine M.empty + +{- Check if the info of the given line is not in the list of LogLines. -} +isNewInfo :: LogLine -> [LogLine] -> Bool +isNewInfo l old = not (any issame old) + where + issame l' = info l' == info l insertBetter :: (LogLine -> Bool) -> LogLine -> LogMap -> Maybe LogMap insertBetter betterthan l m diff --git a/Logs/Web.hs b/Logs/Web.hs --- a/Logs/Web.hs +++ b/Logs/Web.hs @@ -57,7 +57,11 @@ setUrlPresent :: Key -> URLString -> Annex () setUrlPresent key url = do - us <- getUrls key + -- Avoid reading the url log when not compacting, for speed. + us <- ifM (annexAlwaysCompact <$> Annex.getGitConfig) + ( getUrls key + , pure mempty + ) unless (url `elem` us) $ do config <- Annex.getGitConfig addLog (Annex.Branch.RegardingUUID []) (urlLogFile config key) diff --git a/Remote/Adb.hs b/Remote/Adb.hs --- a/Remote/Adb.hs +++ b/Remote/Adb.hs @@ -46,6 +46,8 @@ (FieldDesc "sometimes needed to specify which Android device to use") , yesNoParser ignorefinderrorField (Just False) (FieldDesc "ignore adb find errors") + , yesNoParser oldandroidField (Just False) + (FieldDesc "support old versions of android (slower)") ] , setup = adbSetup , exportSupported = exportIsSupported @@ -62,6 +64,8 @@ ignorefinderrorField :: RemoteConfigField ignorefinderrorField = Accepted "ignorefinderror" +oldandroidField :: RemoteConfigField +oldandroidField = Accepted "oldandroid" gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote) gen r u rc gc rs = do @@ -305,25 +309,43 @@ ImportableContents (mapMaybe mk ls) [] Nothing -> giveup "adb find failed" where - adbfind = adbShell' serial + adbfind = adbShell' serial findparams + (\s -> if oldandroid + then s ++ ignorefinderrorsh + else concat + [ "set -o pipefail; " + , s + , "| xargs -0 stat -c " ++ shellEscape statformat ++ " --" + , ignorefinderrorsh + ] + ) + + findparams = [ Param "find" -- trailing slash is needed, or android's find command -- won't recurse into the directory , File $ fromAndroidPath adir ++ "/" , Param "-type", Param "f" - , Param "-printf", Param "%p\\0" - ] - (\s -> concat - [ "set -o pipefail; " - , s - , "| xargs -0 stat -c " ++ shellEscape statformat ++ " --" - , if ignorefinderror then " || true" else "" - ] - ) + ] ++ if oldandroid + then + [ Param "-exec" + , Param "stat" + , Param "-c" + , Param statformat + , Param "{}" + , Param ";" + ] + else + [ Param "-printf" + , Param "%p\\0" + ] ignorefinderror = fromMaybe False (getRemoteConfigValue ignorefinderrorField c) + oldandroid = fromMaybe False (getRemoteConfigValue oldandroidField c) statformat = adbStatFormat ++ "\t%n" + + ignorefinderrorsh = if ignorefinderror then " || true" else "" mk ('S':'T':'\t':l) = let (stat, fn) = separate (== '\t') l diff --git a/Remote/Directory.hs b/Remote/Directory.hs --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -514,11 +514,11 @@ checkExportContent ii dir loc overwritablecids (giveup "unsafe to overwrite file") - (const $ liftIO $ rename tmpf dest) + (const $ liftIO $ R.rename tmpf' dest) return newcid where - dest = fromRawFilePath $ exportPath dir loc - (destdir, base) = splitFileName dest + dest = exportPath dir loc + (destdir, base) = splitFileName (fromRawFilePath dest) template = relatedTemplate (base ++ ".tmp") removeExportWithContentIdentifierM :: IgnoreInodes -> RawFilePath -> Key -> ExportLocation -> [ContentIdentifier] -> Annex () diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -609,12 +609,12 @@ ensureInitialized a `finally` stopCoProcesses -data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar (Maybe (Annex.AnnexState, Annex.AnnexRead))) +data LocalRemoteAnnex = LocalRemoteAnnex Git.Repo (MVar [(Annex.AnnexState, Annex.AnnexRead)]) {- This can safely be called on a Repo that is not local, but of course - onLocal will not work if used with the result. -} mkLocalRemoteAnnex :: Git.Repo -> Annex (LocalRemoteAnnex) -mkLocalRemoteAnnex repo = LocalRemoteAnnex repo <$> liftIO (newMVar Nothing) +mkLocalRemoteAnnex repo = LocalRemoteAnnex repo <$> liftIO (newMVar []) {- Runs an action from the perspective of a local remote. - @@ -645,10 +645,13 @@ onLocal' :: LocalRemoteAnnex -> Annex a -> Annex a onLocal' (LocalRemoteAnnex repo mv) a = liftIO (takeMVar mv) >>= \case - Nothing -> do + [] -> do + liftIO $ putMVar mv [] v <- newLocal repo go (v, ensureInitialized >> a) - Just v -> go (v, a) + (v:rest) -> do + liftIO $ putMVar mv rest + go (v, a) where go ((st, rd), a') = do curro <- Annex.getState Annex.output @@ -657,7 +660,9 @@ (ret, (st', _rd)) <- liftIO $ act `onException` cache (st, rd) liftIO $ cache (st', rd) return ret - cache = putMVar mv . Just + cache v = do + l <- takeMVar mv + putMVar mv (v:l) {- Faster variant of onLocal. - diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -149,7 +149,7 @@ (c', _encsetup) <- encryptionSetup c gc pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c' let failinitunlessforced msg = case ss of - Init -> unlessM (Annex.getState Annex.force) (giveup msg) + Init -> unlessM (Annex.getRead Annex.force) (giveup msg) Enable _ -> noop AutoEnable _ -> noop case (isEncrypted pc, Git.GCrypt.urlPrefix `isPrefixOf` url) of diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -197,7 +197,7 @@ cipher <- liftIO a showNote (describeCipher cipher) return (storeCipher cipher c', EncryptionIsSetup) - highRandomQuality = ifM (Annex.getState Annex.fast) + highRandomQuality = ifM (Annex.getRead Annex.fast) ( return False , case parseHighRandomQuality (fromProposedAccepted <$> M.lookup highRandomQualityField c) of Left err -> giveup err diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -47,6 +47,7 @@ import Utility.SshHost import Annex.SpecialRemote.Config import Annex.Verify +import qualified Utility.RawFilePath as R import qualified Data.Map as M @@ -224,7 +225,7 @@ basedest = fromRawFilePath $ Prelude.head (keyPaths k) populatedest dest = liftIO $ if canrename then do - rename src dest + R.rename (toRawFilePath src) (toRawFilePath dest) return True else createLinkOrCopy (toRawFilePath src) (toRawFilePath dest) {- If the key being sent is encrypted or chunked, the file diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -312,7 +312,7 @@ use archiveconfig pc' info checkexportimportsafe c' info = - unlessM (Annex.getState Annex.force) $ + unlessM (Annex.getRead Annex.force) $ checkexportimportsafe' c' info checkexportimportsafe' c' info | versioning info = return () @@ -777,9 +777,11 @@ - - Note that IA buckets can only created by having a file - stored in them. So this also takes care of that. + - + - Not done for import/export buckets. -} writeUUIDFile :: ParsedRemoteConfig -> UUID -> S3Info -> S3Handle -> Annex () -writeUUIDFile c u info h = do +writeUUIDFile c u info h = unless (exportTree c || importTree c) $ do v <- checkUUIDFile c u info h case v of Right True -> noop @@ -794,15 +796,19 @@ mkobject = putObject info file (RequestBodyLBS uuidb) {- Checks if the UUID file exists in the bucket - - and has the specified UUID already. -} + - and has the specified UUID already. + - + - Not done for import/export buckets. -} checkUUIDFile :: ParsedRemoteConfig -> UUID -> S3Info -> S3Handle -> Annex (Either SomeException Bool) -checkUUIDFile c u info h = tryNonAsync $ liftIO $ runResourceT $ do - resp <- tryS3 $ sendS3Handle h (S3.getObject (bucket info) file) - case resp of - Left _ -> return False - Right r -> do - v <- AWS.loadToMemory r - extractFromResourceT (check v) +checkUUIDFile c u info h + | exportTree c || importTree c = pure (Right False) + | otherwise = tryNonAsync $ liftIO $ runResourceT $ do + resp <- tryS3 $ sendS3Handle h (S3.getObject (bucket info) file) + case resp of + Left _ -> return False + Right r -> do + v <- AWS.loadToMemory r + extractFromResourceT (check v) where check (S3.GetObjectMemoryResponse _meta rsp) = responseStatus rsp == ok200 && responseBody rsp == uuidb diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -82,6 +82,7 @@ import qualified Utility.FileSystemEncoding import qualified Utility.Aeson import qualified Utility.CopyFile +import qualified Utility.MoveFile import qualified Types.Remote #ifndef mingw32_HOST_OS import qualified Remote.Helper.Encryptable @@ -261,6 +262,7 @@ repoTests note numparts = map mk $ sep [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras + , testCase "add moved link" test_add_moved , testCase "readonly remote" test_readonly_remote , testCase "ignore deleted files" test_ignore_deleted_files , testCase "metadata" test_metadata @@ -389,6 +391,17 @@ git_annex "unlock" [wormannexedfile] "unlock" annexed_present wormannexedfile checkbackend wormannexedfile backendWORM + +test_add_moved :: Assertion +test_add_moved = intmpclonerepo $ do + git_annex "get" [annexedfile] "get failed" + annexed_present annexedfile + createDirectory subdir + Utility.MoveFile.moveFile (toRawFilePath annexedfile) (toRawFilePath subfile) + git_annex "add" [subdir] "add of moved annexed file" + where + subdir = "subdir" + subfile = subdir "file" test_readonly_remote :: Assertion test_readonly_remote = diff --git a/Types/Command.hs b/Types/Command.hs --- a/Types/Command.hs +++ b/Types/Command.hs @@ -87,8 +87,8 @@ -- ^ command line parser , cmdinfomod :: forall a. InfoMod a -- ^ command-specific modifier for ParserInfo - , cmdglobaloptions :: [GlobalOption] - -- ^ additional global options + , cmdannexoptions :: [AnnexOption] + -- ^ additional options not parsed by the CommandParser , cmdnorepo :: Maybe (Parser (IO ())) -- ^used when not in a repo } diff --git a/Types/DeferredParse.hs b/Types/DeferredParse.hs --- a/Types/DeferredParse.hs +++ b/Types/DeferredParse.hs @@ -38,20 +38,20 @@ instance DeferredParseClass [DeferredParse a] where finishParse v = mapM finishParse v -type GlobalOption = Parser GlobalSetter +type AnnexOption = Parser AnnexSetter --- Used for global options that can modify Annex state by running +-- Used for options that can modify Annex state by running -- an arbitrary action in it, and can also set up AnnexRead. -data GlobalSetter = GlobalSetter +data AnnexSetter = AnnexSetter { annexStateSetter :: Annex () , annexReadSetter :: AnnexRead -> AnnexRead } -instance Sem.Semigroup GlobalSetter where - a <> b = GlobalSetter +instance Sem.Semigroup AnnexSetter where + a <> b = AnnexSetter { annexStateSetter = annexStateSetter a >> annexStateSetter b , annexReadSetter = annexReadSetter b . annexReadSetter a } -instance Monoid GlobalSetter where - mempty = GlobalSetter (return ()) id +instance Monoid AnnexSetter where + mempty = AnnexSetter (return ()) id diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -82,6 +82,7 @@ , annexBloomAccuracy :: Maybe Int , annexSshCaching :: Maybe Bool , annexAlwaysCommit :: Bool + , annexAlwaysCompact :: Bool , annexCommitMessage :: Maybe String , annexMergeAnnexBranches :: Bool , annexDelayAdd :: Maybe Int @@ -164,6 +165,7 @@ , annexBloomAccuracy = getmayberead (annexConfig "bloomaccuracy") , annexSshCaching = getmaybebool (annexConfig "sshcaching") , annexAlwaysCommit = getbool (annexConfig "alwayscommit") True + , annexAlwaysCompact = getbool (annexConfig "alwayscompact") True , annexCommitMessage = getmaybe (annexConfig "commitmessage") , annexMergeAnnexBranches = getbool (annexConfig "merge-annex-branches") True , annexDelayAdd = getmayberead (annexConfig "delayadd") diff --git a/Upgrade/V9.hs b/Upgrade/V9.hs --- a/Upgrade/V9.hs +++ b/Upgrade/V9.hs @@ -27,7 +27,7 @@ ( return UpgradeDeferred , performUpgrade automatic ) - | otherwise = ifM (oldprocessesdanger <&&> (not <$> Annex.getState Annex.force)) + | otherwise = ifM (oldprocessesdanger <&&> (not <$> Annex.getRead Annex.force)) ( do warning $ unlines unsafeupgrade return UpgradeDeferred diff --git a/Utility/Directory.hs b/Utility/Directory.hs --- a/Utility/Directory.hs +++ b/Utility/Directory.hs @@ -16,7 +16,7 @@ import Control.Monad import System.FilePath -import System.PosixCompat.Files hiding (removeLink) +import System.PosixCompat.Files (getSymbolicLinkStatus, isDirectory, isSymbolicLink) import Control.Applicative import System.IO.Unsafe (unsafeInterleaveIO) import Data.Maybe diff --git a/Utility/FileMode.hs b/Utility/FileMode.hs --- a/Utility/FileMode.hs +++ b/Utility/FileMode.hs @@ -16,7 +16,7 @@ import System.IO import Control.Monad import System.PosixCompat.Types -import System.PosixCompat.Files hiding (removeLink) +import System.PosixCompat.Files (unionFileModes, intersectFileModes, stdFileMode, nullFileMode, setFileCreationMask, groupReadMode, ownerReadMode, ownerWriteMode, ownerExecuteMode, groupWriteMode, groupExecuteMode, otherReadMode, otherWriteMode, otherExecuteMode, fileMode) import Control.Monad.IO.Class import Foreign (complement) import Control.Monad.Catch diff --git a/Utility/FileSize.hs b/Utility/FileSize.hs --- a/Utility/FileSize.hs +++ b/Utility/FileSize.hs @@ -14,7 +14,7 @@ getFileSize', ) where -import System.PosixCompat.Files hiding (removeLink) +import System.PosixCompat.Files (FileStatus, fileSize) import qualified Utility.RawFilePath as R #ifdef mingw32_HOST_OS import Control.Exception (bracket) diff --git a/Utility/LogFile.hs b/Utility/LogFile.hs --- a/Utility/LogFile.hs +++ b/Utility/LogFile.hs @@ -18,6 +18,7 @@ ) where import Common +import Utility.RawFilePath #ifndef mingw32_HOST_OS import System.Posix.Types @@ -36,7 +37,7 @@ | num > maxLogs = return () | otherwise = whenM (doesFileExist currfile) $ do go (num + 1) - rename currfile nextfile + rename (toRawFilePath currfile) (toRawFilePath nextfile) where currfile = filename num nextfile = filename (num + 1) diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -34,6 +34,8 @@ import Common +import Data.Kind + {- A Token can be an Operation of an arbitrary type, or one of a few - predefined peices of syntax. -} data Token op = Operation op | And | Or | Not | Open | Close @@ -136,7 +138,7 @@ {- More generic running of a monadic Matcher, with full control over running - of Operations. Mostly useful in order to match on more than one - parameter. -} -matchMrun :: forall o (m :: * -> *). Monad m => Matcher o -> (o -> m Bool) -> m Bool +matchMrun :: forall o (m :: Type -> Type). Monad m => Matcher o -> (o -> m Bool) -> m Bool matchMrun m run = go m where go MAny = return True diff --git a/Utility/RawFilePath.hs b/Utility/RawFilePath.hs --- a/Utility/RawFilePath.hs +++ b/Utility/RawFilePath.hs @@ -89,6 +89,8 @@ setFileMode :: RawFilePath -> FileMode -> IO () setFileMode = F.setFileMode . fromRawFilePath +{- Using renamePath rather than the rename provided in unix-compat + - because of this bug https://github.com/jacobstanley/unix-compat/issues/56-} rename :: RawFilePath -> RawFilePath -> IO () -rename a b = F.rename (fromRawFilePath a) (fromRawFilePath b) +rename a b = D.renamePath (fromRawFilePath a) (fromRawFilePath b) #endif diff --git a/Utility/UserInfo.hs b/Utility/UserInfo.hs --- a/Utility/UserInfo.hs +++ b/Utility/UserInfo.hs @@ -21,7 +21,7 @@ import Control.Applicative #endif -import System.PosixCompat +import System.PosixCompat.User import Prelude {- Current user's home directory. diff --git a/doc/git-annex-addurl.mdwn b/doc/git-annex-addurl.mdwn --- a/doc/git-annex-addurl.mdwn +++ b/doc/git-annex-addurl.mdwn @@ -136,6 +136,10 @@ Messages that would normally be output to standard error are included in the json instead. +* `--backend` + + Specifies which key-value backend to use. + * Also the [[git-annex-common-options]](1) can be used. # CAVEATS diff --git a/doc/git-annex-import.mdwn b/doc/git-annex-import.mdwn --- a/doc/git-annex-import.mdwn +++ b/doc/git-annex-import.mdwn @@ -185,6 +185,10 @@ Setting this to "cpus" will run one job per CPU core. +* `--backend` + + Specifies which key-value backend to use for the imported files. + * `--no-check-gitignore` Add gitignored files. diff --git a/doc/git-annex-importfeed.mdwn b/doc/git-annex-importfeed.mdwn --- a/doc/git-annex-importfeed.mdwn +++ b/doc/git-annex-importfeed.mdwn @@ -102,6 +102,10 @@ url to a file that would be ignored. This makes such files be added despite any ignores. +* `--backend` + + Specifies which key-value backend to use. + * Also the [[git-annex-common-options]](1) can be used. # SEE ALSO diff --git a/doc/git-annex-sync.mdwn b/doc/git-annex-sync.mdwn --- a/doc/git-annex-sync.mdwn +++ b/doc/git-annex-sync.mdwn @@ -167,6 +167,11 @@ resolution. It can also be disabled by setting `annex.resolvemerge` to false. +* `--backend` + + Specifies which key-value backend to use when adding files, + or when importing from a special remote. + * `--cleanup` Removes the local and remote `synced/` branches, which were created diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1038,6 +1038,24 @@ This works well in combination with annex.alwayscommit=false, to gather up a set of changes and commit them with a message you specify. +* `annex.alwayscompact` + + By default, git-annex compacts data it records in the git-annex branch. + Setting this to false avoids doing that compaction in some cases, which + can speed up operations that populate the git-annex branch with a lot + of data. However, when used with operations that overwrite old values in + the git-annex branch, that may cause the git-annex branch to use more disk + space, and so slow down reading data from it. + + An example of a command that can be sped up by using + `-c annex.alwayscompact=false` is `git-annex registerurl --batch`, + when adding a large number of urls to the same key. + + This option was first supported by git-annex version 10.20220724. + It is not entirely safe to set this option in a repository that may also + be used by an older version of git-annex at the same time as a version + that supports this option. + * `annex.allowsign` By default git-annex avoids gpg signing commits that it makes when diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,6 +1,6 @@ Name: git-annex -Version: 10.20220624 -Cabal-Version: >= 1.10 +Version: 10.20220724 +Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess Author: Joey Hess @@ -294,10 +294,11 @@ custom-setup Setup-Depends: base (>= 4.11.1.0), split, unix-compat, - filepath, exceptions, bytestring, directory, IfElse, data-default, + filepath, exceptions, bytestring, IfElse, data-default, filepath-bytestring (>= 1.4.2.1.4), process (>= 1.6.3), time (>= 1.5.0), + directory (>= 1.2.7.0), async, utf8-string, transformers, Cabal Executable git-annex @@ -319,7 +320,7 @@ unix-compat (>= 0.5), SafeSemaphore, async, - directory (>= 1.2), + directory (>= 1.2.7.0), disk-free-space, filepath, filepath-bytestring (>= 1.4.2.1.1), @@ -401,7 +402,7 @@ if (os(windows)) Build-Depends: - Win32 (>= 2.6.1.0), + Win32 (>= 2.6.1.0 && < 2.12.0.0), setenv, process (>= 1.6.2.0), silently (>= 1.2.5.1) @@ -514,6 +515,60 @@ C-Sources: Utility/libkqueue.c Includes: Utility/libkqueue.h Other-Modules: Utility.DirWatcher.Kqueue + + if flag(Webapp) + Build-Depends: + yesod (>= 1.4.3), + yesod-static (>= 1.5.1), + yesod-form (>= 1.4.8), + yesod-core (>= 1.6.0), + path-pieces (>= 0.2.1), + warp (>= 3.2.8), + warp-tls (>= 3.2.2), + wai, + wai-extra, + blaze-builder, + clientsession, + template-haskell, + shakespeare (>= 2.0.11) + CPP-Options: -DWITH_WEBAPP + Other-Modules: + Command.WebApp + Assistant.Threads.WebApp + Assistant.Threads.PairListener + Assistant.WebApp + Assistant.WebApp.Common + Assistant.WebApp.Configurators + Assistant.WebApp.Configurators.AWS + Assistant.WebApp.Configurators.Delete + Assistant.WebApp.Configurators.Edit + Assistant.WebApp.Configurators.Fsck + Assistant.WebApp.Configurators.IA + Assistant.WebApp.Configurators.Local + Assistant.WebApp.Configurators.Pairing + Assistant.WebApp.Configurators.Preferences + Assistant.WebApp.Configurators.Ssh + Assistant.WebApp.Configurators.Unused + Assistant.WebApp.Configurators.Upgrade + Assistant.WebApp.Configurators.WebDAV + Assistant.WebApp.Control + Assistant.WebApp.DashBoard + Assistant.WebApp.Documentation + Assistant.WebApp.Form + Assistant.WebApp.Gpg + Assistant.WebApp.MakeRemote + Assistant.WebApp.Notifications + Assistant.WebApp.OtherRepos + Assistant.WebApp.Page + Assistant.WebApp.Pairing + Assistant.WebApp.Repair + Assistant.WebApp.RepoId + Assistant.WebApp.RepoList + Assistant.WebApp.SideBar + Assistant.WebApp.Types + Assistant.MakeRepo + Utility.Yesod + Utility.WebApp if flag(Dbus) if (os(linux)) @@ -521,60 +576,6 @@ CPP-Options: -DWITH_DBUS -DWITH_DESKTOP_NOTIFY -DWITH_DBUS_NOTIFICATIONS Other-Modules: Utility.DBus - if flag(Webapp) - Build-Depends: - yesod (>= 1.4.3), - yesod-static (>= 1.5.1), - yesod-form (>= 1.4.8), - yesod-core (>= 1.6.0), - path-pieces (>= 0.2.1), - warp (>= 3.2.8), - warp-tls (>= 3.2.2), - wai, - wai-extra, - blaze-builder, - clientsession, - template-haskell, - shakespeare (>= 2.0.11) - CPP-Options: -DWITH_WEBAPP - Other-Modules: - Command.WebApp - Assistant.Threads.WebApp - Assistant.Threads.PairListener - Assistant.WebApp - Assistant.WebApp.Common - Assistant.WebApp.Configurators - Assistant.WebApp.Configurators.AWS - Assistant.WebApp.Configurators.Delete - Assistant.WebApp.Configurators.Edit - Assistant.WebApp.Configurators.Fsck - Assistant.WebApp.Configurators.IA - Assistant.WebApp.Configurators.Local - Assistant.WebApp.Configurators.Pairing - Assistant.WebApp.Configurators.Preferences - Assistant.WebApp.Configurators.Ssh - Assistant.WebApp.Configurators.Unused - Assistant.WebApp.Configurators.Upgrade - Assistant.WebApp.Configurators.WebDAV - Assistant.WebApp.Control - Assistant.WebApp.DashBoard - Assistant.WebApp.Documentation - Assistant.WebApp.Form - Assistant.WebApp.Gpg - Assistant.WebApp.MakeRemote - Assistant.WebApp.Notifications - Assistant.WebApp.OtherRepos - Assistant.WebApp.Page - Assistant.WebApp.Pairing - Assistant.WebApp.Repair - Assistant.WebApp.RepoId - Assistant.WebApp.RepoList - Assistant.WebApp.SideBar - Assistant.WebApp.Types - Assistant.MakeRepo - Utility.Yesod - Utility.WebApp - if flag(Pairing) Build-Depends: network-multicast, network-info CPP-Options: -DWITH_PAIRING @@ -699,7 +700,7 @@ CmdLine.GitAnnexShell CmdLine.GitAnnexShell.Checks CmdLine.GitAnnexShell.Fields - CmdLine.GlobalSetter + CmdLine.AnnexSetter CmdLine.Option CmdLine.GitRemoteTorAnnex CmdLine.Seek