diff --git a/Annex.hs b/Annex.hs --- a/Annex.hs +++ b/Annex.hs @@ -69,6 +69,7 @@ import Types.WorkerPool import Types.IndexFiles import Types.CatFileHandles +import Types.RemoteConfig import qualified Database.Keys.Handle as Keys import Utility.InodeCache import Utility.Url @@ -112,7 +113,7 @@ , backend :: Maybe (BackendA Annex) , remotes :: [Types.Remote.RemoteA Annex] , output :: MessageState - , concurrency :: Concurrency + , concurrency :: ConcurrencySetting , force :: Bool , fast :: Bool , daemon :: Bool @@ -129,6 +130,7 @@ , uuiddescmap :: Maybe UUIDDescMap , preferredcontentmap :: Maybe (FileMatcherMap Annex) , requiredcontentmap :: Maybe (FileMatcherMap Annex) + , remoteconfigmap :: Maybe (M.Map UUID RemoteConfig) , forcetrust :: TrustMap , trustmap :: Maybe TrustMap , groupmap :: Maybe GroupMap @@ -171,7 +173,7 @@ , backend = Nothing , remotes = [] , output = o - , concurrency = NonConcurrent + , concurrency = ConcurrencyCmdLine NonConcurrent , force = False , fast = False , daemon = False @@ -188,6 +190,7 @@ , uuiddescmap = Nothing , preferredcontentmap = Nothing , requiredcontentmap = Nothing + , remoteconfigmap = Nothing , forcetrust = M.empty , trustmap = Nothing , groupmap = Nothing diff --git a/Annex/Action.hs b/Annex/Action.hs --- a/Annex/Action.hs +++ b/Annex/Action.hs @@ -5,20 +5,13 @@ - Licensed under the GNU AGPL version 3 or higher. -} -{-# LANGUAGE CPP #-} - module Annex.Action ( startup, shutdown, stopCoProcesses, - reapZombies, ) where import qualified Data.Map as M -#ifndef mingw32_HOST_OS -import System.Posix.Process (getAnyProcessStatus) -import Utility.Exception -#endif import Annex.Common import qualified Annex @@ -38,7 +31,6 @@ saveState nocommit sequence_ =<< M.elems <$> Annex.getState Annex.cleanup stopCoProcesses - liftIO reapZombies -- zombies from long-running git processes {- Stops all long-running git query processes. -} stopCoProcesses :: Annex () @@ -47,19 +39,3 @@ checkAttrStop hashObjectStop checkIgnoreStop - -{- Reaps any zombie processes that may be hanging around. - - - - Warning: Not thread safe. Anything that was expecting to wait - - on a process and get back an exit status is going to be confused - - if this reap gets there first. -} -reapZombies :: IO () -#ifndef mingw32_HOST_OS -reapZombies = - -- throws an exception when there are no child processes - catchDefaultIO Nothing (getAnyProcessStatus False True) - >>= maybe (return ()) (const reapZombies) - -#else -reapZombies = return () -#endif diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -393,24 +393,26 @@ {- Lists all files on the branch. including ones in the journal - that have not been committed yet. There may be duplicates in the list. -} -files :: Annex [RawFilePath] +files :: Annex ([RawFilePath], IO Bool) files = do _ <- update + (bfs, cleanup) <- branchFiles -- ++ forces the content of the first list to be buffered in memory, -- so use getJournalledFilesStale which should be much smaller most -- of the time. branchFiles will stream as the list is consumed. - (++) + l <- (++) <$> (map toRawFilePath <$> getJournalledFilesStale) - <*> branchFiles + <*> pure bfs + return (l, cleanup) {- Files in the branch, not including any from journalled changes, - and without updating the branch. -} -branchFiles :: Annex [RawFilePath] +branchFiles :: Annex ([RawFilePath], IO Bool) branchFiles = withIndex $ inRepo branchFiles' -branchFiles' :: Git.Repo -> IO [RawFilePath] -branchFiles' = Git.Command.pipeNullSplitZombie' - (lsTreeParams Git.LsTree.LsTreeRecursive fullname [Param "--name-only"]) +branchFiles' :: Git.Repo -> IO ([RawFilePath], IO Bool) +branchFiles' = Git.Command.pipeNullSplit' $ + lsTreeParams Git.LsTree.LsTreeRecursive fullname [Param "--name-only"] {- Populates the branch's index file with the current branch contents. - @@ -620,10 +622,11 @@ remoteconfigmap <- calcRemoteConfigMap <$> getStaged remoteLog -- partially apply, improves performance let changers' = map (\c -> c config trustmap remoteconfigmap) changers - fs <- branchFiles + (fs, cleanup) <- branchFiles forM_ fs $ \f -> do content <- getStaged f apply changers' f content + liftIO $ void cleanup apply [] _ _ = return () apply (changer:rest) file content = case changer file content of PreserveFile -> apply rest file content diff --git a/Annex/CheckIgnore.hs b/Annex/CheckIgnore.hs --- a/Annex/CheckIgnore.hs +++ b/Annex/CheckIgnore.hs @@ -7,6 +7,7 @@ -} module Annex.CheckIgnore ( + CheckGitIgnore(..), checkIgnored, checkIgnoreStop, mkConcurrentCheckIgnoreHandle, @@ -19,9 +20,15 @@ import Types.Concurrency import Annex.Concurrent.Utility -checkIgnored :: FilePath -> Annex Bool -checkIgnored file = withCheckIgnoreHandle $ \h -> - liftIO $ Git.checkIgnored h file +newtype CheckGitIgnore = CheckGitIgnore Bool + +checkIgnored :: CheckGitIgnore -> FilePath -> Annex Bool +checkIgnored (CheckGitIgnore False) _ = pure False +checkIgnored (CheckGitIgnore True) file = + ifM (Annex.getState Annex.force) + ( pure False + , withCheckIgnoreHandle $ \h -> liftIO $ Git.checkIgnored h file + ) withCheckIgnoreHandle :: (Git.CheckIgnoreHandle -> Annex a) -> Annex a withCheckIgnoreHandle a = diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs --- a/Annex/Concurrent.hs +++ b/Annex/Concurrent.hs @@ -5,10 +5,14 @@ - Licensed under the GNU AGPL version 3 or higher. -} -module Annex.Concurrent where +module Annex.Concurrent ( + module Annex.Concurrent, + module Annex.Concurrent.Utility +) where import Annex import Annex.Common +import Annex.Concurrent.Utility import qualified Annex.Queue import Annex.Action import Types.Concurrency @@ -22,19 +26,24 @@ import Control.Concurrent.STM import qualified Data.Map as M -setConcurrency :: Concurrency -> Annex () -setConcurrency NonConcurrent = Annex.changeState $ \s -> s - { Annex.concurrency = NonConcurrent - } -setConcurrency c = do - cfh <- Annex.getState Annex.catfilehandles +setConcurrency :: ConcurrencySetting -> Annex () +setConcurrency (ConcurrencyCmdLine s) = setConcurrency' s ConcurrencyCmdLine +setConcurrency (ConcurrencyGitConfig s) = setConcurrency' s ConcurrencyGitConfig + +setConcurrency' :: Concurrency -> (Concurrency -> ConcurrencySetting) -> Annex () +setConcurrency' NonConcurrent f = + Annex.changeState $ \s -> s + { Annex.concurrency = f NonConcurrent + } +setConcurrency' c f = do + cfh <- getState Annex.catfilehandles cfh' <- case cfh of CatFileHandlesNonConcurrent _ -> liftIO catFileHandlesPool CatFileHandlesPool _ -> pure cfh cah <- mkConcurrentCheckAttrHandle c cih <- mkConcurrentCheckIgnoreHandle c Annex.changeState $ \s -> s - { Annex.concurrency = c + { Annex.concurrency = f c , Annex.catfilehandles = cfh' , Annex.checkattrhandle = Just cah , Annex.checkignorehandle = Just cih @@ -74,9 +83,9 @@ st <- Annex.getState id -- Make sure that concurrency is enabled, if it was not already, -- so the concurrency-safe resource pools are set up. - st' <- case Annex.concurrency st of + st' <- case getConcurrency' (Annex.concurrency st) of NonConcurrent -> do - setConcurrency (Concurrent 1) + setConcurrency (ConcurrencyCmdLine (Concurrent 1)) Annex.getState id _ -> return st return $ st' diff --git a/Annex/Concurrent/Utility.hs b/Annex/Concurrent/Utility.hs --- a/Annex/Concurrent/Utility.hs +++ b/Annex/Concurrent/Utility.hs @@ -7,9 +7,17 @@ module Annex.Concurrent.Utility where +import Annex import Types.Concurrency import GHC.Conc + +getConcurrency :: Annex Concurrency +getConcurrency = getConcurrency' <$> getState concurrency + +getConcurrency' :: ConcurrencySetting -> Concurrency +getConcurrency' (ConcurrencyCmdLine c) = c +getConcurrency' (ConcurrencyGitConfig c) = c {- Honor the requested level of concurrency, but only up to the number of - CPU cores. Useful for things that are known to be CPU bound. -} diff --git a/Annex/Drop.hs b/Annex/Drop.hs --- a/Annex/Drop.hs +++ b/Annex/Drop.hs @@ -47,8 +47,8 @@ - The runner is used to run CommandStart sequentially, it's typically - callCommandAction. -} -handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex () -handleDropsFrom locs rs reason fromhere key afile preverified runner = do +handleDropsFrom :: [UUID] -> [Remote] -> Reason -> Bool -> Key -> AssociatedFile -> SeekInput -> [VerifiedCopy] -> (CommandStart -> CommandCleanup) -> Annex () +handleDropsFrom locs rs reason fromhere key afile si preverified runner = do g <- Annex.gitRepo l <- map (`fromTopFilePath` g) <$> Database.Keys.getAssociatedFiles key @@ -120,10 +120,10 @@ dropl fs n = checkdrop fs n Nothing $ \numcopies -> stopUnless (inAnnex key) $ - Command.Drop.startLocal afile ai numcopies key preverified + Command.Drop.startLocal afile ai si numcopies key preverified dropr fs r n = checkdrop fs n (Just $ Remote.uuid r) $ \numcopies -> - Command.Drop.startRemote afile ai numcopies key r + Command.Drop.startRemote afile ai si numcopies key r ai = mkActionItem (key, afile) diff --git a/Annex/FileMatcher.hs b/Annex/FileMatcher.hs --- a/Annex/FileMatcher.hs +++ b/Annex/FileMatcher.hs @@ -78,14 +78,14 @@ checkMatcher' :: FileMatcher Annex -> MatchInfo -> AssumeNotPresent -> Annex Bool checkMatcher' matcher mi notpresent = - matchMrun matcher $ \a -> a notpresent mi + matchMrun matcher $ \o -> matchAction o notpresent mi fileMatchInfo :: RawFilePath -> Annex MatchInfo fileMatchInfo file = do matchfile <- getTopFilePath <$> inRepo (toTopFilePath file) return $ MatchingFile FileInfo { matchFile = matchfile - , currFile = file + , contentFile = Just file } matchAll :: FileMatcher Annex @@ -195,9 +195,9 @@ commonKeylessTokens LimitDiskFiles ++ #ifdef WITH_MAGICMIME [ mimer "mimetype" $ - matchMagic "mimetype" getMagicMimeType providedMimeType + matchMagic "mimetype" getMagicMimeType providedMimeType userProvidedMimeType , mimer "mimeencoding" $ - matchMagic "mimeencoding" getMagicMimeEncoding providedMimeEncoding + matchMagic "mimeencoding" getMagicMimeEncoding providedMimeEncoding userProvidedMimeEncoding ] #else [ mimer "mimetype" @@ -264,6 +264,12 @@ usev a v = Operation <$> a v call :: Either String (FileMatcher Annex) -> ParseResult (MatchFiles Annex) -call (Right sub) = Right $ Operation $ \notpresent mi -> - matchMrun sub $ \a -> a notpresent mi +call (Right sub) = Right $ Operation $ MatchFiles + { matchAction = \notpresent mi -> + matchMrun sub $ \o -> matchAction o notpresent mi + , matchNeedsFileName = any matchNeedsFileName sub + , matchNeedsFileContent = any matchNeedsFileContent sub + , matchNeedsKey = any matchNeedsKey sub + , matchNeedsLocationLog = any matchNeedsLocationLog sub + } call (Left err) = Left err diff --git a/Annex/Import.hs b/Annex/Import.hs --- a/Annex/Import.hs +++ b/Annex/Import.hs @@ -12,10 +12,10 @@ ImportCommitConfig(..), buildImportCommit, buildImportTrees, + canImportKeys, importKeys, - filterImportableContents, makeImportMatcher, - listImportableContents, + getImportableContents, ) where import Annex.Common @@ -36,6 +36,7 @@ import Annex.RemoteTrackingBranch import Annex.HashObject import Annex.Transfer +import Annex.CheckIgnore import Command import Backend import Types.Key @@ -48,7 +49,7 @@ import Logs.PreferredContent import Types.FileMatcher import Annex.FileMatcher -import Utility.Matcher (isEmpty) +import qualified Utility.Matcher import qualified Database.Export as Export import qualified Database.ContentIdentifier as CIDDb import qualified Logs.ContentIdentifier as CIDLog @@ -57,7 +58,7 @@ import Control.Concurrent.STM import qualified Data.Map.Strict as M import qualified Data.Set as S -import qualified System.FilePath.Posix as Posix +import qualified System.FilePath.Posix.ByteString as Posix import qualified System.FilePath.ByteString as P {- Configures how to build an import tree. -} @@ -281,6 +282,12 @@ topf = asTopFilePath $ maybe lf (\sd -> getTopFilePath sd P. lf) msubdir +canImportKeys :: Remote -> Bool -> Bool +canImportKeys remote importcontent = + importcontent || isJust (Remote.importKey ia) + where + ia = Remote.importActions remote + {- Downloads all new ContentIdentifiers, or when importcontent is False, - generates Keys without downloading. - @@ -304,7 +311,7 @@ -> ImportableContents (ContentIdentifier, ByteSize) -> Annex (Maybe (ImportableContents (Either Sha Key))) importKeys remote importtreeconfig importcontent importablecontents = do - when (not importcontent && isNothing (Remote.importKey ia)) $ + unless (canImportKeys remote importcontent) $ giveup "This remote does not support importing without downloading content." -- This map is used to remember content identifiers that -- were just imported, before they have necessarily been @@ -364,7 +371,8 @@ [] -> do job <- liftIO $ newEmptyTMVarIO let ai = ActionItemOther (Just (fromRawFilePath (fromImportLocation loc))) - let importaction = starting ("import " ++ Remote.name remote) ai $ do + let si = SeekInput [] + let importaction = starting ("import " ++ Remote.name remote) ai si $ do when oldversion $ showNote "old version" tryNonAsync (importordownload cidmap db i largematcher) >>= \case @@ -383,41 +391,115 @@ importaction return (Right job) - importordownload - | not importcontent = doimport - | otherwise = dodownload + importordownload cidmap db (loc, (cid, sz)) largematcher= do + f <- locworktreefile loc + matcher <- largematcher (fromRawFilePath f) + -- When importing a key is supported, always use it rather + -- than downloading and retrieving a key, to avoid + -- generating trees with different keys for the same content. + let act = if importcontent + then case Remote.importKey ia of + Nothing -> dodownload + Just _ -> if Utility.Matcher.introspect matchNeedsFileContent matcher + then dodownload + else doimport + else doimport + act cidmap db (loc, (cid, sz)) f matcher - doimport cidmap db (loc, (cid, sz)) _largematcher = + doimport cidmap db (loc, (cid, sz)) f matcher = case Remote.importKey ia of Nothing -> error "internal" -- checked earlier - Just a -> do - let importer p = do - unsizedk <- a loc cid p - -- This avoids every remote needing - -- to add the size. - let k = alterKey unsizedk $ \kd -> kd - { keySize = keySize kd <|> Just sz } - checkSecureHashes k >>= \case - Nothing -> do - recordcidkey cidmap db cid k - logChange k (Remote.uuid remote) InfoPresent - return (Right k) - Just msg -> giveup (msg ++ " to import") - let runimport p = tryNonAsync (importer p) >>= \case - Right k -> return $ Just (loc, k) + Just importkey -> do + when (Utility.Matcher.introspect matchNeedsFileContent matcher) $ + giveup "annex.largefiles configuration examines file contents, so cannot import without content." + let mi = MatchingInfo ProvidedInfo + { providedFilePath = f + , providedKey = Nothing + , providedFileSize = sz + , providedMimeType = Nothing + , providedMimeEncoding = Nothing + } + islargefile <- checkMatcher' matcher mi mempty + metered Nothing sz $ const $ if islargefile + then doimportlarge importkey cidmap db loc cid sz f + else doimportsmall cidmap db loc cid sz + + doimportlarge importkey cidmap db loc cid sz f p = + tryNonAsync importer >>= \case + Right (Just (k, True)) -> return $ Just (loc, Right k) + Right _ -> return Nothing + Left e -> do + warning (show e) + return Nothing + where + importer = do + unsizedk <- importkey loc cid + -- Don't display progress when generating + -- key, if the content will later be + -- downloaded, which is a more expensive + -- operation generally. + (if importcontent then nullMeterUpdate else p) + -- This avoids every remote needing + -- to add the size. + let k = alterKey unsizedk $ \kd -> kd + { keySize = keySize kd <|> Just sz } + checkSecureHashes k >>= \case + Nothing -> do + recordcidkey cidmap db cid k + logChange k (Remote.uuid remote) InfoPresent + if importcontent + then getcontent k + else return (Just (k, True)) + Just msg -> giveup (msg ++ " to import") + + getcontent :: Key -> Annex (Maybe (Key, Bool)) + getcontent k = do + let af = AssociatedFile (Just f) + let downloader p' tmpfile = do + k' <- Remote.retrieveExportWithContentIdentifier + ia loc cid tmpfile + (pure k) + (combineMeterUpdate p' p) + ok <- moveAnnex k' tmpfile + when ok $ + logStatus k InfoPresent + return (Just (k', ok)) + checkDiskSpaceToGet k Nothing $ + notifyTransfer Download af $ + download (Remote.uuid remote) k af stdRetry $ \p' -> + withTmp k $ downloader p' + + -- The file is small, so is added to git, so while importing + -- without content does not retrieve annexed files, it does + -- need to retrieve this file. + doimportsmall cidmap db loc cid sz p = do + let downloader tmpfile = do + k <- Remote.retrieveExportWithContentIdentifier + ia loc cid tmpfile + (mkkey tmpfile) + p + case keyGitSha k of + Just sha -> do + recordcidkey cidmap db cid k + return sha + Nothing -> error "internal" + checkDiskSpaceToGet tmpkey Nothing $ + withTmp tmpkey $ \tmpfile -> + tryNonAsync (downloader tmpfile) >>= \case + Right sha -> return $ Just (loc, Left sha) Left e -> do warning (show e) return Nothing - metered Nothing sz $ - const runimport + where + tmpkey = importKey cid sz + mkkey tmpfile = gitShaKey <$> hashFile tmpfile - dodownload cidmap db (loc, (cid, sz)) largematcher = do - f <- locworktreefile loc + dodownload cidmap db (loc, (cid, sz)) f matcher = do let af = AssociatedFile (Just f) let downloader tmpfile p = do k <- Remote.retrieveExportWithContentIdentifier ia loc cid tmpfile - (mkkey f tmpfile largematcher) + (mkkey tmpfile) p case keyGitSha k of Nothing -> do @@ -445,25 +527,24 @@ where tmpkey = importKey cid sz - ia = Remote.importActions remote + mkkey tmpfile = do + let mi = MatchingFile FileInfo + { matchFile = f + , contentFile = Just (toRawFilePath tmpfile) + } + islargefile <- checkMatcher' matcher mi mempty + if islargefile + then do + backend <- chooseBackend (fromRawFilePath f) + let ks = KeySource + { keyFilename = f + , contentLocation = toRawFilePath tmpfile + , inodeCache = Nothing + } + fst <$> genKey ks nullMeterUpdate backend + else gitShaKey <$> hashFile tmpfile - mkkey f tmpfile largematcher = do - matcher <- largematcher (fromRawFilePath f) - let mi = MatchingFile FileInfo - { matchFile = f - , currFile = toRawFilePath tmpfile - } - islargefile <- checkMatcher' matcher mi mempty - if islargefile - then do - backend <- chooseBackend (fromRawFilePath f) - let ks = KeySource - { keyFilename = f - , contentLocation = toRawFilePath tmpfile - , inodeCache = Nothing - } - fst <$> genKey ks nullMeterUpdate backend - else gitShaKey <$> hashFile tmpfile + ia = Remote.importActions remote locworktreefile loc = fromRepo $ fromTopFilePath $ asTopFilePath $ case importtreeconfig of @@ -536,61 +617,62 @@ where load t = M.lookup (Remote.uuid r) . fst <$> preferredRequiredMapsLoad' t -wantImport :: FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool -wantImport matcher loc sz = checkMatcher' matcher mi mempty - where - mi = MatchingInfo $ ProvidedInfo - { providedFilePath = Right $ fromRawFilePath $ fromImportLocation loc - , providedKey = unavail "key" - , providedFileSize = Right sz - , providedMimeType = unavail "mime" - , providedMimeEncoding = unavail "mime" - } - -- This should never run, as long as the FileMatcher was generated - -- using the preferredContentKeylessTokens. - unavail v = Left $ error $ "Internal error: unavailable " ++ v - -{- If a file is not preferred content, but it was previously exported or - - imported to the remote, not importing it would result in a remote - - tracking branch that, when merged, would delete the file. - - - - To avoid that problem, such files are included in the import. - - The next export will remove them from the remote. - -} -shouldImport :: Export.ExportHandle -> FileMatcher Annex -> ImportLocation -> ByteSize -> Annex Bool -shouldImport dbhandle matcher loc sz = - wantImport matcher loc sz - <||> - liftIO (not . null <$> Export.getExportTreeKey dbhandle loc) - -filterImportableContents :: Remote -> FileMatcher Annex -> ImportableContents (ContentIdentifier, ByteSize) -> Annex (ImportableContents (ContentIdentifier, ByteSize)) -filterImportableContents r matcher importable - | isEmpty matcher = return importable - | otherwise = do - dbhandle <- Export.openDb (Remote.uuid r) - go dbhandle importable - where - go dbhandle ic = ImportableContents - <$> filterM (match dbhandle) (importableContents ic) - <*> mapM (go dbhandle) (importableHistory ic) - - match dbhandle (loc, (_cid, sz)) = shouldImport dbhandle matcher loc sz - {- Gets the ImportableContents from the remote. - - Filters out any paths that include a ".git" component, because git does - not allow storing ".git" in a git repository. While it is possible to - write a git tree that contains that, git will complain and refuse to - check it out. + - + - Filters out new things not matching the FileMatcher or that are + - gitignored. However, files that are already in git get imported + - regardless. (Similar to how git add behaves on gitignored files.) + - This avoids creating a remote tracking branch that, when merged, + - would delete the files. -} -listImportableContents :: Remote -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) -listImportableContents r = fmap removegitspecial - <$> Remote.listImportableContents (Remote.importActions r) +getImportableContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> FileMatcher Annex -> Annex (Maybe (ImportableContents (ContentIdentifier, ByteSize))) +getImportableContents r importtreeconfig ci matcher = + Remote.listImportableContents (Remote.importActions r) >>= \case + Nothing -> return Nothing + Just importable -> do + dbhandle <- Export.openDb (Remote.uuid r) + Just <$> filterunwanted dbhandle importable where - removegitspecial ic = ImportableContents - { importableContents = - filter (not . gitspecial . fst) (importableContents ic) - , importableHistory = - map removegitspecial (importableHistory ic) + filterunwanted dbhandle ic = ImportableContents + <$> filterM (wanted dbhandle) (importableContents ic) + <*> mapM (filterunwanted dbhandle) (importableHistory ic) + + wanted dbhandle (loc, (_cid, sz)) + | ingitdir = pure False + | otherwise = + isknown <||> (matches <&&> notignored) + where + -- Checks, from least to most expensive. + ingitdir = ".git" `elem` Posix.splitDirectories (fromImportLocation loc) + matches = matchesImportLocation matcher loc sz + isknown = isKnownImportLocation dbhandle loc + notignored = notIgnoredImportLocation importtreeconfig ci loc + +isKnownImportLocation :: Export.ExportHandle -> ImportLocation -> Annex Bool +isKnownImportLocation dbhandle loc = liftIO $ + not . null <$> Export.getExportTreeKey dbhandle loc + +matchesImportLocation :: FileMatcher Annex -> ImportLocation -> Integer -> Annex Bool +matchesImportLocation matcher loc sz = checkMatcher' matcher mi mempty + where + mi = MatchingInfo $ ProvidedInfo + { providedFilePath = fromImportLocation loc + , providedKey = Nothing + , providedFileSize = sz + , providedMimeType = Nothing + , providedMimeEncoding = Nothing } - gitspecial l = ".git" `elem` Posix.splitDirectories (fromRawFilePath (fromImportLocation l)) + +notIgnoredImportLocation :: ImportTreeConfig -> CheckGitIgnore -> ImportLocation -> Annex Bool +notIgnoredImportLocation importtreeconfig ci loc = not <$> checkIgnored ci f + where + f = fromRawFilePath $ case importtreeconfig of + ImportSubTree dir _ -> + getTopFilePath dir P. fromImportLocation loc + ImportTree -> + fromImportLocation loc diff --git a/Annex/Ingest.hs b/Annex/Ingest.hs --- a/Annex/Ingest.hs +++ b/Annex/Ingest.hs @@ -1,6 +1,6 @@ {- git-annex content ingestion - - - Copyright 2010-2019 Joey Hess + - Copyright 2010-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -18,7 +18,8 @@ addLink, makeLink, addUnlocked, - forceParams, + CheckGitIgnore(..), + gitAddParams, addAnnexedFile, ) where @@ -31,6 +32,7 @@ import Annex.Link import Annex.MetaData import Annex.CurrentBranch +import Annex.CheckIgnore import Logs.Location import qualified Annex import qualified Annex.Queue @@ -125,19 +127,19 @@ {- Ingests a locked down file into the annex. Updates the work tree and - index. -} -ingestAdd :: MeterUpdate -> Maybe LockedDown -> Annex (Maybe Key) -ingestAdd meterupdate ld = ingestAdd' meterupdate ld Nothing +ingestAdd :: CheckGitIgnore -> MeterUpdate -> Maybe LockedDown -> Annex (Maybe Key) +ingestAdd ci meterupdate ld = ingestAdd' ci meterupdate ld Nothing -ingestAdd' :: MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key) -ingestAdd' _ Nothing _ = return Nothing -ingestAdd' meterupdate ld@(Just (LockedDown cfg source)) mk = do +ingestAdd' :: CheckGitIgnore -> MeterUpdate -> Maybe LockedDown -> Maybe Key -> Annex (Maybe Key) +ingestAdd' _ _ Nothing _ = return Nothing +ingestAdd' ci meterupdate ld@(Just (LockedDown cfg source)) mk = do (mk', mic) <- ingest meterupdate ld mk case mk' of Nothing -> return Nothing Just k -> do let f = keyFilename source if lockingFile cfg - then addLink (fromRawFilePath f) k mic + then addLink ci (fromRawFilePath f) k mic else do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus (contentLocation source) @@ -292,23 +294,28 @@ - Also, using git add allows it to skip gitignored files, unless forced - to include them. -} -addLink :: FilePath -> Key -> Maybe InodeCache -> Annex () -addLink file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig) +addLink :: CheckGitIgnore -> FilePath -> Key -> Maybe InodeCache -> Annex () +addLink ci file key mcache = ifM (coreSymlinks <$> Annex.getGitConfig) ( do _ <- makeLink file key mcache - ps <- forceParams + ps <- gitAddParams ci Annex.Queue.addCommand "add" (ps++[Param "--"]) [file] , do l <- makeLink file key mcache addAnnexLink l (toRawFilePath file) ) -{- Parameters to pass to git add, forcing addition of ignored files. -} -forceParams :: Annex [CommandParam] -forceParams = ifM (Annex.getState Annex.force) +{- Parameters to pass to git add, forcing addition of ignored files. + - + - Note that, when git add is being run on an ignored file that is already + - checked in, CheckGitIgnore True has no effect. + -} +gitAddParams :: CheckGitIgnore -> Annex [CommandParam] +gitAddParams (CheckGitIgnore True) = ifM (Annex.getState Annex.force) ( return [Param "-f"] , return [] ) +gitAddParams (CheckGitIgnore False) = return [Param "-f"] {- Whether a file should be added unlocked or not. Default is to not, - unless symlinks are not supported. annex.addunlocked can override that. @@ -332,15 +339,15 @@ - - When the content of the key is not accepted into the annex, returns False. -} -addAnnexedFile :: AddUnlockedMatcher -> FilePath -> Key -> Maybe FilePath -> Annex Bool -addAnnexedFile matcher file key mtmp = ifM (addUnlocked matcher mi) +addAnnexedFile :: CheckGitIgnore -> AddUnlockedMatcher -> FilePath -> Key -> Maybe FilePath -> Annex Bool +addAnnexedFile ci matcher file key mtmp = ifM (addUnlocked matcher mi) ( do mode <- maybe (pure Nothing) (\tmp -> liftIO $ catchMaybeIO $ fileMode <$> getFileStatus tmp) mtmp - stagePointerFile (toRawFilePath file) mode =<< hashPointerFile key - Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath (toRawFilePath file)) + stagePointerFile file' mode =<< hashPointerFile key + Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file') case mtmp of Just tmp -> ifM (moveAnnex key tmp) ( linkunlocked mode >> return True @@ -351,7 +358,7 @@ , writepointer mode >> return True ) , do - addLink file key Nothing + addLink ci file key Nothing case mtmp of Just tmp -> moveAnnex key tmp Nothing -> return True @@ -359,24 +366,24 @@ where mi = case mtmp of Just tmp -> MatchingFile $ FileInfo - { currFile = toRawFilePath tmp - , matchFile = toRawFilePath file + { contentFile = Just (toRawFilePath tmp) + , matchFile = file' } -- Provide as much info as we can without access to the - -- file's content. It's better to provide wrong info - -- than for an operation to fail just because it can't - -- tell if a file should be unlocked or locked. + -- file's content. Nothing -> MatchingInfo $ ProvidedInfo - { providedFilePath = Right file - , providedKey = Right key - , providedFileSize = Right $ fromMaybe 0 $ + { providedFilePath = file' + , providedKey = Just key + , providedFileSize = fromMaybe 0 $ keySize `fromKey` key - , providedMimeType = Right "application/octet-stream" - , providedMimeEncoding = Right "binary" + , providedMimeType = Nothing + , providedMimeEncoding = Nothing } linkunlocked mode = linkFromAnnex key file mode >>= \case LinkAnnexFailed -> liftIO $ - writePointerFile (toRawFilePath file) key mode + writePointerFile file' key mode _ -> return () - writepointer mode = liftIO $ writePointerFile (toRawFilePath file) key mode + writepointer mode = liftIO $ writePointerFile file' key mode + + file' = toRawFilePath file diff --git a/Annex/Magic.hs b/Annex/Magic.hs --- a/Annex/Magic.hs +++ b/Annex/Magic.hs @@ -1,6 +1,6 @@ {- Interface to libmagic - - - Copyright 2019 Joey Hess + - Copyright 2019-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,6 +21,8 @@ #ifdef WITH_MAGICMIME import Magic import Utility.Env +import Control.Concurrent +import System.IO.Unsafe (unsafePerformIO) import Common #else type Magic = () @@ -41,7 +43,7 @@ getMagicMime :: Magic -> FilePath -> IO (Maybe (MimeType, MimeEncoding)) #ifdef WITH_MAGICMIME -getMagicMime m f = Just . parse <$> magicFile m f +getMagicMime m f = Just . parse <$> magicConcurrentSafe (magicFile m f) where parse s = let (mimetype, rest) = separate (== ';') s @@ -58,3 +60,15 @@ getMagicMimeEncoding :: MonadIO m => Magic -> FilePath -> m(Maybe MimeEncoding) getMagicMimeEncoding m f = liftIO $ fmap snd <$> getMagicMime m f + +#ifdef WITH_MAGICMIME +{-# NOINLINE mutex #-} +mutex :: MVar () +mutex = unsafePerformIO $ newMVar () + +-- Work around a bug, the library is not concurrency safe and will +-- sometimes access the wrong memory if multiple ones are called at the +-- same time. +magicConcurrentSafe :: IO a -> IO a +magicConcurrentSafe = bracket_ (takeMVar mutex) (putMVar mutex ()) +#endif diff --git a/Annex/PidLock.hs b/Annex/PidLock.hs --- a/Annex/PidLock.hs +++ b/Annex/PidLock.hs @@ -67,7 +67,7 @@ let p' = p { env = Just ((v, PidF.pidLockEnvValue) : baseenv) } withCreateProcess p' a #else - gonopidlock + liftIO gonopidlock #endif {- Wrap around actions that may run a git-annex child process via a git diff --git a/Annex/SpecialRemote.hs b/Annex/SpecialRemote.hs --- a/Annex/SpecialRemote.hs +++ b/Annex/SpecialRemote.hs @@ -36,7 +36,7 @@ headMaybe . sortBy (comparing $ \(u, _, _) -> Down $ M.lookup u t) . findByRemoteConfig (\c -> lookupName c == Just name) - <$> Logs.Remote.readRemoteLog + <$> Logs.Remote.remoteConfigMap newConfig :: RemoteName @@ -56,7 +56,7 @@ specialRemoteMap :: Annex (M.Map UUID RemoteName) specialRemoteMap = do - m <- Logs.Remote.readRemoteLog + m <- Logs.Remote.remoteConfigMap return $ M.fromList $ mapMaybe go (M.toList m) where go (u, c) = case lookupName c of @@ -79,7 +79,7 @@ autoEnable :: Annex () autoEnable = do - remotemap <- M.filter configured <$> readRemoteLog + remotemap <- M.filter configured <$> remoteConfigMap enabled <- getenabledremotes forM_ (M.toList remotemap) $ \(cu, c) -> unless (cu `M.member` enabled) $ do let u = case findSameasUUID c of diff --git a/Annex/Ssh.hs b/Annex/Ssh.hs --- a/Annex/Ssh.hs +++ b/Annex/Ssh.hs @@ -34,6 +34,7 @@ import Utility.Env import Utility.Hash import Types.CleanupActions +import Annex.Concurrent.Utility import Types.Concurrency import Git.Env import Git.Ssh @@ -107,7 +108,7 @@ -- No connection caching with concurrency is not a good -- combination, so warn the user. go (Left whynocaching) = do - Annex.getState Annex.concurrency >>= \case + getConcurrency >>= \case NonConcurrent -> return () Concurrent {} -> warnnocaching whynocaching ConcurrentPerCpu -> warnnocaching whynocaching @@ -229,7 +230,7 @@ let socketlock = socket2lock socketfile - Annex.getState Annex.concurrency >>= \case + getConcurrency >>= \case NonConcurrent -> return () Concurrent {} -> makeconnection socketlock ConcurrentPerCpu -> makeconnection socketlock diff --git a/Annex/Transfer.hs b/Annex/Transfer.hs --- a/Annex/Transfer.hs +++ b/Annex/Transfer.hs @@ -31,6 +31,7 @@ import Types.Key import qualified Types.Remote as Remote import Types.Concurrency +import Annex.Concurrent.Utility import Types.WorkerPool import Annex.WorkerPool import Backend (isCryptographicallySecure) @@ -73,9 +74,7 @@ {- Like runTransfer, but ignores any existing transfer lock file for the - transfer, allowing re-running a transfer that is already in progress. - - - - Note that this may result in confusing progress meter display in the - - webapp, if multiple processes are writing to the transfer info file. -} + -} alwaysRunTransfer :: Observable v => Transfer -> AssociatedFile -> RetryDecider -> (MeterUpdate -> Annex v) -> Annex v alwaysRunTransfer = runTransfer' True @@ -262,7 +261,7 @@ - increase total transfer speed. -} pickRemote :: Observable v => [Remote] -> (Remote -> Annex v) -> Annex v -pickRemote l a = debugLocks $ go l =<< Annex.getState Annex.concurrency +pickRemote l a = debugLocks $ go l =<< getConcurrency where go [] _ = return observeFailure go (r:[]) _ = a r diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -1,6 +1,6 @@ {- youtube-dl integration for git-annex - - - Copyright 2017-2018 Joey Hess + - Copyright 2017-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,10 +21,15 @@ import Utility.DiskFree import Utility.HtmlDetect import Utility.Process.Transcript +import Utility.Metered +import Utility.DataUnits +import Messages.Progress import Logs.Transfer import Network.URI import Control.Concurrent.Async +import Data.Char +import Text.Read -- youtube-dl can follow redirects to anywhere, including potentially -- localhost or a private address. So, it's only allowed to download @@ -43,6 +48,8 @@ -- Runs youtube-dl in a work directory, to download a single media file -- from the url. Reutrns the path to the media file in the work directory. -- +-- Displays a progress meter as youtube-dl downloads. +-- -- If youtube-dl fails without writing any files to the work directory, -- or is not installed, returns Right Nothing. -- @@ -53,14 +60,14 @@ -- -- (Note that we can't use --output to specifiy the file to download to, -- due to ) -youtubeDl :: URLString -> FilePath -> Annex (Either String (Maybe FilePath)) -youtubeDl url workdir = ifM ipAddressesUnlimited - ( withUrlOptions $ youtubeDl' url workdir +youtubeDl :: URLString -> FilePath -> MeterUpdate -> Annex (Either String (Maybe FilePath)) +youtubeDl url workdir p = ifM ipAddressesUnlimited + ( withUrlOptions $ youtubeDl' url workdir p , return $ Left youtubeDlNotAllowedMessage ) -youtubeDl' :: URLString -> FilePath -> UrlOptions -> Annex (Either String (Maybe FilePath)) -youtubeDl' url workdir uo +youtubeDl' :: URLString -> FilePath -> MeterUpdate -> UrlOptions -> Annex (Either String (Maybe FilePath)) +youtubeDl' url workdir p uo | supportedScheme uo url = ifM (liftIO $ inPath "youtube-dl") ( runcmd >>= \case Right True -> workdirfiles >>= \case @@ -81,11 +88,17 @@ runcmd = youtubeDlMaxSize workdir >>= \case Left msg -> return (Left msg) Right maxsize -> do - quiet <- commandProgressDisabled - opts <- youtubeDlOpts $ dlopts ++ maxsize ++ - if quiet then [ Param "--quiet" ] else [] - ok <- liftIO $ boolSystem' "youtube-dl" opts $ - \p -> p { cwd = Just workdir } + opts <- youtubeDlOpts (dlopts ++ maxsize) + oh <- mkOutputHandlerQuiet + -- The size is unknown to start. Once youtube-dl + -- outputs some progress, the meter will be updated + -- with the size, which is why it's important the + -- meter is passed into commandMeter' + let unknownsize = Nothing :: Maybe FileSize + ok <- metered (Just p) unknownsize $ \meter meterupdate -> + liftIO $ commandMeter' + parseYoutubeDlProgress oh (Just meter) meterupdate "youtube-dl" opts + (\pr -> pr { cwd = Just workdir }) return (Right ok) dlopts = [ Param url @@ -125,10 +138,10 @@ ) -- Download a media file to a destination, -youtubeDlTo :: Key -> URLString -> FilePath -> Annex Bool -youtubeDlTo key url dest = do +youtubeDlTo :: Key -> URLString -> FilePath -> MeterUpdate -> Annex Bool +youtubeDlTo key url dest p = do res <- withTmpWorkDir key $ \workdir -> - youtubeDl url workdir >>= \case + youtubeDl url workdir p >>= \case Right (Just mediafile) -> do liftIO $ renameFile mediafile dest return (Just True) @@ -239,3 +252,37 @@ -- involving youtube-dl in a ftp download "ftp:" -> False _ -> allowedScheme uo u + +{- Strategy: Look for chunks prefixed with \r, which look approximately + - like this: + - "ESC[K[download] 26.6% of 60.22MiB at 254.69MiB/s ETA 00:00" + - Look at the number before "% of " and the number and unit after, + - to determine the number of bytes. + -} +parseYoutubeDlProgress :: ProgressParser +parseYoutubeDlProgress = go [] . reverse . progresschunks + where + delim = '\r' + + progresschunks = drop 1 . splitc delim + + go remainder [] = (Nothing, Nothing, remainder) + go remainder (x:xs) = case split "% of " x of + (p:r:[]) -> case (parsepercent p, parsebytes r) of + (Just percent, Just total) -> + ( Just (toBytesProcessed (calc percent total)) + , Just (TotalSize total) + , remainder + ) + _ -> go (delim:x++remainder) xs + _ -> go (delim:x++remainder) xs + + calc :: Double -> Integer -> Integer + calc percent total = round (percent * fromIntegral total / 100) + + parsepercent :: String -> Maybe Double + parsepercent = readMaybe . reverse . takeWhile (not . isSpace) . reverse + + parsebytes = readSize units . takeWhile (not . isSpace) + + units = memoryUnits ++ storageUnits diff --git a/Assistant/Drop.hs b/Assistant/Drop.hs --- a/Assistant/Drop.hs +++ b/Assistant/Drop.hs @@ -16,6 +16,7 @@ import Logs.Location import CmdLine.Action import Types.NumCopies +import Types.Command {- Drop from local and/or remote when allowed by the preferred content and - numcopies settings. -} @@ -23,4 +24,7 @@ handleDrops reason fromhere key f preverified = do syncrs <- syncDataRemotes <$> getDaemonStatus locs <- liftAnnex $ loggedLocations key - liftAnnex $ handleDropsFrom locs syncrs reason fromhere key f preverified callCommandAction + liftAnnex $ handleDropsFrom + locs syncrs reason fromhere key f + (SeekInput []) + preverified callCommandAction diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -24,6 +24,7 @@ import qualified Utility.Lsof as Lsof import qualified Utility.DirWatcher as DirWatcher import Types.KeySource +import Types.Command import Config import Annex.Content import Annex.Ingest @@ -286,7 +287,7 @@ ks = keySource ld doadd = sanitycheck ks $ do (mkey, _mcache) <- liftAnnex $ do - showStart "add" $ keyFilename ks + showStart "add" (keyFilename ks) (SeekInput []) ingest nullMeterUpdate (Just $ LockedDown lockdownconfig ks) Nothing maybe (failedingest change) (done change $ fromRawFilePath $ keyFilename ks) mkey add _ _ = return Nothing diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -30,6 +30,7 @@ import Annex.Content import Annex.Wanted import CmdLine.Action +import Types.Command import qualified Data.Set as S import Control.Concurrent @@ -168,7 +169,7 @@ liftAnnex $ handleDropsFrom locs syncrs "expensive scan found too many copies of object" - present key af [] callCommandAction + present key af (SeekInput []) [] callCommandAction ts <- if present then liftAnnex . filterM (wantSend True (Just key) af . Remote.uuid . fst) =<< use syncDataRemotes (genTransfer Upload False) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -169,7 +169,7 @@ ig _ = False unlessIgnored :: FilePath -> Assistant (Maybe Change) -> Assistant (Maybe Change) -unlessIgnored file a = ifM (liftAnnex $ checkIgnored file) +unlessIgnored file a = ifM (liftAnnex $ checkIgnored (CheckGitIgnore True) file) ( noChange , a ) diff --git a/Assistant/WebApp/Configurators/AWS.hs b/Assistant/WebApp/Configurators/AWS.hs --- a/Assistant/WebApp/Configurators/AWS.hs +++ b/Assistant/WebApp/Configurators/AWS.hs @@ -154,7 +154,7 @@ getEnableS3R :: UUID -> Handler Html getEnableS3R uuid = do - m <- liftAnnex readRemoteLog + m <- liftAnnex remoteConfigMap isia <- case M.lookup uuid m of Just c -> liftAnnex $ do pc <- parsedRemoteConfig S3.remote c @@ -180,7 +180,7 @@ runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ awsCredsAForm defcreds case result of FormSuccess creds -> liftH $ do - m <- liftAnnex readRemoteLog + m <- liftAnnex remoteConfigMap let name = fromJust $ lookupName $ fromJust $ M.lookup uuid m makeAWSRemote enableSpecialRemote remotetype SmallArchiveGroup creds name M.empty diff --git a/Assistant/WebApp/Configurators/Delete.hs b/Assistant/WebApp/Configurators/Delete.hs --- a/Assistant/WebApp/Configurators/Delete.hs +++ b/Assistant/WebApp/Configurators/Delete.hs @@ -59,7 +59,7 @@ reponame <- liftAnnex $ Remote.prettyUUID uuid {- If it's not listed in the remote log, it must be a git repo. -} - gitrepo <- liftAnnex $ M.notMember uuid <$> readRemoteLog + gitrepo <- liftAnnex $ M.notMember uuid <$> remoteConfigMap $(widgetFile "configurators/delete/finished") getDeleteCurrentRepositoryR :: Handler Html diff --git a/Assistant/WebApp/Configurators/Edit.hs b/Assistant/WebApp/Configurators/Edit.hs --- a/Assistant/WebApp/Configurators/Edit.hs +++ b/Assistant/WebApp/Configurators/Edit.hs @@ -71,7 +71,7 @@ void uuidDescMapLoad groups <- lookupGroups uuid - remoteconfig <- M.lookup uuid <$> readRemoteLog + remoteconfig <- M.lookup uuid <$> remoteConfigMap let (repogroup, associateddirectory) = case getStandardGroup groups of Nothing -> (RepoGroupCustom $ unwords $ map fromGroup $ S.toList groups, Nothing) Just g -> (RepoGroupStandard g, associatedDirectory remoteconfig g) @@ -122,7 +122,7 @@ | T.null t -> noop | otherwise -> liftAnnex $ do let dir = takeBaseName $ T.unpack t - m <- readRemoteLog + m <- remoteConfigMap case M.lookup uuid m of Nothing -> noop Just remoteconfig -> configSet uuid $ @@ -220,7 +220,7 @@ let istransfer = repoGroup curr == RepoGroupStandard TransferGroup config <- liftAnnex $ fromMaybe mempty . M.lookup uuid - <$> readRemoteLog + <$> remoteConfigMap let repoInfo = getRepoInfo mremote config let repoEncryption = getRepoEncryption mremote (Just config) $(widgetFile "configurators/edit/repository") @@ -230,7 +230,7 @@ Just rmt -> do config <- liftAnnex $ fromMaybe mempty . M.lookup (Remote.uuid rmt) - <$> readRemoteLog + <$> remoteConfigMap getRepoInfo mr config Nothing -> getRepoInfo Nothing mempty g <- liftAnnex gitRepo @@ -242,7 +242,7 @@ checkAssociatedDirectory :: RepoConfig -> Maybe Remote -> Annex () checkAssociatedDirectory _ Nothing = noop checkAssociatedDirectory cfg (Just r) = do - repoconfig <- M.lookup (Remote.uuid r) <$> readRemoteLog + repoconfig <- M.lookup (Remote.uuid r) <$> remoteConfigMap case repoGroup cfg of RepoGroupStandard gr -> case associatedDirectory repoconfig gr of Just d -> do diff --git a/Assistant/WebApp/Configurators/IA.hs b/Assistant/WebApp/Configurators/IA.hs --- a/Assistant/WebApp/Configurators/IA.hs +++ b/Assistant/WebApp/Configurators/IA.hs @@ -158,7 +158,7 @@ runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $ iaCredsAForm defcreds case result of FormSuccess creds -> liftH $ do - m <- liftAnnex readRemoteLog + m <- liftAnnex remoteConfigMap let name = fromJust $ lookupName $ fromJust $ M.lookup uuid m AWS.makeAWSRemote enableSpecialRemote S3.remote PublicGroup creds name M.empty diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs --- a/Assistant/WebApp/Configurators/Ssh.hs +++ b/Assistant/WebApp/Configurators/Ssh.hs @@ -209,7 +209,7 @@ -} enableSshRemote :: (RemoteConfig -> Maybe SshData) -> (SshInput -> RemoteName -> Handler Html) -> (SshData -> UUID -> Handler Html) -> UUID -> Handler Html enableSshRemote getsshdata rsyncnetsetup genericsetup u = do - m <- fromMaybe M.empty . M.lookup u <$> liftAnnex readRemoteLog + m <- fromMaybe M.empty . M.lookup u <$> liftAnnex remoteConfigMap case (unmangle <$> getsshdata m, lookupName m) of (Just sshdata, Just reponame) -> sshConfigurator $ do ((result, form), enctype) <- liftH $ @@ -424,7 +424,7 @@ -- Not a UUID we know, so prompt about combining. $(widgetFile "configurators/ssh/combine") handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do - m <- liftAnnex readRemoteLog + m <- liftAnnex remoteConfigMap case fromProposedAccepted <$> (M.lookup typeField =<< M.lookup u m) of Just "gcrypt" -> combineExistingGCrypt sshdata' u _ -> makeSshRepo ExistingRepo sshdata' @@ -545,7 +545,7 @@ -- Record the location of the ssh remote in the remote log, so it -- can easily be enabled elsewhere using the webapp. setup r = do - m <- readRemoteLog + m <- remoteConfigMap let c = fromMaybe M.empty (M.lookup (Remote.uuid r) m) let c' = M.insert (Proposed "location") (Proposed (genSshUrl sshdata)) $ M.insert typeField (Proposed "git") $ diff --git a/Assistant/WebApp/Configurators/WebDAV.hs b/Assistant/WebApp/Configurators/WebDAV.hs --- a/Assistant/WebApp/Configurators/WebDAV.hs +++ b/Assistant/WebApp/Configurators/WebDAV.hs @@ -53,7 +53,7 @@ getEnableWebDAVR = postEnableWebDAVR postEnableWebDAVR :: UUID -> Handler Html postEnableWebDAVR uuid = do - m <- liftAnnex readRemoteLog + m <- liftAnnex remoteConfigMap let c = fromJust $ M.lookup uuid m let name = fromJust $ lookupName c let url = fromProposedAccepted $ fromJust $ M.lookup (Accepted "url") c diff --git a/Assistant/WebApp/Gpg.hs b/Assistant/WebApp/Gpg.hs --- a/Assistant/WebApp/Gpg.hs +++ b/Assistant/WebApp/Gpg.hs @@ -80,7 +80,7 @@ mname <- ifM (inRepo $ Git.Command.runBool [Param "fetch", Param tmpremote]) ( do void Annex.Branch.forceUpdate - (lookupName <=< M.lookup u) <$> readRemoteLog + (lookupName <=< M.lookup u) <$> remoteConfigMap , return Nothing ) void $ inRepo $ Git.Remote.Remove.remove tmpremote diff --git a/Assistant/WebApp/RepoList.hs b/Assistant/WebApp/RepoList.hs --- a/Assistant/WebApp/RepoList.hs +++ b/Assistant/WebApp/RepoList.hs @@ -162,7 +162,7 @@ return $ here : l else return l unconfigured = liftAnnex $ do - m <- readRemoteLog + m <- remoteConfigMap g <- gitRepo map snd . catMaybes . filter selectedremote . map (findinfo m g) diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -15,7 +15,6 @@ import CmdLine.GitAnnex.Options import qualified Annex import qualified Annex.Branch -import Annex.Action import qualified Options.Applicative as O @@ -35,10 +34,6 @@ -- The cmd is run for benchmarking without startup or -- shutdown actions. Annex.eval st $ performCommandAction cmd seek noop - -- Since the cmd will be run many times, some zombie - -- processes that normally only occur once per command - -- will build up; reap them. - reapZombies where -- Simplified versio of CmdLine.dispatch, without support for fuzzy -- matching or out-of-repo commands. diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,52 @@ +git-annex (8.20201007) upstream; urgency=medium + + * --json output now includes a new field "input" which is the input + value (filename, url, etc) that caused a json object to be output. + * --batch combined with -J now runs batch requests concurrently for many + commands. Before, the combination was accepted, but did not enable + concurrency. Since the output of batch requests can be in any order, + --json with the new "input" field is recommended to be used, + to determine which batch request each response corresponds to. + * aws-0.22 improved its support for setting etags, which improves + support for versioned S3 buckets. + * Serialize use of C magic library, which is not thread safe. + This fixes failures uploading to S3 when using -J. + * add, addurl, importfeed, import: Added --no-check-gitignore option + for finer grained control than using --force. + * import: Check gitignores when importing trees from special remotes. + * addunused: Don't check .gitignores when adding files. + * Improve the "Try making some of these repositories available" + message, with some hints for the user for what to do. + * Improve --debug output to show pid of processes that are started and + stopped. + * sync --all: Sped up seeking to around twice as fast, by avoiding a + pass over the worktree files when preferred content expressions of the + local repo and remotes don't use include=/exclude=. + * Sped up seeking for files to operate on, when using options like + --copies or --in, by around 20% + * import --no-content: Check annex.largefiles, and import small + files into git, the same as is done when importing with content. + If the largefiles expression needs the file content available + (due to mimetype or mimeencoding being used), the import will fail. + * sync: When run without --content, import without copying from + importtree=yes directory special remotes. + (Other special remotes may support this later as well.) + * addurl: Avoid a redundant git ignores check for speed. + * upgrade: Avoid an upgrade failure of a bare repo in unusual circumstances. + * httpalso: Support being used with special remotes that do not have + encryption= in their config. + * Parse youtube-dl progress output, which lets progress be displayed + when doing concurrent downloads. + * Fix build with Benchmark build flag. + * Enable building with git-annex benchmark by default, only turning it + off when the criterion library is not installed. + * runshell: Fix a edge case where rm errors were sent to stdout, which + could confuse things parsing git-annex output. + * runshell: Update files atomically when preparing to run git-annex. + * Fix a build failure on Windows. + + -- Joey Hess Wed, 07 Oct 2020 12:19:05 -0400 + git-annex (8.20200908) upstream; urgency=medium * Added httpalso special remote, which is useful for accessing diff --git a/CmdLine/Action.hs b/CmdLine/Action.hs --- a/CmdLine/Action.hs +++ b/CmdLine/Action.hs @@ -53,9 +53,11 @@ - This should only be run in the seek stage. -} commandAction :: CommandStart -> Annex () -commandAction start = Annex.getState Annex.concurrency >>= \case +commandAction start = getConcurrency >>= \case NonConcurrent -> runnonconcurrent - Concurrent _ -> runconcurrent + Concurrent n + | n > 1 -> runconcurrent + | otherwise -> runnonconcurrent ConcurrentPerCpu -> runconcurrent where runnonconcurrent = void $ includeCommandAction start @@ -174,17 +176,11 @@ - stages, without catching errors and without incrementing error counter. - Useful if one command wants to run part of another command. -} callCommandAction :: CommandStart -> CommandCleanup -callCommandAction = fromMaybe True <$$> callCommandAction' - -{- Like callCommandAction, but returns Nothing when the command did not - - perform any action. -} -callCommandAction' :: CommandStart -> Annex (Maybe Bool) -callCommandAction' start = - start >>= \case - Nothing -> return Nothing - Just (startmsg, perform) -> do - showStartMessage startmsg - Just <$> performCommandAction' startmsg perform +callCommandAction start = start >>= \case + Just (startmsg, perform) -> do + showStartMessage startmsg + performCommandAction' startmsg perform + Nothing -> return True performCommandAction' :: StartMessage -> CommandPerform -> CommandCleanup performCommandAction' startmsg perform = @@ -206,9 +202,9 @@ -} startConcurrency :: UsedStages -> Annex a -> Annex a startConcurrency usedstages a = do - fromcmdline <- Annex.getState Annex.concurrency + fromcmdline <- getConcurrency fromgitcfg <- annexJobs <$> Annex.getGitConfig - let usegitcfg = setConcurrency fromgitcfg + let usegitcfg = setConcurrency (ConcurrencyGitConfig fromgitcfg) case (fromcmdline, fromgitcfg) of (NonConcurrent, NonConcurrent) -> a (Concurrent n, _) -> @@ -264,7 +260,7 @@ - May be called repeatedly by the same thread without blocking. -} ensureOnlyActionOn :: Key -> Annex a -> Annex a ensureOnlyActionOn k a = debugLocks $ - go =<< Annex.getState Annex.concurrency + go =<< getConcurrency where go NonConcurrent = a go (Concurrent _) = goconcurrent diff --git a/CmdLine/Batch.hs b/CmdLine/Batch.hs --- a/CmdLine/Batch.hs +++ b/CmdLine/Batch.hs @@ -8,6 +8,7 @@ module CmdLine.Batch where import Annex.Common +import qualified Annex import Types.Command import CmdLine.Action import CmdLine.GitAnnex.Options @@ -18,6 +19,8 @@ import Annex.BranchState import Annex.WorkTree import Annex.Content +import Annex.Concurrent +import Types.Concurrency data BatchMode = Batch BatchFormat | NoBatch @@ -42,7 +45,9 @@ -- In batch mode, one line at a time is read, parsed, and a reply output to -- stdout. In non batch mode, the command's parameters are parsed and -- a reply output for each. -batchable :: (opts -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser +-- +-- Note that the actions are not run concurrently. +batchable :: (opts -> SeekInput -> String -> Annex Bool) -> Parser opts -> CmdParamsDesc -> CommandParser batchable handler parser paramdesc = batchseeker <$> batchparser where batchparser = (,,) @@ -51,12 +56,12 @@ <*> cmdParams paramdesc batchseeker (opts, NoBatch, params) = - mapM_ (go NoBatch opts) params + mapM_ (\p -> go NoBatch opts (SeekInput [p], p)) params batchseeker (opts, batchmode@(Batch fmt), _) = batchInput fmt (pure . Right) (go batchmode opts) - go batchmode opts p = - unlessM (handler opts p) $ + go batchmode opts (si, p) = + unlessM (handler opts si p) $ batchBadInput batchmode -- bad input is indicated by an empty line in batch mode. In non batch @@ -72,17 +77,18 @@ -- be converted to relative. Normally, filename parameters are passed -- through git ls-files, which makes them relative, but batch mode does -- not use that, and absolute worktree files are likely to cause breakage. -batchInput :: BatchFormat -> (String -> Annex (Either String a)) -> (a -> Annex ()) -> Annex () +batchInput :: BatchFormat -> (String -> Annex (Either String v)) -> ((SeekInput, v) -> Annex ()) -> Annex () batchInput fmt parser a = go =<< batchLines fmt where go [] = return () go (l:rest) = do - either parseerr a =<< parser l + either parseerr (\v -> a (SeekInput [l], v)) =<< parser l go rest parseerr s = giveup $ "Batch input parse failure: " ++ s batchLines :: BatchFormat -> Annex [String] batchLines fmt = do + checkBatchConcurrency enableInteractiveBranchAccess liftIO $ splitter <$> getContents where @@ -90,45 +96,57 @@ BatchLine -> lines BatchNull -> splitc '\0' --- Runs a CommandStart in batch mode. --- +-- When concurrency is enabled at the command line, it is used in batch +-- mode. But, if it's only set in git config, don't use it, because the +-- program using batch mode may not expect interleaved output. +checkBatchConcurrency :: Annex () +checkBatchConcurrency = Annex.getState Annex.concurrency >>= \case + ConcurrencyCmdLine _ -> noop + ConcurrencyGitConfig _ -> + setConcurrency (ConcurrencyGitConfig (Concurrent 1)) + +batchCommandAction :: CommandStart -> Annex () +batchCommandAction = commandAction . batchCommandStart + -- The batch mode user expects to read a line of output, and it's up to the -- CommandStart to generate that output as it succeeds or fails to do its -- job. However, if it stops without doing anything, it won't generate --- any output, so in that case, batchBadInput is used to provide the caller --- with an empty line. -batchCommandAction :: CommandStart -> Annex () -batchCommandAction a = maybe (batchBadInput (Batch BatchLine)) (const noop) - =<< callCommandAction' a +-- any output. This modifies it so in that case, an empty line is printed. +batchCommandStart :: CommandStart -> CommandStart +batchCommandStart a = a >>= \case + Just v -> return (Just v) + Nothing -> do + batchBadInput (Batch BatchLine) + return Nothing -- Reads lines of batch input and passes the filepaths to a CommandStart -- to handle them. -- --- Absolute filepaths are converted to relative. +-- Absolute filepaths are converted to relative, because in non-batch +-- mode, that is done when CmdLine.Seek uses git ls-files. -- --- File matching options are not checked. -batchStart :: BatchFormat -> (FilePath -> CommandStart) -> Annex () -batchStart fmt a = batchInput fmt (Right <$$> liftIO . relPathCwdToFile) $ - batchCommandAction . a - --- Like batchStart, but checks the file matching options --- and skips non-matching files. -batchFilesMatching :: BatchFormat -> (RawFilePath -> CommandStart) -> Annex () +-- File matching options are checked, and non-matching files skipped. +batchFilesMatching :: BatchFormat -> ((SeekInput, RawFilePath) -> CommandStart) -> Annex () batchFilesMatching fmt a = do matcher <- getMatcher - batchStart fmt $ \f -> + go $ \si f -> let f' = toRawFilePath f - in ifM (matcher $ MatchingFile $ FileInfo f' f') - ( a f' + in ifM (matcher $ MatchingFile $ FileInfo (Just f') f') + ( a (si, f') , return Nothing ) + where + go a' = batchInput fmt + (Right <$$> liftIO . relPathCwdToFile) + (batchCommandAction . uncurry a') batchAnnexedFilesMatching :: BatchFormat -> AnnexedFileSeeker -> Annex () -batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $ - whenAnnexed $ \f k -> case checkContentPresent seeker of - Just v -> do - present <- inAnnex k - if present == v - then startAction seeker f k - else return Nothing - Nothing -> startAction seeker f k +batchAnnexedFilesMatching fmt seeker = batchFilesMatching fmt $ \(si, bf) -> + flip whenAnnexed bf $ \f k -> + case checkContentPresent seeker of + Just v -> do + present <- inAnnex k + if present == v + then startAction seeker si f k + else return Nothing + Nothing -> startAction seeker si f k diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -392,7 +392,7 @@ -- action in `allowConcurrentOutput`. jobsOption :: [GlobalOption] jobsOption = - [ globalSetter setConcurrency $ + [ globalSetter (setConcurrency . ConcurrencyCmdLine) $ option (maybeReader parseConcurrency) ( long "jobs" <> short 'J' <> metavar (paramNumber `paramOr` "cpus") diff --git a/CmdLine/Seek.hs b/CmdLine/Seek.hs --- a/CmdLine/Seek.hs +++ b/CmdLine/Seek.hs @@ -18,7 +18,6 @@ import Types.FileMatcher import qualified Annex import qualified Git -import qualified Git.Command import qualified Git.LsFiles as LsFiles import qualified Git.LsTree as LsTree import qualified Git.Types as Git @@ -39,6 +38,7 @@ import Annex.Link import Annex.InodeSentinal import Annex.Concurrent +import Annex.CheckIgnore import qualified Annex.Branch import qualified Annex.BranchState import qualified Database.Keys @@ -50,7 +50,7 @@ import System.Posix.Types data AnnexedFileSeeker = AnnexedFileSeeker - { startAction :: RawFilePath -> Key -> CommandStart + { startAction :: SeekInput -> RawFilePath -> Key -> CommandStart , checkContentPresent :: Maybe Bool , usesLocationLog :: Bool } @@ -67,32 +67,29 @@ else seekFilteredKeys a (getfiles [] l) ) where - getfiles c [] = return (reverse c) + getfiles c [] = return (reverse c, pure True) getfiles c (p:ps) = do os <- seekOptions ww (fs, cleanup) <- inRepo $ LsFiles.inRepoDetails os [toRawFilePath p] - case fs of + r <- case fs of [f] -> do void $ liftIO $ cleanup - getfiles (f:c) ps + fst <$> getfiles ((SeekInput [p], f):c) ps [] -> do void $ liftIO $ cleanup - getfiles c ps - _ -> giveup needforce + fst <$> getfiles c ps + _ -> do + void $ liftIO $ cleanup + giveup needforce + return (r, pure True) withFilesInGitAnnexNonRecursive _ _ _ NoWorkTreeItems = noop -withFilesNotInGit :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek -withFilesNotInGit a (WorkTreeItems l) = go =<< seek - where - seek = do - force <- Annex.getState Annex.force - g <- gitRepo - liftIO $ Git.Command.leaveZombie - <$> LsFiles.notInRepo [] force l' g - go fs = seekFiltered a $ - return $ concat $ segmentPaths id l' fs - l' = map toRawFilePath l -withFilesNotInGit _ NoWorkTreeItems = noop +withFilesNotInGit :: CheckGitIgnore -> WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek +withFilesNotInGit (CheckGitIgnore ci) ww a l = do + force <- Annex.getState Annex.force + let include_ignored = force || not ci + seekFiltered (const (pure True)) a $ + seekHelper id ww (const $ LsFiles.notInRepo [] include_ignored) l withPathContents :: ((FilePath, FilePath) -> CommandSeek) -> CmdParams -> CommandSeek withPathContents a params = do @@ -109,7 +106,7 @@ , return [(p, takeFileName p)] ) checkmatch matcher (f, relf) = matcher $ MatchingFile $ FileInfo - { currFile = toRawFilePath f + { contentFile = Just (toRawFilePath f) , matchFile = toRawFilePath relf } @@ -119,24 +116,24 @@ withStrings :: (String -> CommandSeek) -> CmdParams -> CommandSeek withStrings a params = sequence_ $ map a params -withPairs :: ((String, String) -> CommandSeek) -> CmdParams -> CommandSeek -withPairs a params = sequence_ $ map a $ pairs [] params +withPairs :: ((SeekInput, (String, String)) -> CommandSeek) -> CmdParams -> CommandSeek +withPairs a params = sequence_ $ + map (\p@(x,y) -> a (SeekInput [x,y], p)) (pairs [] params) where pairs c [] = reverse c pairs c (x:y:xs) = pairs ((x,y):c) xs pairs _ _ = giveup "expected pairs" -withFilesToBeCommitted :: (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek -withFilesToBeCommitted a l = seekFiltered a $ +withFilesToBeCommitted :: ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek +withFilesToBeCommitted a l = seekFiltered (const (pure True)) a $ seekHelper id WarnUnmatchWorkTreeItems (const LsFiles.stagedNotDeleted) l {- unlocked pointer files that are staged, and whose content has not been - modified-} -withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek -withUnmodifiedUnlockedPointers ww a l = seekFiltered a unlockedfiles - where - unlockedfiles = filterM isUnmodifiedUnlocked - =<< seekHelper id ww (const LsFiles.typeChangedStaged) l +withUnmodifiedUnlockedPointers :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek +withUnmodifiedUnlockedPointers ww a l = + seekFiltered (isUnmodifiedUnlocked . snd) a $ + seekHelper id ww (const LsFiles.typeChangedStaged) l isUnmodifiedUnlocked :: RawFilePath -> Annex Bool isUnmodifiedUnlocked f = catKeyFile f >>= \case @@ -144,12 +141,12 @@ Just k -> sameInodeCache f =<< Database.Keys.getInodeCaches k {- Finds files that may be modified. -} -withFilesMaybeModified :: WarnUnmatchWhen -> (RawFilePath -> CommandSeek) -> WorkTreeItems -> CommandSeek -withFilesMaybeModified ww a params = seekFiltered a $ +withFilesMaybeModified :: WarnUnmatchWhen -> ((SeekInput, RawFilePath) -> CommandSeek) -> WorkTreeItems -> CommandSeek +withFilesMaybeModified ww a params = seekFiltered (const (pure True)) a $ seekHelper id ww LsFiles.modified params -withKeys :: (Key -> CommandSeek) -> CmdParams -> CommandSeek -withKeys a l = sequence_ $ map (a . parse) l +withKeys :: ((SeekInput, Key) -> CommandSeek) -> CmdParams -> CommandSeek +withKeys a ls = sequence_ $ map (\l -> a (SeekInput [l], parse l)) ls where parse p = fromMaybe (giveup "bad key") $ deserializeKey p @@ -170,7 +167,7 @@ :: Maybe KeyOptions -> Bool -> AnnexedFileSeeker - -> ((Key, ActionItem) -> CommandSeek) + -> ((SeekInput, Key, ActionItem) -> CommandSeek) -> (WorkTreeItems -> CommandSeek) -> WorkTreeItems -> CommandSeek @@ -178,7 +175,7 @@ where mkkeyaction = do matcher <- Limit.getMatcher - return $ \v@(k, ai) -> checkseeker k $ + return $ \v@(_si, k, ai) -> checkseeker k $ let i = case ai of ActionItemBranchFilePath (BranchFilePath _ topf) _ -> MatchingKey k (AssociatedFile $ Just $ getTopFilePath topf) @@ -194,7 +191,7 @@ withKeyOptions' :: Maybe KeyOptions -> Bool - -> Annex ((Key, ActionItem) -> Annex ()) + -> Annex ((SeekInput, Key, ActionItem) -> Annex ()) -> (WorkTreeItems -> CommandSeek) -> WorkTreeItems -> CommandSeek @@ -245,7 +242,7 @@ Nothing -> return () Just ((k, f), content) -> do maybe noop (Annex.BranchState.setCache f) content - keyaction (k, mkActionItem k) + keyaction (SeekInput [], k, mkActionItem k) go reader catObjectStreamLsTree l (getk . getTopFilePath . LsTree.file) g go liftIO $ void cleanup @@ -253,7 +250,7 @@ runkeyaction getks = do keyaction <- mkkeyaction ks <- getks - forM_ ks $ \k -> keyaction (k, mkActionItem k) + forM_ ks $ \k -> keyaction (SeekInput [], k, mkActionItem k) runbranchkeys bs = do keyaction <- mkkeyaction @@ -263,7 +260,7 @@ Nothing -> noop Just k -> let bfp = mkActionItem (BranchFilePath b (LsTree.file i), k) - in keyaction (k, bfp) + in keyaction (SeekInput [], k, bfp) unlessM (liftIO cleanup) $ error ("git ls-tree " ++ Git.fromRef b ++ " failed") @@ -272,127 +269,166 @@ rs <- remoteList ts <- concat <$> mapM (getFailedTransfers . Remote.uuid) rs forM_ ts $ \(t, i) -> - keyaction (transferKey t, mkActionItem (t, i)) + keyaction (SeekInput [], transferKey t, mkActionItem (t, i)) -seekFiltered :: (RawFilePath -> CommandSeek) -> Annex [RawFilePath] -> Annex () -seekFiltered a fs = do +seekFiltered :: ((SeekInput, RawFilePath) -> Annex Bool) -> ((SeekInput, RawFilePath) -> CommandSeek) -> Annex ([(SeekInput, RawFilePath)], IO Bool) -> Annex () +seekFiltered prefilter a listfs = do matcher <- Limit.getMatcher - sequence_ =<< (map (process matcher) <$> fs) + (fs, cleanup) <- listfs + sequence_ (map (process matcher) fs) + liftIO $ void cleanup where - process matcher f = - whenM (matcher $ MatchingFile $ FileInfo f f) $ a f + process matcher v@(_si, f) = + whenM (prefilter v) $ + whenM (matcher $ MatchingFile $ FileInfo (Just f) f) $ + a v +data MatcherInfo = MatcherInfo + { matcherAction :: MatchInfo -> Annex Bool + , matcherNeedsFileName :: Bool + , matcherNeedsKey :: Bool + , matcherNeedsLocationLog :: Bool + } + +checkMatcherWhen :: MatcherInfo -> Bool -> MatchInfo -> Annex () -> Annex () +checkMatcherWhen mi c i a + | c = whenM (matcherAction mi i) a + | otherwise = a + -- This is significantly faster than using lookupKey after seekFiltered, -- because of the way data is streamed through git cat-file. -- -- It can also precache location logs using the same efficient streaming. -seekFilteredKeys :: AnnexedFileSeeker -> Annex [(RawFilePath, Git.Sha, FileMode)] -> Annex () +seekFilteredKeys :: AnnexedFileSeeker -> Annex ([(SeekInput, (RawFilePath, Git.Sha, FileMode))], IO Bool) -> Annex () seekFilteredKeys seeker listfs = do g <- Annex.gitRepo - matcher <- Limit.getMatcher + mi <- MatcherInfo + <$> Limit.getMatcher + <*> Limit.introspect matchNeedsFileName + <*> Limit.introspect matchNeedsKey + <*> Limit.introspect matchNeedsLocationLog config <- Annex.getGitConfig - -- Run here, not in the async, because it could throw an exception - -- The list should be built lazily. - l <- listfs + (l, cleanup) <- listfs catObjectMetaDataStream g $ \mdfeeder mdcloser mdreader -> catObjectStream g $ \ofeeder ocloser oreader -> do processertid <- liftIO . async =<< forkState - (process matcher ofeeder mdfeeder mdcloser False l) + (process mi ofeeder mdfeeder mdcloser False l) mdprocessertid <- liftIO . async =<< forkState - (mdprocess matcher mdreader ofeeder ocloser) - if usesLocationLog seeker + (mdprocess mi mdreader ofeeder ocloser) + if usesLocationLog seeker || matcherNeedsLocationLog mi then catObjectStream g $ \lfeeder lcloser lreader -> do precachertid <- liftIO . async =<< forkState - (precacher config oreader lfeeder lcloser) - precachefinisher lreader + (precacher mi config oreader lfeeder lcloser) + precachefinisher mi lreader join (liftIO (wait precachertid)) - else finisher oreader + else finisher mi oreader join (liftIO (wait mdprocessertid)) join (liftIO (wait processertid)) + liftIO $ void cleanup where - checkpresence k cont = case checkContentPresent seeker of - Just v -> do - present <- inAnnex k - when (present == v) cont - Nothing -> cont - - finisher oreader = liftIO oreader >>= \case - Just (f, content) -> do - case parseLinkTargetOrPointerLazy =<< content of - Just k -> checkpresence k $ - commandAction $ - startAction seeker f k - Nothing -> noop - finisher oreader + finisher mi oreader = liftIO oreader >>= \case + Just ((si, f), content) -> do + keyaction f mi content $ + commandAction . startAction seeker si f + finisher mi oreader Nothing -> return () - precachefinisher lreader = liftIO lreader >>= \case - Just ((logf, f, k), logcontent) -> do + precachefinisher mi lreader = liftIO lreader >>= \case + Just ((logf, (si, f), k), logcontent) -> do maybe noop (Annex.BranchState.setCache logf) logcontent - commandAction $ startAction seeker f k - precachefinisher lreader + checkMatcherWhen mi + (matcherNeedsLocationLog mi && not (matcherNeedsFileName mi)) + (MatchingKey k (AssociatedFile (Just f))) + (commandAction $ startAction seeker si f k) + precachefinisher mi lreader Nothing -> return () - precacher config oreader lfeeder lcloser = liftIO oreader >>= \case - Just (f, content) -> do - case parseLinkTargetOrPointerLazy =<< content of - Just k -> checkpresence k $ - let logf = locationLogFile config k - ref = Git.Ref.branchFileRef Annex.Branch.fullname logf - in liftIO $ lfeeder ((logf, f, k), ref) - Nothing -> noop - precacher config oreader lfeeder lcloser + precacher mi config oreader lfeeder lcloser = liftIO oreader >>= \case + Just ((si, f), content) -> do + keyaction f mi content $ \k -> + let logf = locationLogFile config k + ref = Git.Ref.branchFileRef Annex.Branch.fullname logf + in liftIO $ lfeeder ((logf, (si, f), k), ref) + precacher mi config oreader lfeeder lcloser Nothing -> liftIO $ void lcloser - feedmatches matcher ofeeder f sha = - whenM (matcher $ MatchingFile $ FileInfo f f) $ - liftIO $ ofeeder (f, sha) + feedmatches mi ofeeder si f sha = checkMatcherWhen mi + -- When the matcher needs a key or location log + -- (and does not need a worktree filename), it will be + -- checked later, to avoid a slow lookup here. + (not ((matcherNeedsKey mi || matcherNeedsLocationLog mi) + && not (matcherNeedsFileName mi))) + (MatchingFile $ FileInfo (Just f) f) + (liftIO $ ofeeder ((si, f), sha)) - process matcher ofeeder mdfeeder mdcloser seenpointer ((f, sha, mode):rest) = + keyaction f mi content a = + case parseLinkTargetOrPointerLazy =<< content of + Just k -> checkMatcherWhen mi + (matcherNeedsKey mi && not (matcherNeedsFileName mi || matcherNeedsLocationLog mi)) + (MatchingKey k (AssociatedFile (Just f))) + (checkpresence k (a k)) + Nothing -> noop + + checkpresence k cont = case checkContentPresent seeker of + Just v -> do + present <- inAnnex k + when (present == v) cont + Nothing -> cont + + process mi ofeeder mdfeeder mdcloser seenpointer ((si, (f, sha, mode)):rest) = case Git.toTreeItemType mode of Just Git.TreeSymlink -> do whenM (exists f) $ -- Once a pointer file has been seen, -- symlinks have to be sent via the - -- metadata processor too. That is slightly - -- slower, but preserves the requested - -- file order. + -- metadata processor too. That is + -- slightly slower, but preserves the + -- requested file order. if seenpointer - then liftIO $ mdfeeder (f, sha) - else feedmatches matcher ofeeder f sha - process matcher ofeeder mdfeeder mdcloser seenpointer rest + then liftIO $ mdfeeder ((si, f), sha) + else feedmatches mi ofeeder si f sha + process mi ofeeder mdfeeder mdcloser seenpointer rest Just Git.TreeSubmodule -> - process matcher ofeeder mdfeeder mdcloser seenpointer rest + process mi ofeeder mdfeeder mdcloser seenpointer rest -- Might be a pointer file, might be other -- file in git, possibly large. Avoid catting -- large files by first looking up the size. Just _ -> do whenM (exists f) $ - liftIO $ mdfeeder (f, sha) - process matcher ofeeder mdfeeder mdcloser True rest + liftIO $ mdfeeder ((si, f), sha) + process mi ofeeder mdfeeder mdcloser True rest Nothing -> - process matcher ofeeder mdfeeder mdcloser seenpointer rest + process mi ofeeder mdfeeder mdcloser seenpointer rest process _ _ _ mdcloser _ [] = liftIO $ void mdcloser -- Check if files exist, because a deleted file will still be -- listed by ls-tree, but should not be processed. exists p = isJust <$> liftIO (catchMaybeIO $ R.getSymbolicLinkStatus p) - mdprocess matcher mdreader ofeeder ocloser = liftIO mdreader >>= \case - Just (f, Just (sha, size, _type)) + mdprocess mi mdreader ofeeder ocloser = liftIO mdreader >>= \case + Just ((si, f), Just (sha, size, _type)) | size < maxPointerSz -> do - feedmatches matcher ofeeder f sha - mdprocess matcher mdreader ofeeder ocloser - Just _ -> mdprocess matcher mdreader ofeeder ocloser + feedmatches mi ofeeder si f sha + mdprocess mi mdreader ofeeder ocloser + Just _ -> mdprocess mi mdreader ofeeder ocloser Nothing -> liftIO $ void ocloser -seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex [a] +seekHelper :: (a -> RawFilePath) -> WarnUnmatchWhen -> ([LsFiles.Options] -> [RawFilePath] -> Git.Repo -> IO ([a], IO Bool)) -> WorkTreeItems -> Annex ([(SeekInput, a)], IO Bool) seekHelper c ww a (WorkTreeItems l) = do os <- seekOptions ww - inRepo $ \g -> - concat . concat <$> forM (segmentXargsOrdered l) - (runSegmentPaths c (\fs -> Git.Command.leaveZombie <$> a os fs g) . map toRawFilePath) -seekHelper _ _ _ NoWorkTreeItems = return [] + inRepo $ \g -> combinelists <$> forM (segmentXargsOrdered l) + (runSegmentPaths' mk c (\fs -> a os fs g) . map toRawFilePath) + where + mk (Just i) f = (SeekInput [fromRawFilePath i], f) + -- This is not accurate, but it only happens when there are a + -- great many input WorkTreeItems. + mk Nothing f = (SeekInput [fromRawFilePath (c f)], f) + + combinelists v = + let r = concat $ concat $ map fst v + cleanup = and <$> sequence (map snd v) + in (r, cleanup) +seekHelper _ _ _ NoWorkTreeItems = return ([], pure True) data WarnUnmatchWhen = WarnUnmatchLsFiles | WarnUnmatchWorkTreeItems diff --git a/Command.hs b/Command.hs --- a/Command.hs +++ b/Command.hs @@ -74,13 +74,15 @@ withGlobalOptions os c = c { cmdglobaloptions = cmdglobaloptions c ++ concat os } {- For start stage to indicate what will be done. -} -starting:: MkActionItem t => String -> t -> CommandPerform -> CommandStart -starting msg t a = next (StartMessage msg (mkActionItem t), a) +starting:: MkActionItem actionitem => String -> actionitem -> SeekInput -> CommandPerform -> CommandStart +starting msg ai si a = next + (StartMessage msg (mkActionItem ai) si, a) {- Use when noMessages was used but the command is going to output - usual messages after all. -} -startingUsualMessages :: MkActionItem t => String -> t -> CommandPerform -> CommandStart -startingUsualMessages msg t a = next (StartUsualMessages msg (mkActionItem t), a) +startingUsualMessages :: MkActionItem t => String -> t -> SeekInput -> CommandPerform -> CommandStart +startingUsualMessages msg t si a = next + (StartUsualMessages msg (mkActionItem t) si, a) {- When no message should be displayed at start/end, but messages can still - be displayed when using eg includeCommandAction. -} diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -24,6 +24,7 @@ import Config.GitConfig import qualified Git.UpdateIndex import Utility.FileMode +import Utility.OptParse import qualified Utility.RawFilePath as R cmd :: Command @@ -37,6 +38,7 @@ , batchOption :: BatchMode , updateOnly :: Bool , largeFilesOverride :: Maybe Bool + , checkGitIgnoreOption :: CheckGitIgnore } optParser :: CmdParamsDesc -> Parser AddOptions @@ -49,6 +51,7 @@ <> help "only update tracked files" ) <*> (parseforcelarge <|> parseforcesmall) + <*> checkGitIgnoreSwitch where parseforcelarge = flag Nothing (Just True) ( long "force-large" @@ -59,23 +62,28 @@ <> help "add all files to git, ignoring other configuration" ) +checkGitIgnoreSwitch :: Parser CheckGitIgnore +checkGitIgnoreSwitch = CheckGitIgnore <$> + invertableSwitch "check-gitignore" True + (help "Do not check .gitignore when adding files") + seek :: AddOptions -> CommandSeek seek o = startConcurrency commandStages $ do largematcher <- largeFilesMatcher addunlockedmatcher <- addUnlockedMatcher annexdotfiles <- getGitConfigVal annexDotFiles - let gofile file = case largeFilesOverride o of + let gofile (si, file) = case largeFilesOverride o of Nothing -> let file' = fromRawFilePath file in ifM (pure (annexdotfiles || not (dotfile file')) <&&> (checkFileMatcher largematcher file' <||> Annex.getState Annex.force)) - ( start file addunlockedmatcher + ( start o si file addunlockedmatcher , ifM (annexAddSmallFiles <$> Annex.getGitConfig) - ( startSmall file + ( startSmall o si file , stop ) ) - Just True -> start file addunlockedmatcher - Just False -> startSmallOverridden file + Just True -> start o si file addunlockedmatcher + Just False -> startSmallOverridden o si file case batchOption o of Batch fmt | updateOnly o -> @@ -90,31 +98,33 @@ l <- workTreeItems ww (addThese o) let go a = a ww (commandAction . gofile) l unless (updateOnly o) $ - go (const withFilesNotInGit) + go (withFilesNotInGit (checkGitIgnoreOption o)) go withFilesMaybeModified go withUnmodifiedUnlockedPointers {- Pass file off to git-add. -} -startSmall :: RawFilePath -> CommandStart -startSmall file = starting "add" (ActionItemWorkTreeFile file) $ - next $ addSmall file +startSmall :: AddOptions -> SeekInput -> RawFilePath -> CommandStart +startSmall o si file = + starting "add" (ActionItemWorkTreeFile file) si $ + next $ addSmall (checkGitIgnoreOption o) file -addSmall :: RawFilePath -> Annex Bool -addSmall file = do +addSmall :: CheckGitIgnore -> RawFilePath -> Annex Bool +addSmall ci file = do showNote "non-large file; adding content to git repository" - addFile file + addFile ci file -startSmallOverridden :: RawFilePath -> CommandStart -startSmallOverridden file = starting "add" (ActionItemWorkTreeFile file) $ - next $ addSmallOverridden file +startSmallOverridden :: AddOptions -> SeekInput -> RawFilePath -> CommandStart +startSmallOverridden o si file = + starting "add" (ActionItemWorkTreeFile file) si $ + next $ addSmallOverridden o file -addSmallOverridden :: RawFilePath -> Annex Bool -addSmallOverridden file = do +addSmallOverridden :: AddOptions -> RawFilePath -> Annex Bool +addSmallOverridden o file = do showNote "adding content to git repository" let file' = fromRawFilePath file s <- liftIO $ getSymbolicLinkStatus file' if not (isRegularFile s) - then addFile file + then addFile (checkGitIgnoreOption o) file else do -- Can't use addFile because the clean filter will -- honor annex.largefiles and it has been overridden. @@ -127,14 +137,14 @@ inRepo (Git.UpdateIndex.stageFile sha ty file') return True -addFile :: RawFilePath -> Annex Bool -addFile file = do - ps <- forceParams +addFile :: CheckGitIgnore -> RawFilePath -> Annex Bool +addFile ci file = do + ps <- gitAddParams ci Annex.Queue.addCommand "add" (ps++[Param "--"]) [fromRawFilePath file] return True -start :: RawFilePath -> AddUnlockedMatcher -> CommandStart -start file addunlockedmatcher = do +start :: AddOptions -> SeekInput -> RawFilePath -> AddUnlockedMatcher -> CommandStart +start o si file addunlockedmatcher = do mk <- liftIO $ isPointerFile file maybe go fixuppointer mk where @@ -144,29 +154,29 @@ Just s | not (isRegularFile s) && not (isSymbolicLink s) -> stop | otherwise -> - starting "add" (ActionItemWorkTreeFile file) $ + starting "add" (ActionItemWorkTreeFile file) si $ if isSymbolicLink s - then next $ addFile file - else perform file addunlockedmatcher + then next $ addFile (checkGitIgnoreOption o) file + else perform o file addunlockedmatcher addpresent key = liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case Just s | isSymbolicLink s -> fixuplink key _ -> add - fixuplink key = starting "add" (ActionItemWorkTreeFile file) $ do + fixuplink key = starting "add" (ActionItemWorkTreeFile file) si $ do -- the annexed symlink is present but not yet added to git liftIO $ removeFile (fromRawFilePath file) - addLink (fromRawFilePath file) key Nothing + addLink (checkGitIgnoreOption o) (fromRawFilePath file) key Nothing next $ cleanup key =<< inAnnex key - fixuppointer key = starting "add" (ActionItemWorkTreeFile file) $ do + fixuppointer key = starting "add" (ActionItemWorkTreeFile file) si $ do -- the pointer file is present, but not yet added to git Database.Keys.addAssociatedFile key =<< inRepo (toTopFilePath file) - next $ addFile file + next $ addFile (checkGitIgnoreOption o) file -perform :: RawFilePath -> AddUnlockedMatcher -> CommandPerform -perform file addunlockedmatcher = withOtherTmp $ \tmpdir -> do +perform :: AddOptions -> RawFilePath -> AddUnlockedMatcher -> CommandPerform +perform o file addunlockedmatcher = withOtherTmp $ \tmpdir -> do lockingfile <- not <$> addUnlocked addunlockedmatcher - (MatchingFile (FileInfo file file)) + (MatchingFile (FileInfo (Just file) file)) let cfg = LockDownConfig { lockingFile = lockingfile , hardlinkFileTmpDir = Just tmpdir @@ -174,7 +184,7 @@ ld <- lockDown cfg (fromRawFilePath file) let sizer = keySource <$> ld v <- metered Nothing sizer $ \_meter meterupdate -> - ingestAdd meterupdate ld + ingestAdd (checkGitIgnoreOption o) meterupdate ld finish v where finish (Just key) = next $ cleanup key True diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs --- a/Command/AddUnused.hs +++ b/Command/AddUnused.hs @@ -28,7 +28,9 @@ perform :: Key -> CommandPerform perform key = next $ do logStatus key InfoPresent - addLink file key Nothing + -- Ignore the usual git ignores because the user has explictly + -- asked to add these files. + addLink (CheckGitIgnore False) file key Nothing return True where file = "unused." ++ fromRawFilePath (keyFile key) diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -54,6 +54,7 @@ , rawOption :: Bool , fileOption :: Maybe FilePath , preserveFilenameOption :: Bool + , checkGitIgnoreOption :: CheckGitIgnore } optParser :: CmdParamsDesc -> Parser AddUrlOptions @@ -100,16 +101,18 @@ <> help "use filename provided by server as-is" ) else pure False) + <*> Command.Add.checkGitIgnoreSwitch seek :: AddUrlOptions -> CommandSeek seek o = startConcurrency commandStages $ do addunlockedmatcher <- addUnlockedMatcher - let go (o', u) = do + let go (si, (o', u)) = do r <- Remote.claimingUrl u if Remote.uuid r == webUUID || rawOption (downloadOptions o') - then void $ commandAction $ startWeb addunlockedmatcher o' u - else checkUrl addunlockedmatcher r o' u - forM_ (addUrls o) (\u -> go (o, u)) + then void $ commandAction $ + startWeb addunlockedmatcher o' si u + else checkUrl addunlockedmatcher r o' si u + forM_ (addUrls o) (\u -> go (SeekInput [u], (o, u))) case batchOption o of Batch fmt -> batchInput fmt (pure . parseBatchInput o) go NoBatch -> noop @@ -123,8 +126,8 @@ else Right (o { downloadOptions = (downloadOptions o) { fileOption = Just f } }, u) | otherwise = Right (o, s) -checkUrl :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> URLString -> Annex () -checkUrl addunlockedmatcher r o u = do +checkUrl :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> URLString -> Annex () +checkUrl addunlockedmatcher r o si u = do pathmax <- liftIO $ fileNameLengthLimit "." let deffile = fromMaybe (urlString2file u (pathdepthOption o) pathmax) (fileOption (downloadOptions o)) go deffile =<< maybe @@ -133,35 +136,35 @@ (Remote.checkUrl r) where - go _ (Left e) = void $ commandAction $ startingAddUrl u o $ do + go _ (Left e) = void $ commandAction $ startingAddUrl si u o $ do warning (show e) next $ return False go deffile (Right (UrlContents sz mf)) = do f <- maybe (pure deffile) (sanitizeOrPreserveFilePath o) mf let f' = adjustFile o (fromMaybe f (fileOption (downloadOptions o))) - void $ commandAction $ startRemote addunlockedmatcher r o f' u sz + void $ commandAction $ startRemote addunlockedmatcher r o si f' u sz go deffile (Right (UrlMulti l)) = case fileOption (downloadOptions o) of Nothing -> forM_ l $ \(u', sz, f) -> do f' <- sanitizeOrPreserveFilePath o f let f'' = adjustFile o (deffile f') - void $ commandAction $ startRemote addunlockedmatcher r o f'' u' sz + void $ commandAction $ startRemote addunlockedmatcher r o si f'' u' sz Just f -> case l of [] -> noop ((u',sz,_):[]) -> do let f' = adjustFile o f - void $ commandAction $ startRemote addunlockedmatcher r o f' u' sz + void $ commandAction $ startRemote addunlockedmatcher r o si f' u' sz _ -> giveup $ unwords [ "That url contains multiple files according to the" , Remote.name r , " remote; cannot add it to a single file." ] -startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> FilePath -> URLString -> Maybe Integer -> CommandStart -startRemote addunlockedmatcher r o file uri sz = do +startRemote :: AddUnlockedMatcher -> Remote -> AddUrlOptions -> SeekInput -> FilePath -> URLString -> Maybe Integer -> CommandStart +startRemote addunlockedmatcher r o si file uri sz = do pathmax <- liftIO $ fileNameLengthLimit "." let file' = joinPath $ map (truncateFilePath pathmax) $ splitDirectories file - startingAddUrl uri o $ do + startingAddUrl si uri o $ do showNote $ "from " ++ Remote.name r showDestinationFile file' performRemote addunlockedmatcher r o uri file' sz @@ -177,12 +180,12 @@ geturi = next $ isJust <$> downloadRemoteFile addunlockedmatcher r (downloadOptions o) uri file sz downloadRemoteFile :: AddUnlockedMatcher -> Remote -> DownloadOptions -> URLString -> FilePath -> Maybe Integer -> Annex (Maybe Key) -downloadRemoteFile addunlockedmatcher r o uri file sz = checkCanAdd file $ do +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)) ( do - addWorkTree addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing + addWorkTree canadd addunlockedmatcher (Remote.uuid r) loguri file urlkey Nothing return (Just urlkey) , do -- Set temporary url for the urlkey @@ -191,7 +194,7 @@ setTempUrl urlkey loguri let downloader = \dest p -> fst <$> Remote.verifiedAction (Remote.retrieveKeyFile r urlkey af dest p) - ret <- downloadWith addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file + ret <- downloadWith canadd addunlockedmatcher downloader urlkey (Remote.uuid r) loguri file removeTempUrl urlkey return ret ) @@ -199,12 +202,12 @@ loguri = setDownloader uri OtherDownloader af = AssociatedFile (Just (toRawFilePath file)) -startWeb :: AddUnlockedMatcher -> AddUrlOptions -> URLString -> CommandStart -startWeb addunlockedmatcher o urlstring = go $ fromMaybe bad $ parseURI urlstring +startWeb :: AddUnlockedMatcher -> AddUrlOptions -> SeekInput -> URLString -> CommandStart +startWeb addunlockedmatcher o si urlstring = go $ fromMaybe bad $ parseURI urlstring where bad = fromMaybe (giveup $ "bad url " ++ urlstring) $ Url.parseURIRelaxed $ urlstring - go url = startingAddUrl urlstring o $ + go url = startingAddUrl si urlstring o $ if relaxedOption (downloadOptions o) then go' url Url.assumeUrlExists else Url.withUrlOptions (Url.getUrlInfo urlstring) >>= \case @@ -308,10 +311,10 @@ ( tryyoutubedl tmp , normalfinish tmp ) - normalfinish tmp = checkCanAdd file $ do + normalfinish tmp = checkCanAdd o file $ \canadd -> do showDestinationFile file createWorkTreeDirectory (parentDir file) - Just <$> finishDownloadWith addunlockedmatcher tmp webUUID url file + Just <$> finishDownloadWith canadd addunlockedmatcher tmp webUUID url file -- Ask youtube-dl what filename it will download first, -- so it's only used when the file contains embedded media. tryyoutubedl tmp = youtubeDlFileNameHtmlOnly url >>= \case @@ -324,14 +327,15 @@ where dl dest = withTmpWorkDir mediakey $ \workdir -> do let cleanuptmp = pruneTmpWorkDirBefore tmp (liftIO . nukeFile) + showNote "using youtube-dl" Transfer.notifyTransfer Transfer.Download url $ - Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \_p -> - youtubeDl url workdir >>= \case + Transfer.download webUUID mediakey (AssociatedFile Nothing) Transfer.noRetry $ \p -> + youtubeDl url workdir p >>= \case Right (Just mediafile) -> do cleanuptmp - checkCanAdd dest $ do + checkCanAdd o dest $ \canadd -> do showDestinationFile dest - addWorkTree addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile) + addWorkTree canadd addunlockedmatcher webUUID mediaurl dest mediakey (Just mediafile) return $ Just mediakey Right Nothing -> normalfinish tmp Left msg -> do @@ -353,8 +357,8 @@ {- The destination file is not known at start time unless the user provided - a filename. It's not displayed then for output consistency, - but is added to the json when available. -} -startingAddUrl :: URLString -> AddUrlOptions -> CommandPerform -> CommandStart -startingAddUrl url o p = starting "addurl" (ActionItemOther (Just url)) $ do +startingAddUrl :: SeekInput -> URLString -> AddUrlOptions -> CommandPerform -> CommandStart +startingAddUrl si url o p = starting "addurl" (ActionItemOther (Just url)) si $ do case fileOption (downloadOptions o) of Nothing -> noop Just file -> maybeShowJSON $ JSONChunk [("file", file)] @@ -374,13 +378,13 @@ - Downloads the url, sets up the worktree file, and returns the - real key. -} -downloadWith :: AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key) -downloadWith addunlockedmatcher downloader dummykey u url file = +downloadWith :: CanAddFile -> AddUnlockedMatcher -> (FilePath -> MeterUpdate -> Annex Bool) -> Key -> UUID -> URLString -> FilePath -> Annex (Maybe Key) +downloadWith canadd addunlockedmatcher downloader dummykey u url file = go =<< downloadWith' downloader dummykey u url afile where afile = AssociatedFile (Just (toRawFilePath file)) go Nothing = return Nothing - go (Just tmp) = Just <$> finishDownloadWith addunlockedmatcher tmp u url file + go (Just tmp) = Just <$> finishDownloadWith canadd addunlockedmatcher tmp u url file {- Like downloadWith, but leaves the dummy key content in - the returned location. -} @@ -396,8 +400,8 @@ then return (Just tmp) else return Nothing -finishDownloadWith :: AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex Key -finishDownloadWith addunlockedmatcher tmp u url file = do +finishDownloadWith :: CanAddFile -> AddUnlockedMatcher -> FilePath -> UUID -> URLString -> FilePath -> Annex Key +finishDownloadWith canadd addunlockedmatcher tmp u url file = do backend <- chooseBackend file let source = KeySource { keyFilename = toRawFilePath file @@ -405,7 +409,7 @@ , inodeCache = Nothing } key <- fst <$> genKey source nullMeterUpdate backend - addWorkTree addunlockedmatcher u url file key (Just tmp) + addWorkTree canadd addunlockedmatcher u url file key (Just tmp) return key {- Adds the url size to the Key. -} @@ -415,8 +419,8 @@ } {- Adds worktree file to the repository. -} -addWorkTree :: AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex () -addWorkTree addunlockedmatcher u url file key mtmp = case mtmp of +addWorkTree :: CanAddFile -> AddUnlockedMatcher -> UUID -> URLString -> FilePath -> Key -> Maybe FilePath -> Annex () +addWorkTree _ addunlockedmatcher u url file key mtmp = case mtmp of Nothing -> go Just tmp -> do -- Move to final location for large file check. @@ -432,18 +436,22 @@ -- than the work tree file. liftIO $ renameFile file tmp go - else void $ Command.Add.addSmall (toRawFilePath file) + else void $ Command.Add.addSmall noci (toRawFilePath file) where go = do maybeShowJSON $ JSONChunk [("key", serializeKey key)] setUrlPresent key url logChange key u InfoPresent - ifM (addAnnexedFile addunlockedmatcher file key mtmp) + ifM (addAnnexedFile noci addunlockedmatcher file key mtmp) ( do when (isJust mtmp) $ logStatus key InfoPresent , maybe noop (\tmp -> pruneTmpWorkDirBefore tmp (liftIO . nukeFile)) mtmp ) + + -- git does not need to check ignores, because that has already + -- been done, as witnessed by the CannAddFile. + noci = CheckGitIgnore False nodownloadWeb :: AddUnlockedMatcher -> DownloadOptions -> URLString -> Url.UrlInfo -> FilePath -> Annex (Maybe Key) nodownloadWeb addunlockedmatcher o url urlinfo file @@ -457,23 +465,23 @@ where nomedia = do let key = Backend.URL.fromUrl url (Url.urlSize urlinfo) - nodownloadWeb' addunlockedmatcher url key file + nodownloadWeb' o addunlockedmatcher url key file usemedia mediafile = do let dest = youtubeDlDestFile o file mediafile let mediaurl = setDownloader url YoutubeDownloader let mediakey = Backend.URL.fromUrl mediaurl Nothing - nodownloadWeb' addunlockedmatcher mediaurl mediakey dest + nodownloadWeb' o addunlockedmatcher mediaurl mediakey dest youtubeDlDestFile :: DownloadOptions -> FilePath -> FilePath -> FilePath youtubeDlDestFile o destfile mediafile | isJust (fileOption o) = destfile | otherwise = takeFileName mediafile -nodownloadWeb' :: AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key) -nodownloadWeb' addunlockedmatcher url key file = checkCanAdd file $ do +nodownloadWeb' :: DownloadOptions -> AddUnlockedMatcher -> URLString -> Key -> FilePath -> Annex (Maybe Key) +nodownloadWeb' o addunlockedmatcher url key file = checkCanAdd o file $ \canadd -> do showDestinationFile file createWorkTreeDirectory (parentDir file) - addWorkTree addunlockedmatcher webUUID url file key Nothing + addWorkTree canadd addunlockedmatcher webUUID url file key Nothing return (Just key) url2file :: URI -> Maybe Int -> Int -> FilePath @@ -505,15 +513,17 @@ addprefix f = maybe f (++ f) (prefixOption o) addsuffix f = maybe f (f ++) (suffixOption o) -checkCanAdd :: FilePath -> Annex (Maybe a) -> Annex (Maybe a) -checkCanAdd file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file)) +data CanAddFile = CanAddFile + +checkCanAdd :: DownloadOptions -> FilePath -> (CanAddFile -> Annex (Maybe a)) -> Annex (Maybe a) +checkCanAdd o file a = ifM (isJust <$> (liftIO $ catchMaybeIO $ getSymbolicLinkStatus file)) ( do warning $ file ++ " already exists; not overwriting" return Nothing - , ifM ((not <$> Annex.getState Annex.force) <&&> checkIgnored file) + , ifM (checkIgnored (checkGitIgnoreOption o) file) ( do - warning $ "not adding " ++ file ++ " which is .gitignored (use --force to override)" + warning $ "not adding " ++ file ++ " which is .gitignored (use --no-check-gitignore to override)" return Nothing - , a + , a CanAddFile ) ) diff --git a/Command/Adjust.hs b/Command/Adjust.hs --- a/Command/Adjust.hs +++ b/Command/Adjust.hs @@ -51,5 +51,5 @@ start :: Adjustment -> CommandStart start adj = do checkVersionSupported - starting "adjust" (ActionItemOther Nothing) $ + starting "adjust" (ActionItemOther Nothing) (SeekInput []) $ next $ enterAdjustedBranch adj diff --git a/Command/CalcKey.hs b/Command/CalcKey.hs --- a/Command/CalcKey.hs +++ b/Command/CalcKey.hs @@ -19,8 +19,8 @@ (paramRepeating paramFile) (batchable run (pure ())) -run :: () -> String -> Annex Bool -run _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case +run :: () -> SeekInput -> String -> Annex Bool +run _ _ file = tryNonAsync (genKey ks nullMeterUpdate Nothing) >>= \case Right (k, _) -> do liftIO $ putStrLn $ serializeKey k return True diff --git a/Command/CheckPresentKey.hs b/Command/CheckPresentKey.hs --- a/Command/CheckPresentKey.hs +++ b/Command/CheckPresentKey.hs @@ -39,7 +39,8 @@ (rn:[]) -> toRemote rn >>= \r -> return (flip check (Just r)) [] -> return (flip check Nothing) _ -> wrongnumparams - batchInput fmt (pure . Right) $ checker >=> batchResult + batchInput fmt (pure . Right) $ + checker . snd >=> batchResult where wrongnumparams = giveup "Wrong number of parameters" diff --git a/Command/Commit.hs b/Command/Commit.hs --- a/Command/Commit.hs +++ b/Command/Commit.hs @@ -10,6 +10,7 @@ import Command import qualified Annex.Branch import qualified Git +import Git.Types cmd :: Command cmd = command "commit" SectionPlumbing @@ -20,10 +21,12 @@ seek = withNothing (commandAction start) start :: CommandStart -start = starting "commit" (ActionItemOther (Just "git-annex")) $ do - Annex.Branch.commit =<< Annex.Branch.commitMessage - _ <- runhook <=< inRepo $ Git.hookPath "annex-content" - next $ return True +start = starting "commit" ai si $ do + Annex.Branch.commit =<< Annex.Branch.commitMessage + _ <- runhook <=< inRepo $ Git.hookPath "annex-content" + next $ return True where runhook (Just hook) = liftIO $ boolSystem hook [] runhook Nothing = return True + ai = ActionItemOther (Just (fromRef Annex.Branch.name)) + si = SeekInput [] diff --git a/Command/Config.hs b/Command/Config.hs --- a/Command/Config.hs +++ b/Command/Config.hs @@ -55,24 +55,32 @@ seek :: Action -> CommandSeek seek (SetConfig ck@(ConfigKey name) val) = checkIsGlobalConfig ck $ commandAction $ - startingUsualMessages (decodeBS' name) (ActionItemOther (Just (fromConfigValue val))) $ do + startingUsualMessages (decodeBS' name) ai si $ do setGlobalConfig ck val when (needLocalUpdate ck) $ setConfig ck (fromConfigValue val) next $ return True + where + ai = ActionItemOther (Just (fromConfigValue val)) + si = SeekInput [decodeBS' name] seek (UnsetConfig ck@(ConfigKey name)) = checkIsGlobalConfig ck $ commandAction $ - startingUsualMessages (decodeBS' name) (ActionItemOther (Just "unset")) $do + startingUsualMessages (decodeBS' name) ai si $ do unsetGlobalConfig ck when (needLocalUpdate ck) $ unsetConfig ck next $ return True + where + ai = ActionItemOther (Just "unset") + si = SeekInput [decodeBS' name] seek (GetConfig ck) = checkIsGlobalConfig ck $ commandAction $ - startingCustomOutput (ActionItemOther Nothing) $ do + startingCustomOutput ai $ do getGlobalConfig ck >>= \case Just (ConfigValue v) -> liftIO $ S8.putStrLn v Just NoConfigValue -> return () Nothing -> return () next $ return True + where + ai = ActionItemOther Nothing checkIsGlobalConfig :: ConfigKey -> Annex a -> Annex a checkIsGlobalConfig ck@(ConfigKey name) a diff --git a/Command/ContentLocation.hs b/Command/ContentLocation.hs --- a/Command/ContentLocation.hs +++ b/Command/ContentLocation.hs @@ -20,8 +20,8 @@ (paramRepeating paramKey) (batchable run (pure ())) -run :: () -> String -> Annex Bool -run _ p = do +run :: () -> SeekInput -> String -> Annex Bool +run _ _ p = do let k = fromMaybe (giveup "bad key") $ deserializeKey p maybe (return False) (\f -> liftIO (B8.putStrLn f) >> return True) =<< inAnnex' (pure True) Nothing check k diff --git a/Command/Copy.hs b/Command/Copy.hs --- a/Command/Copy.hs +++ b/Command/Copy.hs @@ -67,9 +67,9 @@ {- A copy is just a move that does not delete the source file. - However, auto mode avoids unnecessary copies, and avoids getting or - sending non-preferred content. -} -start :: CopyOptions -> RawFilePath -> Key -> CommandStart -start o file key = stopUnless shouldCopy $ - Command.Move.start (fromToOptions o) Command.Move.RemoveNever file key +start :: CopyOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start o si file key = stopUnless shouldCopy $ + Command.Move.start (fromToOptions o) Command.Move.RemoveNever si file key where shouldCopy | autoMode o = want <||> numCopiesCheck (fromRawFilePath file) key (<) diff --git a/Command/Dead.hs b/Command/Dead.hs --- a/Command/Dead.hs +++ b/Command/Dead.hs @@ -32,11 +32,11 @@ seek (DeadKeys ks) = commandActions $ map startKey ks startKey :: Key -> CommandStart -startKey key = starting "dead" (mkActionItem key) $ +startKey key = starting "dead" (mkActionItem key) (SeekInput []) $ keyLocations key >>= \case [] -> performKey key _ -> giveup "This key is still known to be present in some locations; not marking as dead." - + performKey :: Key -> CommandPerform performKey key = do setDead key diff --git a/Command/Describe.hs b/Command/Describe.hs --- a/Command/Describe.hs +++ b/Command/Describe.hs @@ -23,8 +23,11 @@ start :: [String] -> CommandStart start (name:description) | not (null description) = do u <- Remote.nameToUUID name - starting "describe" (ActionItemOther (Just name)) $ + starting "describe" ai si $ perform u $ unwords description + where + ai = ActionItemOther (Just name) + si = SeekInput [name] start _ = giveup "Specify a repository and a description." perform :: UUID -> String -> CommandPerform diff --git a/Command/Drop.hs b/Command/Drop.hs --- a/Command/Drop.hs +++ b/Command/Drop.hs @@ -76,35 +76,35 @@ where ww = WarnUnmatchLsFiles -start :: DropOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart -start o from file key = start' o from key afile ai +start :: DropOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart +start o from si file key = start' o from key afile ai si where afile = AssociatedFile (Just file) ai = mkActionItem (key, afile) -start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart -start' o from key afile ai = +start' :: DropOptions -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart +start' o from key afile ai si = checkDropAuto (autoMode o) from afile key $ \numcopies -> stopUnless want $ case from of - Nothing -> startLocal afile ai numcopies key [] - Just remote -> startRemote afile ai numcopies key remote + Nothing -> startLocal afile ai si numcopies key [] + Just remote -> startRemote afile ai si numcopies key remote where want | autoMode o = wantDrop False (Remote.uuid <$> from) (Just key) afile | otherwise = return True -startKeys :: DropOptions -> Maybe Remote -> (Key, ActionItem) -> CommandStart -startKeys o from (key, ai) = start' o from key (AssociatedFile Nothing) ai +startKeys :: DropOptions -> Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart +startKeys o from (si, key, ai) = start' o from key (AssociatedFile Nothing) ai si -startLocal :: AssociatedFile -> ActionItem -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart -startLocal afile ai numcopies key preverified = - starting "drop" (OnlyActionOn key ai) $ +startLocal :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> Key -> [VerifiedCopy] -> CommandStart +startLocal afile ai si numcopies key preverified = + starting "drop" (OnlyActionOn key ai) si $ performLocal key afile numcopies preverified -startRemote :: AssociatedFile -> ActionItem -> NumCopies -> Key -> Remote -> CommandStart -startRemote afile ai numcopies key remote = - starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) $ +startRemote :: AssociatedFile -> ActionItem -> SeekInput -> NumCopies -> Key -> Remote -> CommandStart +startRemote afile ai si numcopies key remote = + starting ("drop " ++ Remote.name remote) (OnlyActionOn key ai) si $ performRemote key afile numcopies remote performLocal :: Key -> AssociatedFile -> NumCopies -> [VerifiedCopy] -> CommandPerform diff --git a/Command/DropKey.hs b/Command/DropKey.hs --- a/Command/DropKey.hs +++ b/Command/DropKey.hs @@ -41,8 +41,8 @@ where parsekey = maybe (Left "bad key") Right . deserializeKey -start :: Key -> CommandStart -start key = starting "dropkey" (mkActionItem key) $ +start :: (SeekInput, Key) -> CommandStart +start (si, key) = starting "dropkey" (mkActionItem key) si $ perform key perform :: Key -> CommandPerform diff --git a/Command/EnableRemote.hs b/Command/EnableRemote.hs --- a/Command/EnableRemote.hs +++ b/Command/EnableRemote.hs @@ -58,31 +58,37 @@ -- the remote uuid. startNormalRemote :: Git.RemoteName -> [String] -> Git.Repo -> CommandStart startNormalRemote name restparams r - | null restparams = starting "enableremote" (ActionItemOther (Just name)) $ do + | null restparams = starting "enableremote" ai si $ do setRemoteIgnore r False r' <- Remote.Git.configRead False r u <- getRepoUUID r' next $ return $ u /= NoUUID | otherwise = giveup $ "That is a normal git remote; passing these parameters does not make sense: " ++ unwords restparams + where + ai = ActionItemOther (Just name) + si = SeekInput [name] startSpecialRemote :: Git.RemoteName -> Remote.RemoteConfig -> Maybe (UUID, Remote.RemoteConfig, Maybe (SpecialRemote.ConfigFrom UUID)) -> CommandStart startSpecialRemote name config Nothing = do m <- SpecialRemote.specialRemoteMap - confm <- Logs.Remote.readRemoteLog + confm <- Logs.Remote.remoteConfigMap Remote.nameToUUID' name >>= \case Right u | u `M.member` m -> startSpecialRemote name config $ Just (u, fromMaybe M.empty (M.lookup u confm), Nothing) _ -> unknownNameError "Unknown remote name." startSpecialRemote name config (Just (u, c, mcu)) = - starting "enableremote" (ActionItemOther (Just name)) $ do + starting "enableremote" ai si $ do let fullconfig = config `M.union` c t <- either giveup return (SpecialRemote.findType fullconfig) gc <- maybe (liftIO dummyRemoteGitConfig) (return . Remote.gitconfig) =<< Remote.byUUID u performSpecialRemote t u c fullconfig gc mcu + where + ai = ActionItemOther (Just name) + si = SeekInput [name] performSpecialRemote :: RemoteType -> UUID -> R.RemoteConfig -> R.RemoteConfig -> RemoteGitConfig -> Maybe (SpecialRemote.ConfigFrom UUID) -> CommandPerform performSpecialRemote t u oldc c gc mcu = do diff --git a/Command/EnableTor.hs b/Command/EnableTor.hs --- a/Command/EnableTor.hs +++ b/Command/EnableTor.hs @@ -47,12 +47,14 @@ start _os = do #endif #ifndef mingw32_HOST_OS + let ai = ActionItemOther Nothing + let si = SeekInput [] curruserid <- liftIO getEffectiveUserID if curruserid == 0 then case readish =<< headMaybe os of Nothing -> giveup "Need user-id parameter." Just userid -> go userid - else starting "enable-tor" (ActionItemOther Nothing) $ do + else starting "enable-tor" ai si $ do gitannex <- liftIO programPath let ps = [Param (cmdname cmd), Param (show curruserid)] sucommand <- liftIO $ mkSuCommand gitannex ps diff --git a/Command/ExamineKey.hs b/Command/ExamineKey.hs --- a/Command/ExamineKey.hs +++ b/Command/ExamineKey.hs @@ -19,8 +19,8 @@ (paramRepeating paramKey) (batchable run (optional parseFormatOption)) -run :: Maybe Utility.Format.Format -> String -> Annex Bool -run format p = do +run :: Maybe Utility.Format.Format -> SeekInput -> String -> Annex Bool +run format _ p = do let k = fromMaybe (giveup "bad key") $ deserializeKey p showFormatted format (serializeKey' k) (keyVars k) return True diff --git a/Command/Expire.hs b/Command/Expire.hs --- a/Command/Expire.hs +++ b/Command/Expire.hs @@ -60,13 +60,13 @@ start (Expire expire) noact actlog descs u = case lastact of Just ent | notexpired ent -> checktrust (== DeadTrusted) $ - starting "unexpire" (ActionItemOther (Just desc)) $ do + starting "unexpire" ai si $ do showNote =<< whenactive unless noact $ trustSet u SemiTrusted next $ return True _ -> checktrust (/= DeadTrusted) $ - starting "expire" (ActionItemOther (Just desc)) $ do + starting "expire" ai si $ do showNote =<< whenactive unless noact $ trustSet u DeadTrusted @@ -79,6 +79,8 @@ return $ "last active: " ++ fromDuration d ++ " ago" _ -> return "no activity" desc = fromUUID u ++ " " ++ fromUUIDDesc (fromMaybe mempty (M.lookup u descs)) + ai = ActionItemOther (Just desc) + si = SeekInput [] notexpired ent = case ent of Unknown -> False VectorClock c -> case lookupexpire of diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -258,7 +258,7 @@ startExport r db cvar allfilledvar ti = do ek <- exportKey (Git.LsTree.sha ti) stopUnless (notrecordedpresent ek) $ - starting ("export " ++ name r) (ActionItemOther (Just (fromRawFilePath f))) $ + starting ("export " ++ name r) ai si $ ifM (either (const False) id <$> tryNonAsync (checkPresentExport (exportActions r) (asKey ek) loc)) ( next $ cleanupExport r db ek loc False , do @@ -269,6 +269,8 @@ loc = mkExportLocation f f = getTopFilePath (Git.LsTree.file ti) af = AssociatedFile (Just f) + ai = ActionItemOther (Just (fromRawFilePath f)) + si = SeekInput [] notrecordedpresent ek = (||) <$> liftIO (notElem loc <$> getExportedLocation db (asKey ek)) -- If content was removed from the remote, the export db @@ -321,18 +323,23 @@ eks <- forM (filter (`notElem` nullShas) shas) exportKey if null eks then stop - else starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $ + else starting ("unexport " ++ name r) ai si $ performUnexport r db eks loc where loc = mkExportLocation f' f' = getTopFilePath f + ai = ActionItemOther (Just (fromRawFilePath f')) + si = SeekInput [] startUnexport' :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart -startUnexport' r db f ek = starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath f'))) $ - performUnexport r db [ek] loc +startUnexport' r db f ek = + starting ("unexport " ++ name r) ai si $ + performUnexport r db [ek] loc where loc = mkExportLocation f' f' = getTopFilePath f + ai = ActionItemOther (Just (fromRawFilePath f')) + si = SeekInput [] -- Unlike a usual drop from a repository, this does not check that -- numcopies is satisfied before removing the content. Typically an export @@ -373,30 +380,36 @@ | otherwise = do ek <- exportKey sha let loc = exportTempName ek - starting ("unexport " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation loc)))) $ do + let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation loc))) + let si = SeekInput [] + starting ("unexport " ++ name r) ai si $ do liftIO $ removeExportedLocation db (asKey ek) oldloc performUnexport r db [ek] loc where oldloc = mkExportLocation $ getTopFilePath oldf startMoveToTempName :: Remote -> ExportHandle -> TopFilePath -> ExportKey -> CommandStart -startMoveToTempName r db f ek = starting ("rename " ++ name r) - (ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc)) - (performRename r db ek loc tmploc) +startMoveToTempName r db f ek = + starting ("rename " ++ name r) ai si $ + performRename r db ek loc tmploc where loc = mkExportLocation f' f' = getTopFilePath f tmploc = exportTempName ek + ai = ActionItemOther $ Just $ fromRawFilePath f' ++ " -> " ++ fromRawFilePath (fromExportLocation tmploc) + si = SeekInput [] startMoveFromTempName :: Remote -> ExportHandle -> ExportKey -> TopFilePath -> CommandStart startMoveFromTempName r db ek f = do let tmploc = exportTempName ek + let ai = ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f')) stopUnless (liftIO $ elem tmploc <$> getExportedLocation db (asKey ek)) $ - starting ("rename " ++ name r) (ActionItemOther (Just (fromRawFilePath (fromExportLocation tmploc) ++ " -> " ++ fromRawFilePath f'))) $ + starting ("rename " ++ name r) ai si $ performRename r db ek tmploc loc where loc = mkExportLocation f' f' = getTopFilePath f + si = SeekInput [] performRename :: Remote -> ExportHandle -> ExportKey -> ExportLocation -> ExportLocation -> CommandPerform performRename r db ek src dest = diff --git a/Command/Find.hs b/Command/Find.hs --- a/Command/Find.hs +++ b/Command/Find.hs @@ -73,14 +73,14 @@ where ww = WarnUnmatchLsFiles -start :: FindOptions -> RawFilePath -> Key -> CommandStart -start o file key = startingCustomOutput key $ do +start :: FindOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start o _ file key = startingCustomOutput key $ do showFormatted (formatOption o) file $ ("file", fromRawFilePath file) : keyVars key next $ return True -startKeys :: FindOptions -> (Key, ActionItem) -> CommandStart -startKeys o (key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = - start o (getTopFilePath topf) key +startKeys :: FindOptions -> (SeekInput, Key, ActionItem) -> CommandStart +startKeys o (si, key, ActionItemBranchFilePath (BranchFilePath _ topf) _) = + start o si (getTopFilePath topf) key startKeys _ _ = stop showFormatted :: Maybe Utility.Format.Format -> S.ByteString -> [(String, String)] -> Annex () diff --git a/Command/Fix.hs b/Command/Fix.hs --- a/Command/Fix.hs +++ b/Command/Fix.hs @@ -43,8 +43,8 @@ data FixWhat = FixSymlinks | FixAll -start :: FixWhat -> RawFilePath -> Key -> CommandStart -start fixwhat file key = do +start :: FixWhat -> SeekInput -> RawFilePath -> Key -> CommandStart +start fixwhat si file key = do currlink <- liftIO $ catchMaybeIO $ R.readSymbolicLink file wantlink <- calcRepo $ gitAnnexLink (fromRawFilePath file) key case currlink of @@ -56,7 +56,7 @@ FixAll -> fixthin FixSymlinks -> stop where - fixby = starting "fix" (mkActionItem (key, file)) + fixby = starting "fix" (mkActionItem (key, file)) si fixthin = do obj <- calcRepo (gitAnnexLocation key) stopUnless (isUnmodified key file <&&> isUnmodified key obj) $ do diff --git a/Command/Forget.hs b/Command/Forget.hs --- a/Command/Forget.hs +++ b/Command/Forget.hs @@ -12,6 +12,7 @@ import Logs.Transitions import qualified Annex import Annex.VectorClock +import Git.Types cmd :: Command cmd = command "forget" SectionMaintenance @@ -33,13 +34,16 @@ seek = commandAction . start start :: ForgetOptions -> CommandStart -start o = starting "forget" (ActionItemOther (Just "git-annex")) $ do +start o = starting "forget" ai si $ do c <- liftIO currentVectorClock let basets = addTransition c ForgetGitHistory noTransitions let ts = if dropDead o then addTransition c ForgetDeadRemotes basets else basets perform ts =<< Annex.getState Annex.force + where + ai = ActionItemOther (Just (fromRef Branch.name)) + si = SeekInput [] perform :: Transitions -> Bool -> CommandPerform perform ts True = do diff --git a/Command/FromKey.hs b/Command/FromKey.hs --- a/Command/FromKey.hs +++ b/Command/FromKey.hs @@ -45,27 +45,30 @@ withPairs (commandAction . start force) ps seekBatch :: BatchFormat -> CommandSeek -seekBatch fmt = batchInput fmt parse commandAction +seekBatch fmt = batchInput fmt parse (commandAction . go) where parse s = do let (keyname, file) = separate (== ' ') s if not (null keyname) && not (null file) then do file' <- liftIO $ relPathCwdToFile file - return $ Right $ go file' (keyOpt keyname) + return $ Right (file', keyOpt keyname) else return $ Left "Expected pairs of key and filename" - go file key = starting "fromkey" (mkActionItem (key, toRawFilePath file)) $ - perform key file + go (si, (file, key)) = + let ai = mkActionItem (key, toRawFilePath file) + in starting "fromkey" ai si $ + perform key file -start :: Bool -> (String, FilePath) -> CommandStart -start force (keyname, file) = do +start :: Bool -> (SeekInput, (String, FilePath)) -> CommandStart +start force (si, (keyname, file)) = do let key = keyOpt keyname unless force $ do inbackend <- inAnnex key unless inbackend $ giveup $ "key ("++ keyname ++") is not present in backend (use --force to override this sanity check)" - starting "fromkey" (mkActionItem (key, toRawFilePath file)) $ + let ai = mkActionItem (key, toRawFilePath file) + starting "fromkey" ai si $ perform key file -- From user input to a Key. diff --git a/Command/Fsck.hs b/Command/Fsck.hs --- a/Command/Fsck.hs +++ b/Command/Fsck.hs @@ -111,8 +111,8 @@ whenM ((==) DeadTrusted <$> lookupTrust u) $ earlyWarning "Warning: Fscking a repository that is currently marked as dead." -start :: Maybe Remote -> Incremental -> RawFilePath -> Key -> CommandStart -start from inc file key = Backend.getBackend (fromRawFilePath file) key >>= \case +start :: Maybe Remote -> Incremental -> SeekInput -> RawFilePath -> Key -> CommandStart +start from inc si file key = Backend.getBackend (fromRawFilePath file) key >>= \case Nothing -> stop Just backend -> do numcopies <- getFileNumCopies (fromRawFilePath file) @@ -120,7 +120,7 @@ Nothing -> go $ perform key file backend numcopies Just r -> go $ performRemote key afile backend numcopies r where - go = runFsck inc (mkActionItem (key, afile)) key + go = runFsck inc si (mkActionItem (key, afile)) key afile = AssociatedFile (Just file) perform :: Key -> RawFilePath -> Backend -> NumCopies -> Annex Bool @@ -197,11 +197,11 @@ Just a -> isRight <$> tryNonAsync (a key afile tmp) Nothing -> return False -startKey :: Maybe Remote -> Incremental -> (Key, ActionItem) -> NumCopies -> CommandStart -startKey from inc (key, ai) numcopies = +startKey :: Maybe Remote -> Incremental -> (SeekInput, Key, ActionItem) -> NumCopies -> CommandStart +startKey from inc (si, key, ai) numcopies = Backend.maybeLookupBackendVariety (fromKey keyVariety key) >>= \case Nothing -> stop - Just backend -> runFsck inc ai key $ + Just backend -> runFsck inc si ai key $ case from of Nothing -> performKey key backend numcopies Just r -> performRemote key (AssociatedFile Nothing) backend numcopies r @@ -555,9 +555,9 @@ (False, Right ()) -> "dropped from " ++ Remote.name remote (_, Left e) -> "failed to drop from" ++ Remote.name remote ++ ": " ++ show e -runFsck :: Incremental -> ActionItem -> Key -> Annex Bool -> CommandStart -runFsck inc ai key a = stopUnless (needFsck inc key) $ - starting "fsck" (OnlyActionOn key ai) $ do +runFsck :: Incremental -> SeekInput -> ActionItem -> Key -> Annex Bool -> CommandStart +runFsck inc si ai key a = stopUnless (needFsck inc key) $ + starting "fsck" (OnlyActionOn key ai) si $ do ok <- a when ok $ recordFsckTime inc key diff --git a/Command/FuzzTest.hs b/Command/FuzzTest.hs --- a/Command/FuzzTest.hs +++ b/Command/FuzzTest.hs @@ -36,7 +36,7 @@ start = do guardTest logf <- fromRepo gitAnnexFuzzTestLogFile - showStart "fuzztest" (toRawFilePath logf) + showStart "fuzztest" (toRawFilePath logf) (SeekInput []) logh <- liftIO $ openFile logf WriteMode void $ forever $ fuzz logh stop diff --git a/Command/GCryptSetup.hs b/Command/GCryptSetup.hs --- a/Command/GCryptSetup.hs +++ b/Command/GCryptSetup.hs @@ -22,7 +22,7 @@ seek = withStrings (commandAction . start) start :: String -> CommandStart -start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) $ do +start gcryptid = starting "gcryptsetup" (ActionItemOther Nothing) (SeekInput [gcryptid]) $ do u <- getUUID when (u /= NoUUID) $ giveup "gcryptsetup refusing to run; this repository already has a git-annex uuid!" diff --git a/Command/Get.hs b/Command/Get.hs --- a/Command/Get.hs +++ b/Command/Get.hs @@ -54,8 +54,8 @@ where ww = WarnUnmatchLsFiles -start :: GetOptions -> Maybe Remote -> RawFilePath -> Key -> CommandStart -start o from file key = start' expensivecheck from key afile ai +start :: GetOptions -> Maybe Remote -> SeekInput -> RawFilePath -> Key -> CommandStart +start o from si file key = start' expensivecheck from key afile ai si where afile = AssociatedFile (Just file) ai = mkActionItem (key, afile) @@ -64,12 +64,12 @@ <||> wantGet False (Just key) afile | otherwise = return True -startKeys :: Maybe Remote -> (Key, ActionItem) -> CommandStart -startKeys from (key, ai) = checkFailedTransferDirection ai Download $ - start' (return True) from key (AssociatedFile Nothing) ai +startKeys :: Maybe Remote -> (SeekInput, Key, ActionItem) -> CommandStart +startKeys from (si, key, ai) = checkFailedTransferDirection ai Download $ + start' (return True) from key (AssociatedFile Nothing) ai si -start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> CommandStart -start' expensivecheck from key afile ai = +start' :: Annex Bool -> Maybe Remote -> Key -> AssociatedFile -> ActionItem -> SeekInput -> CommandStart +start' expensivecheck from key afile ai si = stopUnless expensivecheck $ case from of Nothing -> go $ perform key afile @@ -77,7 +77,7 @@ stopUnless (Command.Move.fromOk src key) $ go $ Command.Move.fromPerform src Command.Move.RemoveNever key afile where - go = starting "get" (OnlyActionOn key ai) + go = starting "get" (OnlyActionOn key ai) si perform :: Key -> AssociatedFile -> CommandPerform perform key afile = stopUnless (getKey key afile) $ diff --git a/Command/Group.hs b/Command/Group.hs --- a/Command/Group.hs +++ b/Command/Group.hs @@ -22,10 +22,13 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start (name:g:[]) = do +start ps@(name:g:[]) = do u <- Remote.nameToUUID name - startingUsualMessages "group" (ActionItemOther (Just name)) $ + startingUsualMessages "group" ai si $ setGroup u (toGroup g) + where + ai = ActionItemOther (Just name) + si = SeekInput ps start (name:[]) = do u <- Remote.nameToUUID name startingCustomOutput (ActionItemOther Nothing) $ do diff --git a/Command/GroupWanted.hs b/Command/GroupWanted.hs --- a/Command/GroupWanted.hs +++ b/Command/GroupWanted.hs @@ -24,6 +24,9 @@ start :: [String] -> CommandStart start (g:[]) = startingCustomOutput (ActionItemOther Nothing) $ performGet groupPreferredContentMapRaw (toGroup g) -start (g:expr:[]) = startingUsualMessages "groupwanted" (ActionItemOther (Just g)) $ +start ps@(g:expr:[]) = startingUsualMessages "groupwanted" ai si $ performSet groupPreferredContentSet expr (toGroup g) + where + ai = ActionItemOther (Just g) + si = SeekInput ps start _ = giveup "Specify a group." diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -49,12 +49,14 @@ = LocalImportOptions { importFiles :: CmdParams , duplicateMode :: DuplicateMode + , checkGitIgnoreOption :: CheckGitIgnore } | RemoteImportOptions { importFromRemote :: DeferredParse Remote , importToBranch :: Branch , importToSubDir :: Maybe FilePath , importContent :: Bool + , checkGitIgnoreOption :: CheckGitIgnore } optParser :: CmdParamsDesc -> Parser ImportOptions @@ -65,8 +67,9 @@ ( help "do not get contents of imported files" ) dupmode <- fromMaybe Default <$> optional duplicateModeParser + ic <- Command.Add.checkGitIgnoreSwitch return $ case mfromremote of - Nothing -> LocalImportOptions ps dupmode + Nothing -> LocalImportOptions ps dupmode ic Just r -> case ps of [bs] -> let (branch, subdir) = separate (== ':') bs @@ -74,6 +77,7 @@ (Ref (encodeBS' branch)) (if null subdir then Nothing else Just subdir) content + ic _ -> giveup "expected BRANCH[:SUBDIR]" data DuplicateMode = Default | Duplicate | DeDuplicate | CleanDuplicates | SkipDuplicates | ReinjectDuplicates @@ -110,7 +114,7 @@ giveup $ "cannot import files from inside the working tree (use git annex add instead): " ++ unwords inrepops largematcher <- largeFilesMatcher addunlockedmatcher <- addUnlockedMatcher - (commandAction . startLocal addunlockedmatcher largematcher (duplicateMode o)) + (commandAction . startLocal o addunlockedmatcher largematcher (duplicateMode o)) `withPathContents` importFiles o seek o@(RemoteImportOptions {}) = startConcurrency commandStages $ do r <- getParsed (importFromRemote o) @@ -120,16 +124,18 @@ (pure Nothing) (Just <$$> inRepo . toTopFilePath . toRawFilePath) (importToSubDir o) - seekRemote r (importToBranch o) subdir (importContent o) + seekRemote r (importToBranch o) subdir (importContent o) (checkGitIgnoreOption o) -startLocal :: AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart -startLocal addunlockedmatcher largematcher mode (srcfile, destfile) = +startLocal :: ImportOptions -> AddUnlockedMatcher -> GetFileMatcher -> DuplicateMode -> (FilePath, FilePath) -> CommandStart +startLocal o addunlockedmatcher largematcher mode (srcfile, destfile) = ifM (liftIO $ isRegularFile <$> getSymbolicLinkStatus srcfile) - ( starting "import" (ActionItemWorkTreeFile destfile') - pickaction + ( starting "import" ai si pickaction , stop ) where + ai = ActionItemWorkTreeFile destfile' + si = SeekInput [] + destfile' = toRawFilePath destfile deletedup k = do @@ -146,10 +152,10 @@ showNote "reinjecting" Command.Reinject.perform srcfile k importfile ld k = checkdestdir $ do - ignored <- not <$> Annex.getState Annex.force <&&> checkIgnored destfile + ignored <- checkIgnored (checkGitIgnoreOption o) destfile if ignored then do - warning $ "not importing " ++ destfile ++ " which is .gitignored (use --force to override)" + warning $ "not importing " ++ destfile ++ " which is .gitignored (use --no-check-gitignore to override)" stop else do existing <- liftIO (catchMaybeIO $ getSymbolicLinkStatus destfile) @@ -208,18 +214,18 @@ } } ifM (checkFileMatcher largematcher destfile) - ( ingestAdd' nullMeterUpdate (Just ld') (Just k) + ( ingestAdd' (checkGitIgnoreOption o) nullMeterUpdate (Just ld') (Just k) >>= maybe stop (\addedk -> next $ Command.Add.cleanup addedk True) - , next $ Command.Add.addSmall destfile' + , next $ Command.Add.addSmall (checkGitIgnoreOption o) destfile' ) notoverwriting why = do warning $ "not overwriting existing " ++ destfile ++ " " ++ why stop lockdown a = do let mi = MatchingFile $ FileInfo - { currFile = toRawFilePath srcfile + { contentFile = Just (toRawFilePath srcfile) , matchFile = toRawFilePath destfile } lockingfile <- not <$> addUnlocked addunlockedmatcher mi @@ -264,8 +270,8 @@ verifyEnoughCopiesToDrop [] key Nothing need [] preverified tocheck (const yes) no -seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CommandSeek -seekRemote remote branch msubdir importcontent = do +seekRemote :: Remote -> Branch -> Maybe TopFilePath -> Bool -> CheckGitIgnore -> CommandSeek +seekRemote remote branch msubdir importcontent ci = do importtreeconfig <- case msubdir of Nothing -> return ImportTree Just subdir -> @@ -282,7 +288,7 @@ let commitimport = commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importabletvar <- liftIO $ newTVarIO Nothing - void $ includeCommandAction (listContents remote importabletvar) + void $ includeCommandAction (listContents remote importtreeconfig ci importabletvar) liftIO (atomically (readTVar importabletvar)) >>= \case Nothing -> return () Just importable -> importKeys remote importtreeconfig importcontent importable >>= \case @@ -301,25 +307,32 @@ fromtrackingbranch a = inRepo $ a (fromRemoteTrackingBranch tb) -listContents :: Remote -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart -listContents remote tvar = starting "list" (ActionItemOther (Just (Remote.name remote))) $ - listImportableContents remote >>= \case - Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote - Just importable -> do - importable' <- makeImportMatcher remote >>= \case - Right matcher -> filterImportableContents remote matcher importable - Left err -> giveup $ "Cannot import from " ++ Remote.name remote ++ " because of a problem with its configuration: " ++ err - next $ do - liftIO $ atomically $ writeTVar tvar (Just importable') +listContents :: Remote -> ImportTreeConfig -> CheckGitIgnore -> TVar (Maybe (ImportableContents (ContentIdentifier, Remote.ByteSize))) -> CommandStart +listContents remote importtreeconfig ci tvar = starting "list" ai si $ + makeImportMatcher remote >>= \case + Right matcher -> getImportableContents remote importtreeconfig ci matcher >>= \case + Just importable -> next $ do + liftIO $ atomically $ writeTVar tvar (Just importable) return True + Nothing -> giveup $ "Unable to list contents of " ++ Remote.name remote + Left err -> giveup $ unwords + [ "Cannot import from" + , Remote.name remote + , "because of a problem with its configuration:" + , err + ] + where + ai = ActionItemOther (Just (Remote.name remote)) + si = SeekInput [] commitRemote :: Remote -> Branch -> RemoteTrackingBranch -> Maybe Sha -> ImportTreeConfig -> ImportCommitConfig -> ImportableContents (Either Sha Key) -> CommandStart commitRemote remote branch tb trackingcommit importtreeconfig importcommitconfig importable = - starting "update" (ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb)) $ do + starting "update" ai si $ do importcommit <- buildImportCommit remote importtreeconfig importcommitconfig importable next $ updateremotetrackingbranch importcommit - where + ai = ActionItemOther (Just $ fromRef $ fromRemoteTrackingBranch tb) + si = SeekInput [] -- Update the tracking branch. Done even when there -- is nothing new to import, to make sure it exists. updateremotetrackingbranch importcommit = diff --git a/Command/ImportFeed.hs b/Command/ImportFeed.hs --- a/Command/ImportFeed.hs +++ b/Command/ImportFeed.hs @@ -34,7 +34,7 @@ import qualified Utility.Format import Utility.Tmp import Utility.Metered -import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..)) +import Command.AddUrl (addUrlFile, downloadRemoteFile, parseDownloadOptions, DownloadOptions(..), checkCanAdd) import Annex.UUID import Backend.URL (fromUrl) import Annex.Content @@ -78,7 +78,7 @@ getFeed :: AddUnlockedMatcher -> ImportFeedOptions -> Cache -> URLString -> CommandSeek getFeed addunlockedmatcher opts cache url = do - showStart' "importfeed" (Just url) + showStartOther "importfeed" (Just url) (SeekInput []) downloadFeed url >>= \case Nothing -> showEndResult =<< feedProblem url "downloading the feed failed" @@ -124,7 +124,7 @@ getCache opttemplate = ifM (Annex.getState Annex.force) ( ret S.empty S.empty , do - showStart "importfeed" "checking known urls" + showStart "importfeed" "checking known urls" (SeekInput []) (is, us) <- unzip <$> knownItems showEndOk ret (S.fromList us) (S.fromList (concat is)) @@ -198,28 +198,28 @@ -- don't use youtube-dl , rawOption = True } - let go urlinfo = maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f + let go urlinfo = Just . maybeToList <$> addUrlFile addunlockedmatcher dlopts url urlinfo f if relaxedOption (downloadOptions opts) then go Url.assumeUrlExists else Url.withUrlOptions (Url.getUrlInfo url) >>= \case Right urlinfo -> go urlinfo Left err -> do warning err - return [] + return (Just []) else do res <- tryNonAsync $ maybe (error $ "unable to checkUrl of " ++ Remote.name r) (flip id url) (Remote.checkUrl r) case res of - Left _ -> return [] + Left _ -> return (Just []) Right (UrlContents sz _) -> - maybeToList <$> + Just . maybeToList <$> downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url f sz Right (UrlMulti l) -> do kl <- forM l $ \(url', sz, subf) -> downloadRemoteFile addunlockedmatcher r (downloadOptions opts) url' (f sanitizeFilePath subf) sz - return $ if all isJust kl + return $ Just $ if all isJust kl then catMaybes kl else [] @@ -256,20 +256,27 @@ case dest of Nothing -> return True Just f -> do - showStart' "addurl" (Just url) - ks <- getter f - if null ks - then do + showStartOther "addurl" (Just url) (SeekInput []) + getter f >>= \case + Just ks + -- Download problem. + | null ks -> do + showEndFail + checkFeedBroken (feedurl todownload) + | otherwise -> do + forM_ ks $ \key -> + ifM (annexGenMetaData <$> Annex.getGitConfig) + ( addMetaData key $ extractMetaData todownload + , addMetaData key $ minimalMetaData todownload + ) + showEndOk + return True + -- Was not able to add anything, + -- but not because of a download + -- problem. + Nothing -> do showEndFail - checkFeedBroken (feedurl todownload) - else do - forM_ ks $ \key -> - ifM (annexGenMetaData <$> Annex.getGitConfig) - ( addMetaData key $ extractMetaData todownload - , addMetaData key $ minimalMetaData todownload - ) - showEndOk - return True + return False {- Find a unique filename to save the url to. - If the file exists, prefixes it with a number. @@ -300,15 +307,16 @@ | rawOption (downloadOptions opts) = downloadlink | otherwise = do r <- withTmpWorkDir mediakey $ \workdir -> do - dl <- youtubeDl linkurl workdir + dl <- youtubeDl linkurl workdir nullMeterUpdate case dl of Right (Just mediafile) -> do let ext = case takeExtension mediafile of [] -> ".m" s -> s - ok <- rundownload linkurl ext $ \f -> do - addWorkTree addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile) - return [mediakey] + ok <- rundownload linkurl ext $ \f -> + checkCanAdd (downloadOptions opts) f $ \canadd -> do + addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey (Just mediafile) + return (Just [mediakey]) return (Just ok) -- youtude-dl didn't support it, so -- download it as if the link were @@ -325,9 +333,10 @@ addmediafast linkurl mediaurl mediakey = ifM (pure (not (rawOption (downloadOptions opts))) <&&> youtubeDlSupported linkurl) - ( rundownload linkurl ".m" $ \f -> do - addWorkTree addunlockedmatcher webUUID mediaurl f mediakey Nothing - return [mediakey] + ( rundownload linkurl ".m" $ \f -> + checkCanAdd (downloadOptions opts) f $ \canadd -> do + addWorkTree canadd addunlockedmatcher webUUID mediaurl f mediakey Nothing + return (Just [mediakey]) , performDownload addunlockedmatcher opts cache todownload { location = Enclosure linkurl } ) diff --git a/Command/InAnnex.hs b/Command/InAnnex.hs --- a/Command/InAnnex.hs +++ b/Command/InAnnex.hs @@ -20,8 +20,8 @@ seek :: CmdParams -> CommandSeek seek = withKeys (commandAction . start) -start :: Key -> CommandStart -start key = inAnnexSafe key >>= dispatch +start :: (SeekInput, Key) -> CommandStart +start (_, key) = inAnnexSafe key >>= dispatch where dispatch (Just True) = stop dispatch (Just False) = exit 1 diff --git a/Command/Info.hs b/Command/Info.hs --- a/Command/Info.hs +++ b/Command/Info.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2011-2016 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -125,7 +125,7 @@ globalInfo o stop start o ps = do - mapM_ (itemInfo o) ps + mapM_ (\p -> itemInfo o (SeekInput [p], p)) ps stop globalInfo :: InfoOptions -> Annex () @@ -135,34 +135,34 @@ whenM ((==) DeadTrusted <$> lookupTrust u) $ earlyWarning "Warning: This repository is currently marked as dead." stats <- selStats global_fast_stats global_slow_stats - showCustom "info" $ do + showCustom "info" (SeekInput []) $ do evalStateT (mapM_ showStat stats) (emptyStatInfo o) return True -itemInfo :: InfoOptions -> String -> Annex () -itemInfo o p = ifM (isdir p) - ( dirInfo o p +itemInfo :: InfoOptions -> (SeekInput, String) -> Annex () +itemInfo o (si, p) = ifM (isdir p) + ( dirInfo o p si , do disallowMatchingOptions v <- Remote.byName' p case v of - Right r -> remoteInfo o r + Right r -> remoteInfo o r si Left _ -> do v' <- Remote.nameToUUID' p case v' of - Right u -> uuidInfo o u + Right u -> uuidInfo o u si Left _ -> do relp <- liftIO $ relPathCwdToFile p ifAnnexed (toRawFilePath relp) - (fileInfo o relp) - (treeishInfo o p) + (fileInfo o relp si) + (treeishInfo o p si) ) where isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus) -noInfo :: String -> Annex () -noInfo s = do - showStart "info" (encodeBS' s) +noInfo :: String -> SeekInput -> Annex () +noInfo s si = do + showStart "info" (encodeBS' s) si showNote $ "not a directory or an annexed file or a treeish or a remote or a uuid" showEndFail @@ -170,8 +170,8 @@ disallowMatchingOptions = whenM Limit.limited $ giveup "File matching options can only be used when getting info on a directory." -dirInfo :: InfoOptions -> FilePath -> Annex () -dirInfo o dir = showCustom (unwords ["info", dir]) $ do +dirInfo :: InfoOptions -> FilePath -> SeekInput -> Annex () +dirInfo o dir si = showCustom (unwords ["info", dir]) si $ do stats <- selStats (tostats (dir_name:tree_fast_stats True)) (tostats tree_slow_stats) @@ -180,12 +180,12 @@ where tostats = map (\s -> s dir) -treeishInfo :: InfoOptions -> String -> Annex () -treeishInfo o t = do +treeishInfo :: InfoOptions -> String -> SeekInput -> Annex () +treeishInfo o t si = do mi <- getTreeStatInfo o (Git.Ref (encodeBS' t)) case mi of - Nothing -> noInfo t - Just i -> showCustom (unwords ["info", t]) $ do + Nothing -> noInfo t si + Just i -> showCustom (unwords ["info", t]) si $ do stats <- selStats (tostats (tree_name:tree_fast_stats False)) (tostats tree_slow_stats) @@ -194,13 +194,13 @@ where tostats = map (\s -> s t) -fileInfo :: InfoOptions -> FilePath -> Key -> Annex () -fileInfo o file k = showCustom (unwords ["info", file]) $ do +fileInfo :: InfoOptions -> FilePath -> SeekInput -> Key -> Annex () +fileInfo o file si k = showCustom (unwords ["info", file]) si $ do evalStateT (mapM_ showStat (file_stats file k)) (emptyStatInfo o) return True -remoteInfo :: InfoOptions -> Remote -> Annex () -remoteInfo o r = showCustom (unwords ["info", Remote.name r]) $ do +remoteInfo :: InfoOptions -> Remote -> SeekInput -> Annex () +remoteInfo o r si = showCustom (unwords ["info", Remote.name r]) si $ do i <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r let u = Remote.uuid r l <- selStats @@ -209,8 +209,8 @@ evalStateT (mapM_ showStat l) (emptyStatInfo o) return True -uuidInfo :: InfoOptions -> UUID -> Annex () -uuidInfo o u = showCustom (unwords ["info", fromUUID u]) $ do +uuidInfo :: InfoOptions -> UUID -> SeekInput -> Annex () +uuidInfo o u si = showCustom (unwords ["info", fromUUID u]) si $ do l <- selStats (uuid_fast_stats u) (uuid_slow_stats u) evalStateT (mapM_ showStat l) (emptyStatInfo o) return True @@ -532,8 +532,9 @@ let combinedata d uk = finishCheck uk >>= \case Nothing -> return d Just k -> return $ addKey k d - v <- lift $ foldM combinedata emptyKeyInfo - =<< loggedKeysFor' u + (ks, cleanup) <- lift $ loggedKeysFor' u + v <- lift $ foldM combinedata emptyKeyInfo ks + liftIO $ void cleanup put s { repoData = M.insert u v (repoData s) } return v @@ -567,7 +568,7 @@ where initial = (emptyKeyInfo, emptyKeyInfo, emptyNumCopiesStats, M.empty) update matcher fast key file vs@(presentdata, referenceddata, numcopiesstats, repodata) = - ifM (matcher $ MatchingFile $ FileInfo file file) + ifM (matcher $ MatchingFile $ FileInfo (Just file) file) ( do !presentdata' <- ifM (inAnnex key) ( return $ addKey key presentdata diff --git a/Command/Init.hs b/Command/Init.hs --- a/Command/Init.hs +++ b/Command/Init.hs @@ -53,10 +53,14 @@ start :: InitOptions -> CommandStart start os - | autoEnableOnly os = starting "init" (ActionItemOther (Just "autoenable")) $ - performAutoEnableOnly - | otherwise = starting "init" (ActionItemOther (Just $ initDesc os)) $ - perform os + | autoEnableOnly os = + starting "init" (ActionItemOther (Just "autoenable")) si $ + performAutoEnableOnly + | otherwise = + starting "init" (ActionItemOther (Just $ initDesc os)) si $ + perform os + where + si = SeekInput [] perform :: InitOptions -> CommandPerform perform os = do diff --git a/Command/InitRemote.hs b/Command/InitRemote.hs --- a/Command/InitRemote.hs +++ b/Command/InitRemote.hs @@ -62,25 +62,26 @@ start o (name:ws) = ifM (isJust <$> findExisting name) ( giveup $ "There is already a special remote named \"" ++ name ++ "\". (Use enableremote to enable an existing special remote.)" - , do - ifM (isJust <$> Remote.byNameOnly name) - ( giveup $ "There is already a remote named \"" ++ name ++ "\"" - , do - sameasuuid <- maybe - (pure Nothing) - (Just . Sameas <$$> getParsed) - (sameas o) - c <- newConfig name sameasuuid - (Logs.Remote.keyValToConfig Proposed ws) - <$> readRemoteLog - t <- either giveup return (findType c) - if whatElse o - then startingCustomOutput (ActionItemOther Nothing) $ - describeOtherParamsFor c t - else starting "initremote" (ActionItemOther (Just name)) $ - perform t name c o - ) + , ifM (isJust <$> Remote.byNameOnly name) + ( giveup $ "There is already a remote named \"" ++ name ++ "\"" + , do + sameasuuid <- maybe + (pure Nothing) + (Just . Sameas <$$> getParsed) + (sameas o) + c <- newConfig name sameasuuid + (Logs.Remote.keyValToConfig Proposed ws) + <$> remoteConfigMap + t <- either giveup return (findType c) + if whatElse o + then startingCustomOutput (ActionItemOther Nothing) $ + describeOtherParamsFor c t + else starting "initremote" (ActionItemOther (Just name)) si $ + perform t name c o + ) ) + where + si = SeekInput [name] perform :: RemoteType -> String -> R.RemoteConfig -> InitRemoteOptions -> CommandPerform perform t name c o = do diff --git a/Command/Inprogress.hs b/Command/Inprogress.hs --- a/Command/Inprogress.hs +++ b/Command/Inprogress.hs @@ -48,8 +48,8 @@ where ww = WarnUnmatchLsFiles -start :: S.Set Key -> RawFilePath -> Key -> CommandStart -start s _file k +start :: S.Set Key -> SeekInput -> RawFilePath -> Key -> CommandStart +start s _si _file k | S.member k s = start' k | otherwise = stop diff --git a/Command/List.hs b/Command/List.hs --- a/Command/List.hs +++ b/Command/List.hs @@ -77,8 +77,8 @@ printHeader :: [(UUID, RemoteName, TrustLevel)] -> Annex () printHeader l = liftIO $ putStrLn $ lheader $ map (\(_, n, t) -> (n, t)) l -start :: [(UUID, RemoteName, TrustLevel)] -> RawFilePath -> Key -> CommandStart -start l file key = do +start :: [(UUID, RemoteName, TrustLevel)] -> SeekInput -> RawFilePath -> Key -> CommandStart +start l _si file key = do ls <- S.fromList <$> keyLocations key liftIO $ putStrLn $ format (map (\(u, _, t) -> (t, S.member u ls)) l) file stop diff --git a/Command/Lock.hs b/Command/Lock.hs --- a/Command/Lock.hs +++ b/Command/Lock.hs @@ -37,10 +37,10 @@ , usesLocationLog = False } -start :: RawFilePath -> Key -> CommandStart -start file key = ifM (isJust <$> isAnnexLink file) +start :: SeekInput -> RawFilePath -> Key -> CommandStart +start si file key = ifM (isJust <$> isAnnexLink file) ( stop - , starting "lock" (mkActionItem (key, file)) $ + , starting "lock" (mkActionItem (key, file)) si $ go =<< liftIO (isPointerFile file) ) where @@ -60,7 +60,7 @@ perform :: RawFilePath -> Key -> CommandPerform perform file key = do lockdown =<< calcRepo (gitAnnexLocation key) - addLink (fromRawFilePath file) key + addLink (CheckGitIgnore False) (fromRawFilePath file) key =<< withTSDelta (liftIO . genInodeCache file) next $ cleanup file key where diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -100,8 +100,8 @@ where ww = WarnUnmatchLsFiles -start :: LogOptions -> (FilePath -> Outputter) -> RawFilePath -> Key -> CommandStart -start o outputter file key = do +start :: LogOptions -> (FilePath -> Outputter) -> SeekInput -> RawFilePath -> Key -> CommandStart +start o outputter _ file key = do (changes, cleanup) <- getKeyLog key (passthruOptions o) showLogIncremental (outputter (fromRawFilePath file)) changes void $ liftIO cleanup diff --git a/Command/LookupKey.hs b/Command/LookupKey.hs --- a/Command/LookupKey.hs +++ b/Command/LookupKey.hs @@ -18,8 +18,8 @@ (paramRepeating paramFile) (batchable run (pure ())) -run :: () -> String -> Annex Bool -run _ file = seekSingleGitFile file >>= \case +run :: () -> SeekInput -> String -> Annex Bool +run _ _ file = seekSingleGitFile file >>= \case Nothing -> return False Just file' -> catKeyFile file' >>= \case Just k -> do diff --git a/Command/Map.hs b/Command/Map.hs --- a/Command/Map.hs +++ b/Command/Map.hs @@ -197,7 +197,7 @@ {- reads the config of a remote, with progress display -} scan :: Git.Repo -> Annex Git.Repo scan r = do - showStart' "map" (Just $ Git.repoDescribe r) + showStartOther "map" (Just $ Git.repoDescribe r) (SeekInput []) v <- tryScan r case v of Just r' -> do diff --git a/Command/MatchExpression.hs b/Command/MatchExpression.hs --- a/Command/MatchExpression.hs +++ b/Command/MatchExpression.hs @@ -37,9 +37,9 @@ ( long "largefiles" <> help "parse as annex.largefiles expression" ) - <*> (MatchingInfo . addkeysize <$> dataparser) + <*> (MatchingUserInfo . addkeysize <$> dataparser) where - dataparser = ProvidedInfo + dataparser = UserProvidedInfo <$> optinfo "file" (strOption ( long "file" <> metavar paramFile <> help "specify filename to match against" @@ -65,9 +65,9 @@ <|> (pure $ Left $ missingdata datadesc) missingdata datadesc = bail $ "cannot match this expression without " ++ datadesc ++ " data" -- When a key is provided, make its size also be provided. - addkeysize p = case providedKey p of + addkeysize p = case userProvidedKey p of Right k -> case fromKey keySize k of - Just sz -> p { providedFileSize = Right sz } + Just sz -> p { userProvidedFileSize = Right sz } Nothing -> p Left _ -> p @@ -91,7 +91,8 @@ , liftIO exitFailure ) where - checkmatcher matcher = matchMrun matcher $ \a -> a S.empty (matchinfo o) + checkmatcher matcher = matchMrun matcher $ \op -> + matchAction op S.empty (matchinfo o) bail :: String -> IO a bail s = do diff --git a/Command/Merge.hs b/Command/Merge.hs --- a/Command/Merge.hs +++ b/Command/Merge.hs @@ -13,6 +13,7 @@ import qualified Git.Branch import Annex.CurrentBranch import Command.Sync (prepMerge, mergeLocal, mergeConfig, merge, SyncOptions(..)) +import Git.Types cmd :: Command cmd = command "merge" SectionMaintenance @@ -29,17 +30,23 @@ forM_ bs (commandAction . mergeBranch . Git.Ref . encodeBS') mergeAnnexBranch :: CommandStart -mergeAnnexBranch = starting "merge" (ActionItemOther (Just "git-annex")) $ do +mergeAnnexBranch = starting "merge" ai si $ do _ <- Annex.Branch.update -- commit explicitly, in case no remote branches were merged Annex.Branch.commit =<< Annex.Branch.commitMessage next $ return True + where + ai = ActionItemOther (Just (fromRef Annex.Branch.name)) + si = SeekInput [] mergeSyncedBranch :: CommandStart mergeSyncedBranch = mergeLocal mergeConfig def =<< getCurrentBranch mergeBranch :: Git.Ref -> CommandStart -mergeBranch r = starting "merge" (ActionItemOther (Just (Git.fromRef r))) $ do +mergeBranch r = starting "merge" ai si $ do currbranch <- getCurrentBranch let o = def { notOnlyAnnexOption = True } next $ merge currbranch mergeConfig o Git.Branch.ManualCommit r + where + ai = ActionItemOther (Just (Git.fromRef r)) + si = SeekInput [] diff --git a/Command/MetaData.hs b/Command/MetaData.hs --- a/Command/MetaData.hs +++ b/Command/MetaData.hs @@ -93,24 +93,24 @@ Batch fmt -> withMessageState $ \s -> case outputType s of JSONOutput _ -> ifM limited ( giveup "combining --batch with file matching options is not currently supported" - , batchInput fmt parseJSONInput $ - commandAction . startBatch + , batchInput fmt parseJSONInput + (commandAction . startBatch) ) _ -> giveup "--batch is currently only supported in --json mode" -start :: VectorClock -> MetaDataOptions -> RawFilePath -> Key -> CommandStart -start c o file k = startKeys c o (k, mkActionItem (k, afile)) +start :: VectorClock -> MetaDataOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start c o si file k = startKeys c o (si, k, mkActionItem (k, afile)) where afile = AssociatedFile (Just file) -startKeys :: VectorClock -> MetaDataOptions -> (Key, ActionItem) -> CommandStart -startKeys c o (k, ai) = case getSet o of +startKeys :: VectorClock -> MetaDataOptions -> (SeekInput, Key, ActionItem) -> CommandStart +startKeys c o (si, k, ai) = case getSet o of Get f -> startingCustomOutput k $ do l <- S.toList . currentMetaDataValues f <$> getCurrentMetaData k liftIO $ forM_ l $ B8.putStrLn . fromMetaValue next $ return True - _ -> starting "metadata" ai $ + _ -> starting "metadata" ai si $ perform c o k perform :: VectorClock -> MetaDataOptions -> Key -> CommandPerform @@ -170,8 +170,8 @@ (Nothing, Nothing) -> return $ Left "JSON input is missing either file or key" -startBatch :: (Either RawFilePath Key, MetaData) -> CommandStart -startBatch (i, (MetaData m)) = case i of +startBatch :: (SeekInput, (Either RawFilePath Key, MetaData)) -> CommandStart +startBatch (si, (i, (MetaData m))) = case i of Left f -> do mk <- lookupKey f case mk of @@ -179,7 +179,7 @@ Nothing -> giveup $ "not an annexed file: " ++ fromRawFilePath f Right k -> go k (mkActionItem k) where - go k ai = starting "metadata" ai $ do + go k ai = starting "metadata" ai si $ do let o = MetaDataOptions { forFiles = [] , getSet = if MetaData m == emptyMetaData diff --git a/Command/Migrate.hs b/Command/Migrate.hs --- a/Command/Migrate.hs +++ b/Command/Migrate.hs @@ -35,8 +35,8 @@ , usesLocationLog = False } -start :: RawFilePath -> Key -> CommandStart -start file key = do +start :: SeekInput -> RawFilePath -> Key -> CommandStart +start si file key = do forced <- Annex.getState Annex.force v <- Backend.getBackend (fromRawFilePath file) key case v of @@ -46,7 +46,7 @@ newbackend <- maybe defaultBackend return =<< chooseBackend (fromRawFilePath file) if (newbackend /= oldbackend || upgradableKey oldbackend key || forced) && exists - then starting "migrate" (mkActionItem (key, file)) $ + then starting "migrate" (mkActionItem (key, file)) si $ perform file key oldbackend newbackend else stop diff --git a/Command/Mirror.hs b/Command/Mirror.hs --- a/Command/Mirror.hs +++ b/Command/Mirror.hs @@ -57,19 +57,19 @@ , usesLocationLog = True } -start :: MirrorOptions -> RawFilePath -> Key -> CommandStart -start o file k = startKey o afile (k, ai) +start :: MirrorOptions -> SeekInput -> RawFilePath -> Key -> CommandStart +start o si file k = startKey o afile (si, k, ai) where afile = AssociatedFile (Just file) ai = mkActionItem (k, afile) -startKey :: MirrorOptions -> AssociatedFile -> (Key, ActionItem) -> CommandStart -startKey o afile (key, ai) = case fromToOptions o of +startKey :: MirrorOptions -> AssociatedFile -> (SeekInput, Key, ActionItem) -> CommandStart +startKey o afile (si, key, ai) = case fromToOptions o of ToRemote r -> checkFailedTransferDirection ai Upload $ ifM (inAnnex key) - ( Command.Move.toStart Command.Move.RemoveNever afile key ai =<< getParsed r + ( Command.Move.toStart Command.Move.RemoveNever afile key ai si =<< getParsed r , do numcopies <- getnumcopies - Command.Drop.startRemote afile ai numcopies key =<< getParsed r + Command.Drop.startRemote afile ai si numcopies key =<< getParsed r ) FromRemote r -> checkFailedTransferDirection ai Download $ do haskey <- flip Remote.hasKey key =<< getParsed r @@ -77,12 +77,12 @@ Left _ -> stop Right True -> ifM (inAnnex key) ( stop - , Command.Get.start' (return True) Nothing key afile ai + , Command.Get.start' (return True) Nothing key afile ai si ) Right False -> ifM (inAnnex key) ( do numcopies <- getnumcopies - Command.Drop.startLocal afile ai numcopies key [] + Command.Drop.startLocal afile ai si numcopies key [] , stop ) where diff --git a/Command/Move.hs b/Command/Move.hs --- a/Command/Move.hs +++ b/Command/Move.hs @@ -76,42 +76,42 @@ Left ToHere -> downloadStages ww = WarnUnmatchLsFiles -start :: FromToHereOptions -> RemoveWhen -> RawFilePath -> Key -> CommandStart -start fromto removewhen f k = start' fromto removewhen afile k ai +start :: FromToHereOptions -> RemoveWhen -> SeekInput -> RawFilePath -> Key -> CommandStart +start fromto removewhen si f k = start' fromto removewhen afile si k ai where afile = AssociatedFile (Just f) ai = mkActionItem (k, afile) -startKey :: FromToHereOptions -> RemoveWhen -> (Key, ActionItem) -> CommandStart -startKey fromto removewhen = - uncurry $ start' fromto removewhen (AssociatedFile Nothing) +startKey :: FromToHereOptions -> RemoveWhen -> (SeekInput, Key, ActionItem) -> CommandStart +startKey fromto removewhen (si, k, ai) = + start' fromto removewhen (AssociatedFile Nothing) si k ai -start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart -start' fromto removewhen afile key ai = +start' :: FromToHereOptions -> RemoveWhen -> AssociatedFile -> SeekInput -> Key -> ActionItem -> CommandStart +start' fromto removewhen afile si key ai = case fromto of Right (FromRemote src) -> checkFailedTransferDirection ai Download $ - fromStart removewhen afile key ai =<< getParsed src + fromStart removewhen afile key ai si =<< getParsed src Right (ToRemote dest) -> checkFailedTransferDirection ai Upload $ - toStart removewhen afile key ai =<< getParsed dest + toStart removewhen afile key ai si =<< getParsed dest Left ToHere -> checkFailedTransferDirection ai Download $ - toHereStart removewhen afile key ai + toHereStart removewhen afile key ai si describeMoveAction :: RemoveWhen -> String describeMoveAction RemoveNever = "copy" describeMoveAction _ = "move" -toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart -toStart removewhen afile key ai dest = do +toStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart +toStart removewhen afile key ai si dest = do u <- getUUID if u == Remote.uuid dest then stop - else toStart' dest removewhen afile key ai + else toStart' dest removewhen afile key ai si -toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart -toStart' dest removewhen afile key ai = do +toStart' :: Remote -> RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart +toStart' dest removewhen afile key ai si = do fast <- Annex.getState Annex.fast if fast && removewhen == RemoveNever then ifM (expectedPresent dest key) @@ -121,7 +121,7 @@ else go False (Remote.hasKey dest key) where go fastcheck isthere = - starting (describeMoveAction removewhen) (OnlyActionOn key ai) $ + starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $ toPerform dest removewhen key afile fastcheck =<< isthere expectedPresent :: Remote -> Key -> Annex Bool @@ -196,10 +196,10 @@ -- to be done except for cleaning up. lockfailed = next $ Command.Drop.cleanupLocal key -fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> Remote -> CommandStart -fromStart removewhen afile key ai src = +fromStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> Remote -> CommandStart +fromStart removewhen afile key ai si src = stopUnless (fromOk src key) $ - starting (describeMoveAction removewhen) (OnlyActionOn key ai) $ + starting (describeMoveAction removewhen) (OnlyActionOn key ai) si $ fromPerform src removewhen key afile fromOk :: Remote -> Key -> Annex Bool @@ -252,13 +252,13 @@ - - When moving, the content is removed from all the reachable remotes that - it can safely be removed from. -} -toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> CommandStart -toHereStart removewhen afile key ai = +toHereStart :: RemoveWhen -> AssociatedFile -> Key -> ActionItem -> SeekInput -> CommandStart +toHereStart removewhen afile key ai si = startingNoMessage (OnlyActionOn key ai) $ do rs <- Remote.keyPossibilities key forM_ rs $ \r -> includeCommandAction $ - starting (describeMoveAction removewhen) ai $ + starting (describeMoveAction removewhen) ai si $ fromPerform r removewhen key afile next $ return True diff --git a/Command/Multicast.hs b/Command/Multicast.hs --- a/Command/Multicast.hs +++ b/Command/Multicast.hs @@ -78,7 +78,7 @@ seek (MultiCastOptions Receive _ _) = giveup "Cannot specify list of files with --receive; this receives whatever files the sender chooses to send." genAddress :: CommandStart -genAddress = starting "gen-address" (ActionItemOther Nothing) $ do +genAddress = starting "gen-address" (ActionItemOther Nothing) (SeekInput []) $ do k <- uftpKey (s, ok) <- case k of KeyContainer s -> liftIO $ genkey (Param s) @@ -127,21 +127,22 @@ -- In a direct mode repository, the annex objects do not have -- the names of keys, and would have to be copied, which is too -- expensive. - starting "sending files" (ActionItemOther Nothing) $ + starting "sending files" (ActionItemOther Nothing) (SeekInput []) $ withTmpFile "send" $ \t h -> do let ww = WarnUnmatchLsFiles - fs' <- seekHelper id ww LsFiles.inRepo + (fs', cleanup) <- seekHelper id ww LsFiles.inRepo =<< workTreeItems ww fs matcher <- Limit.getMatcher - let addlist f o = whenM (matcher $ MatchingFile $ FileInfo f f) $ + let addlist f o = whenM (matcher $ MatchingFile $ FileInfo (Just f) f) $ liftIO $ hPutStrLn h o - forM_ fs' $ \f -> do + forM_ fs' $ \(_, f) -> do mk <- lookupKey f case mk of Nothing -> noop Just k -> withObjectLoc k $ addlist f . fromRawFilePath liftIO $ hClose h + liftIO $ void cleanup serverkey <- uftpKey u <- getUUID @@ -166,7 +167,7 @@ next $ return True receive :: [CommandParam] -> CommandStart -receive ups = starting "receiving multicast files" (ActionItemOther Nothing) $ do +receive ups = starting "receiving multicast files" ai si $ do showNote "Will continue to run until stopped by ctrl-c" showOutput @@ -200,6 +201,9 @@ mapM_ storeReceived . lines =<< liftIO (hGetContents statush) showEndResult =<< liftIO (wait runner) next $ return True + where + ai = ActionItemOther Nothing + si = SeekInput [] storeReceived :: FilePath -> Annex () storeReceived f = do diff --git a/Command/NumCopies.hs b/Command/NumCopies.hs --- a/Command/NumCopies.hs +++ b/Command/NumCopies.hs @@ -46,6 +46,9 @@ return True startSet :: Int -> CommandStart -startSet n = startingUsualMessages "numcopies" (ActionItemOther (Just $ show n)) $ do +startSet n = startingUsualMessages "numcopies" ai si $ do setGlobalNumCopies $ NumCopies n next $ return True + where + ai = ActionItemOther (Just $ show n) + si = SeekInput [show n] diff --git a/Command/P2P.hs b/Command/P2P.hs --- a/Command/P2P.hs +++ b/Command/P2P.hs @@ -98,9 +98,11 @@ -- Address is read from stdin, to avoid leaking it in shell history. linkRemote :: RemoteName -> CommandStart -linkRemote remotename = starting "p2p link" (ActionItemOther (Just remotename)) $ +linkRemote remotename = starting "p2p link" ai si $ next promptaddr where + ai = ActionItemOther (Just remotename) + si = SeekInput [] promptaddr = do liftIO $ putStrLn "" liftIO $ putStr "Enter peer address: " @@ -124,10 +126,13 @@ startPairing :: RemoteName -> [P2PAddress] -> CommandStart startPairing _ [] = giveup "No P2P networks are currrently available." startPairing remotename addrs = ifM (liftIO Wormhole.isInstalled) - ( starting "p2p pair" (ActionItemOther (Just remotename)) $ + ( starting "p2p pair" ai si $ performPairing remotename addrs , giveup "Magic Wormhole is not installed, and is needed for pairing. Install it from your distribution or from https://github.com/warner/magic-wormhole/" - ) + ) + where + ai = ActionItemOther (Just remotename) + si = SeekInput [] performPairing :: RemoteName -> [P2PAddress] -> CommandPerform performPairing remotename addrs = do diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -35,8 +35,8 @@ let ww = WarnUnmatchWorkTreeItems l <- workTreeItems ww ps -- fix symlinks to files being committed - flip withFilesToBeCommitted l $ \f -> commandAction $ - maybe stop (Command.Fix.start Command.Fix.FixSymlinks f) + flip withFilesToBeCommitted l $ \(si, f) -> commandAction $ + maybe stop (Command.Fix.start Command.Fix.FixSymlinks si f) =<< isAnnexLink f -- after a merge conflict or git cherry-pick or stash, pointer -- files in the worktree won't be populated, so populate them here @@ -53,12 +53,18 @@ (removeViewMetaData v) addViewMetaData :: View -> ViewedFile -> Key -> CommandStart -addViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $ +addViewMetaData v f k = starting "metadata" ai si $ next $ changeMetaData k $ fromView v f + where + ai = mkActionItem (k, toRawFilePath f) + si = SeekInput [] removeViewMetaData :: View -> ViewedFile -> Key -> CommandStart -removeViewMetaData v f k = starting "metadata" (mkActionItem (k, toRawFilePath f)) $ +removeViewMetaData v f k = starting "metadata" ai si $ next $ changeMetaData k $ unsetMetaData $ fromView v f + where + ai = mkActionItem (k, toRawFilePath f) + si = SeekInput [] changeMetaData :: Key -> MetaData -> CommandCleanup changeMetaData k metadata = do diff --git a/Command/ReKey.hs b/Command/ReKey.hs --- a/Command/ReKey.hs +++ b/Command/ReKey.hs @@ -52,21 +52,25 @@ seek :: ReKeyOptions -> CommandSeek seek o = case batchOption o of - Batch fmt -> batchInput fmt batchParser $ - batchCommandAction . start - NoBatch -> withPairs (commandAction . start . parsekey) (reKeyThese o) + Batch fmt -> batchInput fmt batchParser + (batchCommandAction . uncurry start) + NoBatch -> withPairs + (\(si, p) -> commandAction (start si (parsekey p))) + (reKeyThese o) where parsekey (file, skey) = (toRawFilePath file, fromMaybe (giveup "bad key") (deserializeKey skey)) -start :: (RawFilePath, Key) -> CommandStart -start (file, newkey) = ifAnnexed file go stop +start :: SeekInput -> (RawFilePath, Key) -> CommandStart +start si (file, newkey) = ifAnnexed file go stop where go oldkey | oldkey == newkey = stop - | otherwise = starting "rekey" (ActionItemWorkTreeFile file) $ + | otherwise = starting "rekey" ai si $ perform file oldkey newkey + ai = ActionItemWorkTreeFile file + perform :: RawFilePath -> Key -> Key -> CommandPerform perform file oldkey newkey = do ifM (inAnnex oldkey) @@ -120,7 +124,7 @@ ( do -- Update symlink to use the new key. liftIO $ removeFile (fromRawFilePath file) - addLink (fromRawFilePath file) newkey Nothing + addLink (CheckGitIgnore False) (fromRawFilePath file) newkey Nothing , do mode <- liftIO $ catchMaybeIO $ fileMode <$> R.getFileStatus file liftIO $ whenM (isJust <$> isPointerFile file) $ diff --git a/Command/RecvKey.hs b/Command/RecvKey.hs --- a/Command/RecvKey.hs +++ b/Command/RecvKey.hs @@ -24,8 +24,8 @@ seek :: CmdParams -> CommandSeek seek = withKeys (commandAction . start) -start :: Key -> CommandStart -start key = fieldTransfer Download key $ \_p -> do +start :: (SeekInput, Key) -> CommandStart +start (_, key) = fieldTransfer Download key $ \_p -> do -- Always verify content when a repo is sending an unlocked file, -- as the file could change while being transferred. fromunlocked <- (isJust <$> Fields.getField Fields.unlocked) diff --git a/Command/RegisterUrl.hs b/Command/RegisterUrl.hs --- a/Command/RegisterUrl.hs +++ b/Command/RegisterUrl.hs @@ -40,14 +40,16 @@ start :: [String] -> CommandStart start (keyname:url:[]) = - starting "registerurl" (ActionItemOther (Just url)) $ do - let key = keyOpt keyname - perform key url + starting "registerurl" ai si $ + perform (keyOpt keyname) url + where + ai = ActionItemOther (Just url) + si = SeekInput [keyname, url] start _ = giveup "specify a key and an url" startMass :: BatchFormat -> CommandStart startMass fmt = - starting "registerurl" (ActionItemOther (Just "stdin")) $ + starting "registerurl" (ActionItemOther (Just "stdin")) (SeekInput []) $ massAdd fmt massAdd :: BatchFormat -> CommandPerform diff --git a/Command/Reinit.hs b/Command/Reinit.hs --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -24,7 +24,7 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start ws = starting "reinit" (ActionItemOther (Just s)) $ +start ws = starting "reinit" (ActionItemOther (Just s)) (SeekInput ws) $ perform s where s = unwords ws diff --git a/Command/Reinject.hs b/Command/Reinject.hs --- a/Command/Reinject.hs +++ b/Command/Reinject.hs @@ -41,20 +41,22 @@ | otherwise = withWords (commandAction . startSrcDest) (params os) startSrcDest :: [FilePath] -> CommandStart -startSrcDest (src:dest:[]) +startSrcDest ps@(src:dest:[]) | src == dest = stop | otherwise = notAnnexed src $ ifAnnexed (toRawFilePath dest) go stop where - go key = starting "reinject" (ActionItemOther (Just src)) $ + go key = starting "reinject" ai si $ ifM (verifyKeyContent RetrievalAllKeysSecure DefaultVerify UnVerified key src) ( perform src key , giveup $ src ++ " does not have expected content of " ++ dest ) + ai = ActionItemOther (Just src) + si = SeekInput ps startSrcDest _ = giveup "specify a src file and a dest file" startKnown :: FilePath -> CommandStart startKnown src = notAnnexed src $ - starting "reinject" (ActionItemOther (Just src)) $ do + starting "reinject" ai si $ do (key, _) <- genKey ks nullMeterUpdate Nothing ifM (isKnownKey key) ( perform src key @@ -65,6 +67,8 @@ where ks = KeySource src' src' Nothing src' = toRawFilePath src + ai = ActionItemOther (Just src) + si = SeekInput [src] notAnnexed :: FilePath -> CommandStart -> CommandStart notAnnexed src a = diff --git a/Command/RenameRemote.hs b/Command/RenameRemote.hs --- a/Command/RenameRemote.hs +++ b/Command/RenameRemote.hs @@ -27,7 +27,7 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start (oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case +start ps@(oldname:newname:[]) = Annex.SpecialRemote.findExisting oldname >>= \case Just (u, cfg, mcu) -> Annex.SpecialRemote.findExisting newname >>= \case Just _ -> giveup $ "The name " ++ newname ++ " is already used by a special remote." Nothing -> go u cfg mcu @@ -37,13 +37,14 @@ Nothing -> Remote.nameToUUID' oldname >>= \case Left e -> giveup e Right u -> do - m <- Logs.Remote.readRemoteLog + m <- Logs.Remote.remoteConfigMap case M.lookup u m of Nothing -> giveup "That is not a special remote." Just cfg -> go u cfg Nothing where - go u cfg mcu = starting "rename" (ActionItemOther Nothing) $ - perform u cfg mcu newname + ai = ActionItemOther Nothing + si = SeekInput ps + go u cfg mcu = starting "rename" ai si $ perform u cfg mcu newname start _ = giveup "Specify an old name (or uuid or description) and a new name." perform :: UUID -> R.RemoteConfig -> Maybe (Annex.SpecialRemote.ConfigFrom UUID) -> String -> CommandPerform diff --git a/Command/Repair.hs b/Command/Repair.hs --- a/Command/Repair.hs +++ b/Command/Repair.hs @@ -25,7 +25,7 @@ seek = withNothing (commandAction start) start :: CommandStart -start = starting "repair" (ActionItemOther Nothing) $ +start = starting "repair" (ActionItemOther Nothing) (SeekInput []) $ next $ runRepair =<< Annex.getState Annex.force runRepair :: Bool -> Annex Bool diff --git a/Command/ResolveMerge.hs b/Command/ResolveMerge.hs --- a/Command/ResolveMerge.hs +++ b/Command/ResolveMerge.hs @@ -24,7 +24,7 @@ seek = withNothing (commandAction start) start :: CommandStart -start = starting "resolvemerge" (ActionItemOther Nothing) $ do +start = starting "resolvemerge" (ActionItemOther Nothing) (SeekInput []) $ do us <- fromMaybe nobranch <$> inRepo Git.Branch.current d <- fromRawFilePath <$> fromRepo Git.localGitDir let merge_head = d "MERGE_HEAD" diff --git a/Command/RmUrl.hs b/Command/RmUrl.hs --- a/Command/RmUrl.hs +++ b/Command/RmUrl.hs @@ -30,8 +30,7 @@ seek :: RmUrlOptions -> CommandSeek seek o = case batchOption o of - Batch fmt -> batchInput fmt batchParser - (batchCommandAction . start) + Batch fmt -> batchInput fmt batchParser (batchCommandAction . start) NoBatch -> withPairs (commandAction . start) (rmThese o) -- Split on the last space, since a FilePath can contain whitespace, @@ -45,9 +44,10 @@ f' <- liftIO $ relPathCwdToFile f return $ Right (f', reverse ru) -start :: (FilePath, URLString) -> CommandStart -start (file, url) = flip whenAnnexed file' $ \_ key -> - starting "rmurl" (mkActionItem (key, AssociatedFile (Just file'))) $ +start :: (SeekInput, (FilePath, URLString)) -> CommandStart +start (si, (file, url)) = flip whenAnnexed file' $ \_ key -> do + let ai = mkActionItem (key, AssociatedFile (Just file')) + starting "rmurl" ai si $ next $ cleanup url key where file' = toRawFilePath file diff --git a/Command/Schedule.hs b/Command/Schedule.hs --- a/Command/Schedule.hs +++ b/Command/Schedule.hs @@ -29,9 +29,11 @@ u <- Remote.nameToUUID name startingCustomOutput (ActionItemOther Nothing) $ performGet u - parse (name:expr:[]) = do + parse ps@(name:expr:[]) = do u <- Remote.nameToUUID name - startingUsualMessages "schedule" (ActionItemOther (Just name)) $ + let ai = ActionItemOther (Just name) + let si = SeekInput ps + startingUsualMessages "schedule" ai si $ performSet expr u parse _ = giveup "Specify a repository." diff --git a/Command/SendKey.hs b/Command/SendKey.hs --- a/Command/SendKey.hs +++ b/Command/SendKey.hs @@ -26,8 +26,8 @@ seek :: CmdParams -> CommandSeek seek = withKeys (commandAction . start) -start :: Key -> CommandStart -start key = do +start :: (SeekInput, Key) -> CommandStart +start (_, key) = do opts <- filterRsyncSafeOptions . maybe [] words <$> getField "RsyncOptions" ifM (inAnnex key) diff --git a/Command/SetKey.hs b/Command/SetKey.hs --- a/Command/SetKey.hs +++ b/Command/SetKey.hs @@ -20,8 +20,11 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start (keyname:file:[]) = starting "setkey" (ActionItemOther (Just file)) $ +start ps@(keyname:file:[]) = starting "setkey" ai si $ perform file (keyOpt keyname) + where + ai = ActionItemOther (Just file) + si = SeekInput ps start _ = giveup "specify a key and a content file" keyOpt :: String -> Key diff --git a/Command/SetPresentKey.hs b/Command/SetPresentKey.hs --- a/Command/SetPresentKey.hs +++ b/Command/SetPresentKey.hs @@ -32,8 +32,8 @@ seek o = case batchOption o of Batch fmt -> batchInput fmt (pure . parseKeyStatus . words) - (batchCommandAction . start) - NoBatch -> either giveup (commandAction . start) + (batchCommandAction . uncurry start) + NoBatch -> either giveup (commandAction . start (SeekInput (params o))) (parseKeyStatus $ params o) data KeyStatus = KeyStatus Key UUID LogStatus @@ -46,9 +46,10 @@ return $ KeyStatus k u s parseKeyStatus _ = Left "Bad input. Expected: key uuid value" -start :: KeyStatus -> CommandStart -start (KeyStatus k u s) = starting "setpresentkey" (mkActionItem k) $ - perform k u s +start :: SeekInput -> KeyStatus -> CommandStart +start si (KeyStatus k u s) = starting "setpresentkey" ai si $ perform k u s + where + ai = mkActionItem k perform :: Key -> UUID -> LogStatus -> CommandPerform perform k u s = next $ do diff --git a/Command/Sync.hs b/Command/Sync.hs --- a/Command/Sync.hs +++ b/Command/Sync.hs @@ -57,6 +57,7 @@ import Annex.UUID import Logs.UUID import Logs.Export +import Logs.PreferredContent import Annex.AutoMerge import Annex.AdjustedBranch import Annex.Ssh @@ -65,6 +66,9 @@ import Annex.Export import Annex.TaggedPush import Annex.CurrentBranch +import Annex.Import (canImportKeys) +import Annex.CheckIgnore +import Types.FileMatcher import qualified Database.Export as Export import Utility.Bloom import Utility.OptParse @@ -223,10 +227,13 @@ , map (withbranch . pullRemote o mergeConfig) gitremotes , [ mergeAnnex ] ] - - whenM (shouldSyncContent o) $ do - mapM_ (withbranch . importRemote o mergeConfig) importremotes + content <- shouldSyncContent o + + forM_ importremotes $ + withbranch . importRemote content o mergeConfig + + when content $ do -- Send content to any exports before other -- repositories, in case that lets content -- be dropped from other repositories. @@ -308,7 +315,7 @@ fastest = fromMaybe [] . headMaybe . Remote.byCost commit :: SyncOptions -> CommandStart -commit o = stopUnless shouldcommit $ starting "commit" (ActionItemOther Nothing) $ do +commit o = stopUnless shouldcommit $ starting "commit" ai si $ do commitmessage <- maybe commitMsg return (messageOption o) Annex.Branch.commit =<< Annex.Branch.commitMessage next $ do @@ -324,6 +331,8 @@ ( pure (commitOption o) <||> (pure (not (noCommitOption o)) <&&> getGitConfigVal annexAutoCommit) ) + ai = ActionItemOther Nothing + si = SeekInput [] commitMsg :: Annex String commitMsg = do @@ -350,14 +359,18 @@ mergeLocal' mergeconfig o currbranch@(Just branch, _) = needMerge currbranch branch >>= \case Nothing -> stop - Just syncbranch -> - starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $ + Just syncbranch -> do + let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch) + let si = SeekInput [] + starting "merge" ai si $ next $ merge currbranch mergeconfig o Git.Branch.ManualCommit syncbranch mergeLocal' _ _ currbranch@(Nothing, _) = inRepo Git.Branch.currentUnsafe >>= \case Just branch -> needMerge currbranch branch >>= \case Nothing -> stop - Just syncbranch -> - starting "merge" (ActionItemOther (Just $ Git.Ref.describe syncbranch)) $ do + Just syncbranch -> do + let ai = ActionItemOther (Just $ Git.Ref.describe syncbranch) + let si = SeekInput [] + starting "merge" ai si $ do warning $ "There are no commits yet to branch " ++ Git.fromRef branch ++ ", so cannot merge " ++ Git.fromRef syncbranch ++ " into it." next $ return False Nothing -> stop @@ -421,7 +434,7 @@ pullRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandStart pullRemote o mergeconfig remote branch = stopUnless (pure $ pullOption o && wantpull) $ - starting "pull" (ActionItemOther (Just (Remote.name remote))) $ do + starting "pull" ai si $ do showOutput ifM (onlyAnnex o) ( do @@ -443,9 +456,11 @@ [Param "fetch", Param $ Remote.name remote] ++ map Param bs wantpull = remoteAnnexPull (Remote.gitconfig remote) + ai = ActionItemOther (Just (Remote.name remote)) + si = SeekInput [] -importRemote :: SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandSeek -importRemote o mergeconfig remote currbranch +importRemote :: Bool -> SyncOptions -> [Git.Merge.MergeConfig] -> Remote -> CurrBranch -> CommandSeek +importRemote importcontent o mergeconfig remote currbranch | not (pullOption o) || not wantpull = noop | otherwise = case remoteAnnexTrackingBranch (Remote.gitconfig remote) of Nothing -> noop @@ -455,8 +470,11 @@ let subdir = if S.null p then Nothing else Just (asTopFilePath p) - Command.Import.seekRemote remote branch subdir True - void $ mergeRemote remote currbranch mergeconfig o + if canImportKeys remote importcontent + then do + Command.Import.seekRemote remote branch subdir importcontent (CheckGitIgnore True) + void $ mergeRemote remote currbranch mergeconfig o + else warning $ "Cannot import from " ++ Remote.name remote ++ " when not syncing content." where wantpull = remoteAnnexPull (Remote.gitconfig remote) @@ -489,7 +507,7 @@ onlyannex <- onlyAnnex o let mainbranch = if onlyannex then Nothing else Just branch stopUnless (pure (pushOption o) <&&> needpush mainbranch) $ - starting "push" (ActionItemOther (Just (Remote.name remote))) $ next $ do + starting "push" ai si $ next $ do repo <- Remote.getRepo remote showOutput ok <- inRepoWithSshOptionsTo repo gc $ @@ -500,6 +518,8 @@ warning $ unwords [ "Pushing to " ++ Remote.name remote ++ " failed." ] return ok where + ai = ActionItemOther (Just (Remote.name remote)) + si = SeekInput [] gc = Remote.gitconfig remote needpush mainbranch | remoteAnnexReadOnly gc = return False @@ -623,9 +643,11 @@ - (Or, when in an ajusted branch where some files are hidden, at files in - the original branch.) - - - With --all, makes a second pass over all keys. - - This ensures that preferred content expressions that match on - - filenames work, even when in --all mode. + - With --all, when preferred content expressions look at filenames, + - makes a first pass over the files in the work tree so those preferred + - content expressions will match. The second pass is over all keys, + - and only preferred content expressions that don't look at filenames + - will match. - - Returns true if any file transfers were made. - @@ -636,7 +658,10 @@ seekSyncContent o rs currbranch = do mvar <- liftIO newEmptyMVar bloom <- case keyOptions o of - Just WantAllKeys -> Just <$> genBloomFilter (seekworktree mvar (WorkTreeItems [])) + Just WantAllKeys -> ifM preferredcontentmatchesfilenames + ( Just <$> genBloomFilter (seekworktree mvar (WorkTreeItems [])) + , pure Nothing + ) _ -> case currbranch of (Just origbranch, Just adj) | adjustmentHidesFiles adj -> do l <- workTreeItems' (AllowHidden True) ww (contentOfOption o) @@ -646,6 +671,7 @@ l <- workTreeItems ww (contentOfOption o) seekworktree mvar l (const noop) pure Nothing + waitForAllRunningCommandActions withKeyOptions' (keyOptions o) False (return (commandAction . gokey mvar bloom)) (const noop) @@ -663,26 +689,30 @@ seekHelper fst3 ww LsFiles.inRepoDetails l seekincludinghidden origbranch mvar l bloomfeeder = - seekFiltered (\f -> ifAnnexed f (commandAction . gofile bloomfeeder mvar f) noop) $ + seekFiltered (const (pure True)) (\(si, f) -> ifAnnexed f (commandAction . gofile bloomfeeder mvar si f) noop) $ seekHelper id ww (LsFiles.inRepoOrBranch origbranch) l ww = WarnUnmatchLsFiles - gofile bloom mvar f k = + gofile bloom mvar _ f k = go (Right bloom) mvar (AssociatedFile (Just f)) k - gokey mvar bloom (k, _) = + gokey mvar bloom (_, k, _) = go (Left bloom) mvar (AssociatedFile Nothing) k go ebloom mvar af k = do - -- Run syncFile as a command action so file transfers run - -- concurrently. let ai = OnlyActionOn k (ActionItemKey k) startingNoMessage ai $ do whenM (syncFile ebloom rs af k) $ void $ liftIO $ tryPutMVar mvar () next $ return True + preferredcontentmatchesfilenames = + preferredcontentmatchesfilenames' Nothing + <||> anyM (preferredcontentmatchesfilenames' . Just . Remote.uuid) rs + preferredcontentmatchesfilenames' = + introspectPreferredRequiredContent matchNeedsFileName + {- If it's preferred content, and we don't have it, get it from one of the - listed remotes (preferring the cheaper earlier ones). - @@ -708,11 +738,13 @@ u <- getUUID let locs' = concat [if inhere || got then [u] else [], putrs, locs] - -- A bloom filter is populated with all the keys in the first pass. - -- On the second pass, avoid dropping keys that were seen in the - -- first pass, which would happen otherwise when preferred content - -- matches on the filename, which is not available in the second - -- pass. + -- To handle --all, a bloom filter is populated with all the keys + -- of files in the working tree in the first pass. On the second + -- pass, avoid dropping keys that were seen in the first pass, which + -- would happen otherwise when preferred content matches on the + -- filename, which is not available in the second pass. + -- (When the preferred content expressions do not match on + -- filenames, the first pass is skipped for speed.) -- -- When there's a false positive in the bloom filter, the result -- is keeping a key that preferred content doesn't really want. @@ -725,7 +757,7 @@ -- includeCommandAction for drops, -- because a failure to drop does not mean -- the sync failed. - handleDropsFrom locs' rs "unwanted" True k af [] + handleDropsFrom locs' rs "unwanted" True k af si [] callCommandAction return (got || not (null putrs)) @@ -739,7 +771,7 @@ ( return [ get have ] , return [] ) - get have = includeCommandAction $ starting "get" ai $ + get have = includeCommandAction $ starting "get" ai si $ stopUnless (getKey' k af have) $ next $ return True @@ -755,9 +787,10 @@ , return [] ) put dest = includeCommandAction $ - Command.Move.toStart' dest Command.Move.RemoveNever af k ai + Command.Move.toStart' dest Command.Move.RemoveNever af k ai si ai = mkActionItem (k, af) + si = SeekInput [] {- When a remote has an annex-tracking-branch configuration, change the export - to contain the current content of the branch. Otherwise, transfer any files @@ -814,22 +847,21 @@ cleanupLocal :: CurrBranch -> CommandStart cleanupLocal (Nothing, _) = stop -cleanupLocal (Just currb, _) = - starting "cleanup" (ActionItemOther (Just "local")) $ - next $ do - delbranch $ syncBranch currb - delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name - mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r) - =<< listTaggedBranches - return True +cleanupLocal (Just currb, _) = starting "cleanup" ai si $ next $ do + delbranch $ syncBranch currb + delbranch $ syncBranch $ Git.Ref.base $ Annex.Branch.name + mapM_ (\(s,r) -> inRepo $ Git.Ref.delete s r) =<< listTaggedBranches + return True where delbranch b = whenM (inRepo $ Git.Ref.exists $ Git.Ref.branchRef b) $ inRepo $ Git.Branch.delete b + ai = ActionItemOther (Just "local") + si = SeekInput [] cleanupRemote :: Remote -> CurrBranch -> CommandStart cleanupRemote _ (Nothing, _) = stop cleanupRemote remote (Just b, _) = - starting "cleanup" (ActionItemOther (Just (Remote.name remote))) $ + starting "cleanup" ai si $ next $ inRepo $ Git.Command.runBool [ Param "push" , Param "--quiet" @@ -839,7 +871,10 @@ , Param $ Git.fromRef $ syncBranch $ Git.Ref.base $ Annex.Branch.name ] - + where + ai = ActionItemOther (Just (Remote.name remote)) + si = SeekInput [] + shouldSyncContent :: SyncOptions -> Annex Bool shouldSyncContent o | noContentOption o = pure False diff --git a/Command/TestRemote.hs b/Command/TestRemote.hs --- a/Command/TestRemote.hs +++ b/Command/TestRemote.hs @@ -73,7 +73,7 @@ seek = commandAction . start start :: TestRemoteOptions -> CommandStart -start o = starting "testremote" (ActionItemOther (Just (testRemote o))) $ do +start o = starting "testremote" (ActionItemOther (Just (testRemote o))) si $ do fast <- Annex.getState Annex.fast cache <- liftIO newRemoteVariantCache r <- either giveup (disableExportTree cache) @@ -98,6 +98,7 @@ perform drs unavailr exportr ks where basesz = fromInteger $ sizeOption o + si = SeekInput [testRemote o] perform :: [Described (Annex (Maybe Remote))] -> Maybe Remote -> Annex (Maybe Remote) -> [Key] -> CommandPerform perform drs unavailr exportr ks = do diff --git a/Command/TransferKey.hs b/Command/TransferKey.hs --- a/Command/TransferKey.hs +++ b/Command/TransferKey.hs @@ -44,8 +44,8 @@ seek :: TransferKeyOptions -> CommandSeek seek o = withKeys (commandAction . start o) (keyOptions o) -start :: TransferKeyOptions -> Key -> CommandStart -start o key = startingCustomOutput key $ case fromToOptions o of +start :: TransferKeyOptions -> (SeekInput, Key) -> CommandStart +start o (_, key) = startingCustomOutput key $ case fromToOptions o of ToRemote dest -> toPerform key (fileOption o) =<< getParsed dest FromRemote src -> fromPerform key (fileOption o) =<< getParsed src diff --git a/Command/Trust.hs b/Command/Trust.hs --- a/Command/Trust.hs +++ b/Command/Trust.hs @@ -28,7 +28,8 @@ start ws = do let name = unwords ws u <- Remote.nameToUUID name - starting c (ActionItemOther (Just name)) (perform u) + let si = SeekInput ws + starting c (ActionItemOther (Just name)) si (perform u) perform uuid = do trustSet uuid level when (level == DeadTrusted) $ diff --git a/Command/Unannex.hs b/Command/Unannex.hs --- a/Command/Unannex.hs +++ b/Command/Unannex.hs @@ -33,9 +33,9 @@ , usesLocationLog = False } -start :: RawFilePath -> Key -> CommandStart -start file key = - starting "unannex" (mkActionItem (key, file)) $ +start :: SeekInput -> RawFilePath -> Key -> CommandStart +start si file key = + starting "unannex" (mkActionItem (key, file)) si $ perform file key perform :: RawFilePath -> Key -> CommandPerform diff --git a/Command/Undo.hs b/Command/Undo.hs --- a/Command/Undo.hs +++ b/Command/Undo.hs @@ -41,8 +41,11 @@ withStrings (commandAction . start) ps start :: FilePath -> CommandStart -start p = starting "undo" (ActionItemOther (Just p)) $ +start p = starting "undo" ai si $ perform p + where + ai = ActionItemOther (Just p) + si = SeekInput [p] perform :: FilePath -> CommandPerform perform p = do diff --git a/Command/Ungroup.hs b/Command/Ungroup.hs --- a/Command/Ungroup.hs +++ b/Command/Ungroup.hs @@ -24,7 +24,7 @@ start :: [String] -> CommandStart start (name:g:[]) = do u <- Remote.nameToUUID name - starting "ungroup" (ActionItemOther (Just name)) $ + starting "ungroup" (ActionItemOther (Just name)) (SeekInput [name, g]) $ perform u (toGroup g) start _ = giveup "Specify a repository and a group." diff --git a/Command/Uninit.hs b/Command/Uninit.hs --- a/Command/Uninit.hs +++ b/Command/Uninit.hs @@ -16,6 +16,7 @@ import qualified Database.Keys import Annex.Content import Annex.Init +import Annex.CheckIgnore import Utility.FileMode import qualified Utility.RawFilePath as R @@ -42,7 +43,11 @@ seek :: CmdParams -> CommandSeek seek ps = do l <- workTreeItems ww ps - withFilesNotInGit (commandAction . whenAnnexed (startCheckIncomplete . fromRawFilePath)) l + withFilesNotInGit + (CheckGitIgnore False) + WarnUnmatchWorkTreeItems + (\(_, f) -> commandAction $ whenAnnexed (startCheckIncomplete . fromRawFilePath) f) + l Annex.changeState $ \s -> s { Annex.fast = True } withFilesInGitAnnex ww Command.Unannex.seeker l finish diff --git a/Command/Unlock.hs b/Command/Unlock.hs --- a/Command/Unlock.hs +++ b/Command/Unlock.hs @@ -36,12 +36,13 @@ , usesLocationLog = False } -start :: RawFilePath -> Key -> CommandStart -start file key = ifM (isJust <$> isAnnexLink file) - ( starting "unlock" (mkActionItem (key, AssociatedFile (Just file))) $ - perform file key +start :: SeekInput -> RawFilePath -> Key -> CommandStart +start si file key = ifM (isJust <$> isAnnexLink file) + ( starting "unlock" ai si $ perform file key , stop ) + where + ai = mkActionItem (key, AssociatedFile (Just file)) perform :: RawFilePath -> Key -> CommandPerform perform dest key = do diff --git a/Command/Unused.hs b/Command/Unused.hs --- a/Command/Unused.hs +++ b/Command/Unused.hs @@ -73,7 +73,7 @@ Just "." -> (".", checkUnused refspec) Just "here" -> (".", checkUnused refspec) Just n -> (n, checkRemoteUnused n refspec) - starting "unused" (ActionItemOther (Just name)) perform + starting "unused" (ActionItemOther (Just name)) (SeekInput []) perform checkUnused :: RefSpec -> CommandPerform checkUnused refspec = chain 0 @@ -337,4 +337,5 @@ Nothing -> search rest Just key -> starting message (ActionItemOther $ Just $ show n) + (SeekInput []) (a key) diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -39,10 +39,10 @@ start :: UpgradeOptions -> CommandStart start (UpgradeOptions { autoOnly = True }) = do - starting "upgrade" (ActionItemOther Nothing) $ do + starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do getVersion >>= maybe noop checkUpgrade next $ return True -start _ = starting "upgrade" (ActionItemOther Nothing) $ do +start _ = starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do whenM (isNothing <$> getVersion) $ do initialize Nothing Nothing r <- upgrade False latestVersion diff --git a/Command/VAdd.hs b/Command/VAdd.hs --- a/Command/VAdd.hs +++ b/Command/VAdd.hs @@ -22,7 +22,7 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start params = starting "vadd" (ActionItemOther Nothing) $ +start params = starting "vadd" (ActionItemOther Nothing) (SeekInput params) $ withCurrentView $ \view -> do let (view', change) = refineView view $ map parseViewParam $ reverse params diff --git a/Command/VCycle.hs b/Command/VCycle.hs --- a/Command/VCycle.hs +++ b/Command/VCycle.hs @@ -26,7 +26,7 @@ start = go =<< currentView where go Nothing = giveup "Not in a view." - go (Just v) = starting "vcycle" (ActionItemOther Nothing) $ do + go (Just v) = starting "vcycle" (ActionItemOther Nothing) (SeekInput [])$ do let v' = v { viewComponents = vcycle [] (viewComponents v) } if v == v' then do diff --git a/Command/VFilter.hs b/Command/VFilter.hs --- a/Command/VFilter.hs +++ b/Command/VFilter.hs @@ -20,7 +20,7 @@ seek = withWords (commandAction . start) start :: [String] -> CommandStart -start params = starting "vfilter" (ActionItemOther Nothing) $ +start params = starting "vfilter" (ActionItemOther Nothing) (SeekInput params) $ withCurrentView $ \view -> do let view' = filterView view $ map parseViewParam $ reverse params diff --git a/Command/VPop.hs b/Command/VPop.hs --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -27,7 +27,7 @@ start ps = go =<< currentView where go Nothing = giveup "Not in a view." - go (Just v) = starting "vpop" (ActionItemOther (Just $ show num)) $ do + go (Just v) = starting "vpop" ai si $ do removeView v (oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v) <$> recentViews @@ -46,3 +46,7 @@ sameparentbranch a b = viewParentBranch a == viewParentBranch b num = fromMaybe 1 $ readish =<< headMaybe ps + + ai = ActionItemOther (Just $ show num) + + si = SeekInput ps diff --git a/Command/View.hs b/Command/View.hs --- a/Command/View.hs +++ b/Command/View.hs @@ -36,7 +36,9 @@ , giveup "Not safe to enter view." ) where - go view Nothing = starting "view" (ActionItemOther Nothing) $ + ai = ActionItemOther Nothing + si = SeekInput ps + go view Nothing = starting "view" ai si $ perform view go view (Just v) | v == view = stop diff --git a/Command/Wanted.hs b/Command/Wanted.hs --- a/Command/Wanted.hs +++ b/Command/Wanted.hs @@ -36,9 +36,11 @@ u <- Remote.nameToUUID rname startingCustomOutput (ActionItemOther Nothing) $ performGet getter u - start (rname:expr:[]) = do + start ps@(rname:expr:[]) = do u <- Remote.nameToUUID rname - startingUsualMessages name (ActionItemOther (Just rname)) $ + let si = SeekInput ps + let ai = ActionItemOther (Just rname) + startingUsualMessages name ai si $ performSet setter expr u start _ = giveup "Specify a repository." diff --git a/Command/Whereis.hs b/Command/Whereis.hs --- a/Command/Whereis.hs +++ b/Command/Whereis.hs @@ -66,16 +66,16 @@ where ww = WarnUnmatchLsFiles -start :: WhereisOptions -> M.Map UUID Remote -> RawFilePath -> Key -> CommandStart -start o remotemap file key = - startKeys o remotemap (key, mkActionItem (key, afile)) +start :: WhereisOptions -> M.Map UUID Remote -> SeekInput -> RawFilePath -> Key -> CommandStart +start o remotemap si file key = + startKeys o remotemap (si, key, mkActionItem (key, afile)) where afile = AssociatedFile (Just file) -startKeys :: WhereisOptions -> M.Map UUID Remote -> (Key, ActionItem) -> CommandStart -startKeys o remotemap (key, ai) +startKeys :: WhereisOptions -> M.Map UUID Remote -> (SeekInput, Key, ActionItem) -> CommandStart +startKeys o remotemap (si, key, ai) | isJust (formatOption o) = startingCustomOutput ai go - | otherwise = starting "whereis" ai go + | otherwise = starting "whereis" ai si go where go = perform o remotemap key ai diff --git a/Config/GitConfig.hs b/Config/GitConfig.hs --- a/Config/GitConfig.hs +++ b/Config/GitConfig.hs @@ -20,13 +20,13 @@ - Note: Be sure to add the config to mergeGitConfig and to - globalConfigs. -} -getGitConfigVal :: (GitConfig -> Configurable a) -> Annex a +getGitConfigVal :: (GitConfig -> GlobalConfigurable a) -> Annex a getGitConfigVal f = getGitConfigVal' f >>= \case HasGlobalConfig c -> return c DefaultConfig d -> return d HasGitConfig c -> return c -getGitConfigVal' :: (GitConfig -> Configurable a) -> Annex (Configurable a) +getGitConfigVal' :: (GitConfig -> GlobalConfigurable a) -> Annex (GlobalConfigurable a) getGitConfigVal' f = (f <$> Annex.getGitConfig) >>= \case DefaultConfig _ -> do r <- Annex.gitRepo diff --git a/Database/Benchmark.hs b/Database/Benchmark.hs --- a/Database/Benchmark.hs +++ b/Database/Benchmark.hs @@ -22,7 +22,6 @@ import Utility.DataUnits import Criterion.Main -import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as B8 import System.Random import Control.Concurrent @@ -92,7 +91,7 @@ } fileN :: Integer -> TopFilePath -fileN n = asTopFilePath ("file" ++ show n) +fileN n = asTopFilePath (toRawFilePath ("file" ++ show n)) keyMiss :: Key keyMiss = keyN 0 -- 0 is never stored diff --git a/Git/Command.hs b/Git/Command.hs --- a/Git/Command.hs +++ b/Git/Command.hs @@ -55,7 +55,7 @@ - - Also returns an action that should be used when the output is all - read, that will wait on the command, and - - return True if it succeeded. Failure to wait will result in zombies. + - return True if it succeeded. -} pipeReadLazy :: [CommandParam] -> Repo -> IO (L.ByteString, IO Bool) pipeReadLazy params repo = assertLocal repo $ do @@ -133,16 +133,6 @@ pipeNullSplitStrict params repo = do s <- pipeReadStrict params repo return $ filter (not . S.null) $ S.split 0 s - -pipeNullSplitZombie :: [CommandParam] -> Repo -> IO [L.ByteString] -pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo - -pipeNullSplitZombie' :: [CommandParam] -> Repo -> IO [S.ByteString] -pipeNullSplitZombie' params repo = leaveZombie <$> pipeNullSplit' params repo - -{- Doesn't run the cleanup action. A zombie results. -} -leaveZombie :: (a, IO Bool) -> a -leaveZombie = fst {- Runs a git command as a coprocess. -} gitCoProcessStart :: Bool -> [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle diff --git a/Limit.hs b/Limit.hs --- a/Limit.hs +++ b/Limit.hs @@ -1,6 +1,6 @@ {- user-specified limits on files to act on - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -51,9 +51,12 @@ {- Gets a matcher for the user-specified limits. The matcher is cached for - speed; once it's obtained the user-specified limits can't change. -} getMatcher :: Annex (MatchInfo -> Annex Bool) -getMatcher = Utility.Matcher.matchM <$> getMatcher' +getMatcher = run <$> getMatcher' + where + run matcher i = Utility.Matcher.matchMrun matcher $ \o -> + matchAction o S.empty i -getMatcher' :: Annex (Utility.Matcher.Matcher (MatchInfo -> Annex Bool)) +getMatcher' :: Annex (Utility.Matcher.Matcher (MatchFiles Annex)) getMatcher' = go =<< Annex.getState Annex.limit where go (CompleteMatcher matcher) = return matcher @@ -63,11 +66,16 @@ s { Annex.limit = CompleteMatcher matcher } return matcher +{- Checks if the user-specified limits contains anything that meets the + - condition. -} +introspect :: (MatchFiles Annex -> Bool) -> Annex Bool +introspect c = Utility.Matcher.introspect c <$> getMatcher' + {- Adds something to the limit list, which is built up reversed. -} -add :: Utility.Matcher.Token (MatchInfo -> Annex Bool) -> Annex () +add :: Utility.Matcher.Token (MatchFiles Annex) -> Annex () add l = Annex.changeState $ \s -> s { Annex.limit = prepend $ Annex.limit s } where - prepend (BuildingMatcher ls) = BuildingMatcher $ l:ls + prepend (BuildingMatcher ls) = BuildingMatcher (l:ls) prepend _ = error "internal" {- Adds a new syntax token. -} @@ -76,41 +84,60 @@ {- Adds a new limit. -} addLimit :: Either String (MatchFiles Annex) -> Annex () -addLimit = either giveup (\l -> add $ Utility.Matcher.Operation $ l S.empty) +addLimit = either giveup (add . Utility.Matcher.Operation) {- Add a limit to skip files that do not match the glob. -} addInclude :: String -> Annex () addInclude = addLimit . limitInclude limitInclude :: MkLimit Annex -limitInclude glob = Right $ const $ matchGlobFile glob +limitInclude glob = Right $ MatchFiles + { matchAction = const $ matchGlobFile glob + , matchNeedsFileName = True + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } {- Add a limit to skip files that match the glob. -} addExclude :: String -> Annex () addExclude = addLimit . limitExclude limitExclude :: MkLimit Annex -limitExclude glob = Right $ const $ not <$$> matchGlobFile glob +limitExclude glob = Right $ MatchFiles + { matchAction = const $ not <$$> matchGlobFile glob + , matchNeedsFileName = True + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } matchGlobFile :: String -> MatchInfo -> Annex Bool matchGlobFile glob = go where cglob = compileGlob glob CaseSensative -- memoized go (MatchingFile fi) = pure $ matchGlob cglob (fromRawFilePath (matchFile fi)) - go (MatchingInfo p) = matchGlob cglob <$> getInfo (providedFilePath p) + go (MatchingInfo p) = pure $ matchGlob cglob (fromRawFilePath (providedFilePath p)) + go (MatchingUserInfo p) = matchGlob cglob <$> getUserInfo (userProvidedFilePath p) go (MatchingKey _ (AssociatedFile Nothing)) = pure False go (MatchingKey _ (AssociatedFile (Just af))) = pure $ matchGlob cglob (fromRawFilePath af) addMimeType :: String -> Annex () -addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType +addMimeType = addMagicLimit "mimetype" getMagicMimeType providedMimeType userProvidedMimeType addMimeEncoding :: String -> Annex () -addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMimeEncoding +addMimeEncoding = addMagicLimit "mimeencoding" getMagicMimeEncoding providedMimeEncoding userProvidedMimeEncoding -addMagicLimit :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> String -> Annex () -addMagicLimit limitname querymagic selectprovidedinfo glob = do +addMagicLimit + :: String + -> (Magic -> FilePath -> Annex (Maybe String)) + -> (ProvidedInfo -> Maybe String) + -> (UserProvidedInfo -> UserInfo String) + -> String + -> Annex () +addMagicLimit limitname querymagic selectprovidedinfo selectuserprovidedinfo glob = do magic <- liftIO initMagicMime - addLimit $ matchMagic limitname querymagic' selectprovidedinfo magic glob + addLimit $ matchMagic limitname querymagic' selectprovidedinfo selectuserprovidedinfo magic glob where querymagic' magic f = liftIO (isPointerFile (toRawFilePath f)) >>= \case -- Avoid getting magic of a pointer file, which would @@ -123,34 +150,66 @@ querymagic magic . fromRawFilePath Nothing -> querymagic magic f -matchMagic :: String -> (Magic -> FilePath -> Annex (Maybe String)) -> (ProvidedInfo -> OptInfo String) -> Maybe Magic -> MkLimit Annex -matchMagic _limitname querymagic selectprovidedinfo (Just magic) glob = Right $ const go +matchMagic + :: String + -> (Magic -> FilePath -> Annex (Maybe String)) + -> (ProvidedInfo -> Maybe String) + -> (UserProvidedInfo -> UserInfo String) + -> Maybe Magic + -> MkLimit Annex +matchMagic _limitname querymagic selectprovidedinfo selectuserprovidedinfo (Just magic) glob = + Right $ MatchFiles + { matchAction = const go + , matchNeedsFileName = True + , matchNeedsFileContent = True + , matchNeedsKey = False + , matchNeedsLocationLog = False + } where cglob = compileGlob glob CaseSensative -- memoized go (MatchingKey _ _) = pure False - go (MatchingFile fi) = catchBoolIO $ - maybe False (matchGlob cglob) - <$> querymagic magic (fromRawFilePath (currFile fi)) - go (MatchingInfo p) = - matchGlob cglob <$> getInfo (selectprovidedinfo p) -matchMagic limitname _ _ Nothing _ = + go (MatchingFile fi) = case contentFile fi of + Just f -> catchBoolIO $ + maybe False (matchGlob cglob) + <$> querymagic magic (fromRawFilePath f) + Nothing -> return False + go (MatchingInfo p) = pure $ + maybe False (matchGlob cglob) (selectprovidedinfo p) + go (MatchingUserInfo p) = + matchGlob cglob <$> getUserInfo (selectuserprovidedinfo p) +matchMagic limitname _ _ _ Nothing _ = Left $ "unable to load magic database; \""++limitname++"\" cannot be used" addUnlocked :: Annex () -addUnlocked = addLimit $ Right $ const $ matchLockStatus False +addUnlocked = addLimit $ Right $ MatchFiles + { matchAction = const $ matchLockStatus False + , matchNeedsFileName = True + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } addLocked :: Annex () -addLocked = addLimit $ Right $ const $ matchLockStatus True +addLocked = addLimit $ Right $ MatchFiles + { matchAction = const $ matchLockStatus True + , matchNeedsFileName = True + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } matchLockStatus :: Bool -> MatchInfo -> Annex Bool matchLockStatus _ (MatchingKey _ _) = pure False matchLockStatus _ (MatchingInfo _) = pure False -matchLockStatus wantlocked (MatchingFile fi) = liftIO $ do - islocked <- isPointerFile (currFile fi) >>= \case - Just _key -> return False - Nothing -> isSymbolicLink - <$> getSymbolicLinkStatus (fromRawFilePath (currFile fi)) - return (islocked == wantlocked) +matchLockStatus _ (MatchingUserInfo _) = pure False +matchLockStatus wantlocked (MatchingFile fi) = case contentFile fi of + Just f -> liftIO $ do + islocked <- isPointerFile f >>= \case + Just _key -> return False + Nothing -> isSymbolicLink + <$> getSymbolicLinkStatus (fromRawFilePath f) + return (islocked == wantlocked) + Nothing -> return False {- Adds a limit to skip files not believed to be present - in a specfied repository. Optionally on a prior date. -} @@ -159,19 +218,25 @@ u <- Remote.nameToUUID name hereu <- getUUID addLimit $ if u == hereu && null date - then use inhere - else use (inuuid u) + then use True checkinhere + else use False (checkinuuid u) where (name, date) = separate (== '@') s - use a = Right $ checkKey . a - inuuid u notpresent key + use inhere a = Right $ MatchFiles + { matchAction = checkKey . a + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = not inhere + } + checkinuuid u notpresent key | null date = do us <- Remote.keyLocations key return $ u `elem` us && u `S.notMember` notpresent | otherwise = do us <- loggedLocationsHistorical (RefDate date) key return $ u `elem` us - inhere notpresent key + checkinhere notpresent key | S.null notpresent = inAnnex key | otherwise = do u <- getUUID @@ -181,22 +246,35 @@ {- Limit to content that is currently present on a uuid. -} limitPresent :: Maybe UUID -> MatchFiles Annex -limitPresent u _ = checkKey $ \key -> do - hereu <- getUUID - if u == Just hereu || isNothing u - then inAnnex key - else do - us <- Remote.keyLocations key - return $ maybe False (`elem` us) u +limitPresent u = MatchFiles + { matchAction = const $ checkKey $ \key -> do + hereu <- getUUID + if u == Just hereu || isNothing u + then inAnnex key + else do + us <- Remote.keyLocations key + return $ maybe False (`elem` us) u + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = not (isNothing u) + } {- Limit to content that is in a directory, anywhere in the repository tree -} limitInDir :: FilePath -> MatchFiles Annex -limitInDir dir = const go +limitInDir dir = MatchFiles + { matchAction = const go + , matchNeedsFileName = True + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } where go (MatchingFile fi) = checkf $ fromRawFilePath $ matchFile fi go (MatchingKey _ (AssociatedFile Nothing)) = return False - go (MatchingKey _ (AssociatedFile (Just af))) = checkf (fromRawFilePath af) - go (MatchingInfo p) = checkf =<< getInfo (providedFilePath p) + go (MatchingKey _ (AssociatedFile (Just af))) = checkf $ fromRawFilePath af + go (MatchingInfo p) = checkf $ fromRawFilePath $ providedFilePath p + go (MatchingUserInfo p) = checkf =<< getUserInfo (userProvidedFilePath p) checkf = return . elem dir . splitPath . takeDirectory {- Adds a limit to skip files not believed to have the specified number @@ -216,8 +294,14 @@ where go num good = case readish num of Nothing -> Left "bad number for copies" - Just n -> Right $ \notpresent -> checkKey $ - go' n good notpresent + Just n -> Right $ MatchFiles + { matchAction = \notpresent -> checkKey $ + go' n good notpresent + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = True + } go' n good notpresent key = do us <- filter (`S.notMember` notpresent) <$> (filterM good =<< Remote.keyLocations key) @@ -234,8 +318,14 @@ limitLackingCopies :: Bool -> MkLimit Annex limitLackingCopies approx want = case readish want of - Just needed -> Right $ \notpresent mi -> flip checkKey mi $ - go mi needed notpresent + Just needed -> Right $ MatchFiles + { matchAction = \notpresent mi -> flip checkKey mi $ + go mi needed notpresent + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = True + } Nothing -> Left "bad value for number of lacking copies" where go mi needed notpresent key = do @@ -246,6 +336,7 @@ fromRawFilePath $ matchFile fi MatchingKey _ _ -> approxNumCopies MatchingInfo {} -> approxNumCopies + MatchingUserInfo {} -> approxNumCopies us <- filter (`S.notMember` notpresent) <$> (trustExclude UnTrusted =<< Remote.keyLocations key) return $ numcopies - length us >= needed @@ -257,19 +348,42 @@ - its key is obviously not unused. -} limitUnused :: MatchFiles Annex -limitUnused _ (MatchingFile _) = return False -limitUnused _ (MatchingKey k _) = S.member k <$> unusedKeys -limitUnused _ (MatchingInfo p) = do - k <- getInfo (providedKey p) - S.member k <$> unusedKeys +limitUnused = MatchFiles + { matchAction = go + , matchNeedsFileName = True + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = False + } + where + go _ (MatchingFile _) = return False + go _ (MatchingKey k _) = isunused k + go _ (MatchingInfo p) = maybe (pure False) isunused (providedKey p) + go _ (MatchingUserInfo p) = do + k <- getUserInfo (userProvidedKey p) + isunused k + + isunused k = S.member k <$> unusedKeys {- Limit that matches any version of any file or key. -} limitAnything :: MatchFiles Annex -limitAnything _ _ = return True +limitAnything = MatchFiles + { matchAction = \_ _ -> return True + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } {- Limit that never matches. -} limitNothing :: MatchFiles Annex -limitNothing _ _ = return False +limitNothing = MatchFiles + { matchAction = \_ _ -> return False + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } {- Adds a limit to skip files not believed to be present in all - repositories in the specified group. -} @@ -277,15 +391,21 @@ addInAllGroup groupname = addLimit $ limitInAllGroup groupMap groupname limitInAllGroup :: Annex GroupMap -> MkLimit Annex -limitInAllGroup getgroupmap groupname = Right $ \notpresent mi -> do - m <- getgroupmap - let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m - if S.null want - then return True - -- optimisation: Check if a wanted uuid is notpresent. - else if not (S.null (S.intersection want notpresent)) - then return False - else checkKey (check want) mi +limitInAllGroup getgroupmap groupname = Right $ MatchFiles + { matchAction = \notpresent mi -> do + m <- getgroupmap + let want = fromMaybe S.empty $ M.lookup (toGroup groupname) $ uuidsByGroup m + if S.null want + then return True + -- optimisation: Check if a wanted uuid is notpresent. + else if not (S.null (S.intersection want notpresent)) + then return False + else checkKey (check want) mi + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = True + } where check want key = do present <- S.fromList <$> Remote.keyLocations key @@ -296,7 +416,13 @@ addInBackend = addLimit . limitInBackend limitInBackend :: MkLimit Annex -limitInBackend name = Right $ const $ checkKey check +limitInBackend name = Right $ MatchFiles + { matchAction = const $ checkKey check + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = False + } where check key = pure $ fromKey keyVariety key == variety variety = parseKeyVariety (encodeBS name) @@ -306,7 +432,13 @@ addSecureHash = addLimit $ Right limitSecureHash limitSecureHash :: MatchFiles Annex -limitSecureHash _ = checkKey isCryptographicallySecure +limitSecureHash = MatchFiles + { matchAction = const $ checkKey isCryptographicallySecure + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = False + } {- Adds a limit to skip files that are too large or too small -} addLargerThan :: String -> Annex () @@ -318,20 +450,33 @@ limitSize :: LimitBy -> (Maybe Integer -> Maybe Integer -> Bool) -> MkLimit Annex limitSize lb vs s = case readSize dataUnits s of Nothing -> Left "bad size" - Just sz -> Right $ go sz + Just sz -> Right $ MatchFiles + { matchAction = go sz + , matchNeedsFileName = case lb of + LimitAnnexFiles -> False + LimitDiskFiles -> True + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } where go sz _ (MatchingFile fi) = case lb of - LimitAnnexFiles -> lookupFileKey fi >>= \case - Just key -> checkkey sz key - Nothing -> return False - LimitDiskFiles -> do - filesize <- liftIO $ catchMaybeIO $ - getFileSize (fromRawFilePath (currFile fi)) - return $ filesize `vs` Just sz + LimitAnnexFiles -> goannexed sz fi + LimitDiskFiles -> case contentFile fi of + Just f -> do + filesize <- liftIO $ catchMaybeIO $ + getFileSize (fromRawFilePath f) + return $ filesize `vs` Just sz + Nothing -> goannexed sz fi go sz _ (MatchingKey key _) = checkkey sz key - go sz _ (MatchingInfo p) = - getInfo (providedFileSize p) + go sz _ (MatchingInfo p) = return $ + Just (providedFileSize p) `vs` Just sz + go sz _ (MatchingUserInfo p) = + getUserInfo (userProvidedFileSize p) >>= \sz' -> return (Just sz' `vs` Just sz) + goannexed sz fi = lookupFileKey fi >>= \case + Just key -> checkkey sz key + Nothing -> return False checkkey sz key = return $ fromKey keySize key `vs` Just sz addMetaData :: String -> Annex () @@ -340,7 +485,13 @@ limitMetaData :: MkLimit Annex limitMetaData s = case parseMetaDataMatcher s of Left e -> Left e - Right (f, matching) -> Right $ const $ checkKey (check f matching) + Right (f, matching) -> Right $ MatchFiles + { matchAction = const $ checkKey (check f matching) + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = True + , matchNeedsLocationLog = False + } where check f matching k = not . S.null . S.filter matching @@ -350,19 +501,31 @@ addTimeLimit duration = do start <- liftIO getPOSIXTime let cutoff = start + durationToPOSIXTime duration - addLimit $ Right $ const $ const $ do - now <- liftIO getPOSIXTime - if now > cutoff - then do - warning $ "Time limit (" ++ fromDuration duration ++ ") reached!" - shutdown True - liftIO $ exitWith $ ExitFailure 101 - else return True + addLimit $ Right $ MatchFiles + { matchAction = const $ const $ do + now <- liftIO getPOSIXTime + if now > cutoff + then do + warning $ "Time limit (" ++ fromDuration duration ++ ") reached!" + shutdown True + liftIO $ exitWith $ ExitFailure 101 + else return True + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } addAccessedWithin :: Duration -> Annex () addAccessedWithin duration = do now <- liftIO getPOSIXTime - addLimit $ Right $ const $ checkKey $ check now + addLimit $ Right $ MatchFiles + { matchAction = const $ checkKey $ check now + , matchNeedsFileName = False + , matchNeedsFileContent = False + , matchNeedsKey = False + , matchNeedsLocationLog = False + } where check now k = inAnnexCheck k $ \f -> liftIO $ catchDefaultIO False $ do @@ -373,10 +536,12 @@ secs = fromIntegral (durationSeconds duration) lookupFileKey :: FileInfo -> Annex (Maybe Key) -lookupFileKey = lookupKey . currFile +lookupFileKey fi = case contentFile fi of + Just f -> lookupKey f + Nothing -> return Nothing checkKey :: (Key -> Annex Bool) -> MatchInfo -> Annex Bool checkKey a (MatchingFile fi) = lookupFileKey fi >>= maybe (return False) a checkKey a (MatchingKey k _) = a k -checkKey a (MatchingInfo p) = a =<< getInfo (providedKey p) - +checkKey a (MatchingInfo p) = maybe (return False) a (providedKey p) +checkKey a (MatchingUserInfo p) = a =<< getUserInfo (userProvidedKey p) diff --git a/Limit/Wanted.hs b/Limit/Wanted.hs --- a/Limit/Wanted.hs +++ b/Limit/Wanted.hs @@ -1,6 +1,6 @@ {- git-annex limits by wanted status - - - Copyright 2012 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -11,16 +11,32 @@ import Annex.Wanted import Limit import Types.FileMatcher +import Logs.PreferredContent addWantGet :: Annex () -addWantGet = addLimit $ Right $ const $ checkWant $ - wantGet False Nothing +addWantGet = addPreferredContentLimit $ + checkWant $ wantGet False Nothing addWantDrop :: Annex () -addWantDrop = addLimit $ Right $ const $ checkWant $ - wantDrop False Nothing Nothing +addWantDrop = addPreferredContentLimit $ + checkWant $ wantDrop False Nothing Nothing +addPreferredContentLimit :: (MatchInfo -> Annex Bool) -> Annex () +addPreferredContentLimit a = do + nfn <- introspectPreferredRequiredContent matchNeedsFileName Nothing + nfc <- introspectPreferredRequiredContent matchNeedsFileContent Nothing + nk <- introspectPreferredRequiredContent matchNeedsKey Nothing + nl <- introspectPreferredRequiredContent matchNeedsLocationLog Nothing + addLimit $ Right $ MatchFiles + { matchAction = const a + , matchNeedsFileName = nfn + , matchNeedsFileContent = nfc + , matchNeedsKey = nk + , matchNeedsLocationLog = nl + } + checkWant :: (AssociatedFile -> Annex Bool) -> MatchInfo -> Annex Bool checkWant a (MatchingFile fi) = a (AssociatedFile (Just $ matchFile fi)) checkWant a (MatchingKey _ af) = a af -checkWant _ (MatchingInfo {}) = return False +checkWant a (MatchingInfo p) = a (AssociatedFile (Just $ providedFilePath p)) +checkWant _ (MatchingUserInfo {}) = return False diff --git a/Logs/Location.hs b/Logs/Location.hs --- a/Logs/Location.hs +++ b/Logs/Location.hs @@ -126,14 +126,15 @@ - - Keys that have been marked as dead are not included. -} -loggedKeys :: Annex [Unchecked Key] +loggedKeys :: Annex ([Unchecked Key], IO Bool) loggedKeys = loggedKeys' (not <$$> checkDead) -loggedKeys' :: (Key -> Annex Bool) -> Annex [Unchecked Key] +loggedKeys' :: (Key -> Annex Bool) -> Annex ([Unchecked Key], IO Bool) loggedKeys' check = do config <- Annex.getGitConfig - mapMaybe (defercheck <$$> locationLogFileKey config) - <$> Annex.Branch.files + (bfs, cleanup) <- Annex.Branch.files + let l = mapMaybe (defercheck <$$> locationLogFileKey config) bfs + return (l, cleanup) where defercheck k = Unchecked $ ifM (check k) ( return (Just k) @@ -146,9 +147,13 @@ - This does not stream well; use loggedKeysFor' for lazy streaming. -} loggedKeysFor :: UUID -> Annex [Key] -loggedKeysFor u = catMaybes <$> (mapM finishCheck =<< loggedKeysFor' u) +loggedKeysFor u = do + (l, cleanup) <- loggedKeysFor' u + l' <- catMaybes <$> mapM finishCheck l + liftIO $ void cleanup + return l' -loggedKeysFor' :: UUID -> Annex [Unchecked Key] +loggedKeysFor' :: UUID -> Annex ([Unchecked Key], IO Bool) loggedKeysFor' u = loggedKeys' isthere where isthere k = do diff --git a/Logs/PreferredContent.hs b/Logs/PreferredContent.hs --- a/Logs/PreferredContent.hs +++ b/Logs/PreferredContent.hs @@ -1,6 +1,6 @@ {- git-annex preferred content matcher configuration - - - Copyright 2012-2019 Joey Hess + - Copyright 2012-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -21,6 +21,7 @@ defaultStandardGroup, preferredRequiredMapsLoad, preferredRequiredMapsLoad', + introspectPreferredRequiredContent, prop_standardGroups_parse, ) where @@ -61,6 +62,16 @@ Nothing -> return d Just matcher -> checkMatcher matcher mkey afile notpresent (return d) (return d) +{- Checks if the preferred or required content for the specified repository + - (or the current repository if none is specified) contains any terms + - that meet the condition. -} +introspectPreferredRequiredContent :: (MatchFiles Annex -> Bool) -> Maybe UUID -> Annex Bool +introspectPreferredRequiredContent c mu = do + u <- maybe getUUID return mu + check u preferredContentMap <||> check u requiredContentMap + where + check u mk = mk >>= return . maybe False (any c) . M.lookup u + preferredContentMap :: Annex (FileMatcherMap Annex) preferredContentMap = maybe (fst <$> preferredRequiredMapsLoad preferredContentTokens) return =<< Annex.getState Annex.preferredcontentmap @@ -86,7 +97,7 @@ preferredRequiredMapsLoad' :: (PreferredContentData -> [ParseToken (MatchFiles Annex)]) -> Annex (M.Map UUID (Either String (FileMatcher Annex)), M.Map UUID (Either String (FileMatcher Annex))) preferredRequiredMapsLoad' mktokens = do groupmap <- groupMap - configmap <- readRemoteLog + configmap <- remoteConfigMap let genmap l gm = let mk u = makeMatcher groupmap configmap gm u mktokens in simpleMap diff --git a/Logs/Remote.hs b/Logs/Remote.hs --- a/Logs/Remote.hs +++ b/Logs/Remote.hs @@ -1,12 +1,13 @@ {- git-annex remote log - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} module Logs.Remote ( remoteLog, + remoteConfigMap, readRemoteLog, configSet, keyValToConfig, @@ -18,6 +19,7 @@ ) where import Annex.Common +import qualified Annex import qualified Annex.Branch import Types.Remote import Logs @@ -35,8 +37,20 @@ buildRemoteConfigLog . changeLog c u (removeSameasInherited cfg) . parseRemoteConfigLog + Annex.changeState $ \s -> s { Annex.remoteconfigmap = Nothing } -{- Map of remotes by uuid containing key/value config maps. -} +{- Map of remotes by uuid containing key/value config maps. + - Cached for speed. -} +remoteConfigMap :: Annex (M.Map UUID RemoteConfig) +remoteConfigMap = maybe remoteConfigMapLoad return + =<< Annex.getState Annex.remoteconfigmap + +remoteConfigMapLoad :: Annex (M.Map UUID RemoteConfig) +remoteConfigMapLoad = do + m <- readRemoteLog + Annex.changeState $ \s -> s { Annex.remoteconfigmap = Just m } + return m + readRemoteLog :: Annex (M.Map UUID RemoteConfig) readRemoteLog = calcRemoteConfigMap <$> Annex.Branch.get remoteLog diff --git a/Messages.hs b/Messages.hs --- a/Messages.hs +++ b/Messages.hs @@ -9,7 +9,7 @@ module Messages ( showStart, - showStart', + showStartOther, showStartMessage, showEndMessage, StartMessage(..), @@ -45,6 +45,7 @@ disableDebugOutput, debugEnabled, commandProgressDisabled, + jsonOutputEnabled, outputMessage, withMessageState, prompt, @@ -64,45 +65,46 @@ import Types.Messages import Types.ActionItem import Types.Concurrency -import Types.Command (StartMessage(..)) +import Types.Command (StartMessage(..), SeekInput) import Types.Transfer (transferKey) import Messages.Internal import Messages.Concurrent +import Annex.Concurrent.Utility import qualified Messages.JSON as JSON import qualified Annex -showStart :: String -> RawFilePath -> Annex () -showStart command file = outputMessage json $ +showStart :: String -> RawFilePath -> SeekInput -> Annex () +showStart command file si = outputMessage json $ encodeBS' command <> " " <> file <> " " where - json = JSON.start command (Just file) Nothing + json = JSON.start command (Just file) Nothing si -showStart' :: String -> Maybe String -> Annex () -showStart' command mdesc = outputMessage json $ encodeBS' $ - command ++ (maybe "" (" " ++) mdesc) ++ " " +showStartKey :: String -> Key -> ActionItem -> SeekInput -> Annex () +showStartKey command key ai si = outputMessage json $ + encodeBS' command <> " " <> actionItemDesc ai <> " " where - json = JSON.start command Nothing Nothing + json = JSON.start command (actionItemWorkTreeFile ai) (Just key) si -showStartKey :: String -> Key -> ActionItem -> Annex () -showStartKey command key i = outputMessage json $ - encodeBS' command <> " " <> actionItemDesc i <> " " +showStartOther :: String -> Maybe String -> SeekInput -> Annex () +showStartOther command mdesc si = outputMessage json $ encodeBS' $ + command ++ (maybe "" (" " ++) mdesc) ++ " " where - json = JSON.start command (actionItemWorkTreeFile i) (Just key) + json = JSON.start command Nothing Nothing si showStartMessage :: StartMessage -> Annex () -showStartMessage (StartMessage command ai) = case ai of - ActionItemAssociatedFile _ k -> showStartKey command k ai - ActionItemKey k -> showStartKey command k ai - ActionItemBranchFilePath _ k -> showStartKey command k ai - ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai - ActionItemWorkTreeFile file -> showStart command file - ActionItemOther msg -> showStart' command msg - OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai') -showStartMessage (StartUsualMessages command ai) = do +showStartMessage (StartMessage command ai si) = case ai of + ActionItemAssociatedFile _ k -> showStartKey command k ai si + ActionItemKey k -> showStartKey command k ai si + ActionItemBranchFilePath _ k -> showStartKey command k ai si + ActionItemFailedTransfer t _ -> showStartKey command (transferKey t) ai si + ActionItemWorkTreeFile file -> showStart command file si + ActionItemOther msg -> showStartOther command msg si + OnlyActionOn _ ai' -> showStartMessage (StartMessage command ai' si) +showStartMessage (StartUsualMessages command ai si) = do outputType <$> Annex.getState Annex.output >>= \case QuietOutput -> Annex.setOutput NormalOutput _ -> noop - showStartMessage (StartMessage command ai) + showStartMessage (StartMessage command ai si) showStartMessage (StartNoMessage _) = noop showStartMessage (CustomOutput _) = outputType <$> Annex.getState Annex.output >>= \case @@ -111,8 +113,8 @@ -- Only show end result if the StartMessage is one that gets displayed. showEndMessage :: StartMessage -> Bool -> Annex () -showEndMessage (StartMessage _ _) = showEndResult -showEndMessage (StartUsualMessages _ _) = showEndResult +showEndMessage (StartMessage _ _ _) = showEndResult +showEndMessage (StartUsualMessages _ _ _) = showEndResult showEndMessage (StartNoMessage _) = const noop showEndMessage (CustomOutput _) = const noop @@ -238,9 +240,9 @@ - a complete JSON document. - This is only needed when showStart and showEndOk is not used. -} -showCustom :: String -> Annex Bool -> Annex () -showCustom command a = do - outputMessage (JSON.start command Nothing Nothing) "" +showCustom :: String -> SeekInput -> Annex Bool -> Annex () +showCustom command si a = do + outputMessage (JSON.start command Nothing Nothing si) "" r <- a outputMessage (JSON.end r) "" @@ -287,6 +289,12 @@ JSONOutput _ -> True NormalOutput -> concurrentOutputEnabled s +jsonOutputEnabled :: Annex Bool +jsonOutputEnabled = withMessageState $ \s -> return $ + case outputType s of + JSONOutput _ -> True + _ -> False + {- Prevents any concurrent console access while running an action, so - that the action is the only thing using the console, and can eg prompt - the user. @@ -298,7 +306,7 @@ {- Like prompt, but for a non-annex action that prompts. -} mkPrompter :: (MonadMask m, MonadIO m) => Annex (m a -> m a) -mkPrompter = Annex.getState Annex.concurrency >>= \case +mkPrompter = getConcurrency >>= \case NonConcurrent -> return id (Concurrent _) -> goconcurrent ConcurrentPerCpu -> goconcurrent diff --git a/Messages/JSON.hs b/Messages/JSON.hs --- a/Messages/JSON.hs +++ b/Messages/JSON.hs @@ -1,6 +1,6 @@ {- git-annex command-line JSON output and input - - - Copyright 2011-2018 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -39,6 +39,7 @@ import Prelude import Types.Messages +import Types.Command (SeekInput(..)) import Key import Utility.Metered import Utility.Percentage @@ -64,8 +65,8 @@ none :: JSONBuilder none = id -start :: String -> Maybe RawFilePath -> Maybe Key -> JSONBuilder -start command file key _ = case j of +start :: String -> Maybe RawFilePath -> Maybe Key -> SeekInput -> JSONBuilder +start command file key si _ = case j of Object o -> Just (o, False) _ -> Nothing where @@ -74,6 +75,7 @@ , itemKey = key , itemFile = fromRawFilePath <$> file , itemAdded = Nothing + , itemSeekInput = si } end :: Bool -> JSONBuilder @@ -176,6 +178,7 @@ , itemKey :: Maybe Key , itemFile :: Maybe FilePath , itemAdded :: Maybe a -- for additional fields added by `add` + , itemSeekInput :: SeekInput } deriving (Show) @@ -183,10 +186,11 @@ toJSON' i = object $ catMaybes [ Just $ "command" .= itemCommand i , case itemKey i of - Nothing -> Nothing Just k -> Just $ "key" .= toJSON' k + Nothing -> Nothing , Just $ "file" .= toJSON' (itemFile i) -- itemAdded is not included; must be added later by 'add' + , Just $ "input" .= fromSeekInput (itemSeekInput i) ] instance FromJSON a => FromJSON (JSONActionItem a) where @@ -195,6 +199,7 @@ <*> (maybe (return Nothing) parseJSON =<< (v .:? "key")) <*> (v .:? "file") <*> parseadded + <*> pure (SeekInput []) where parseadded = (Just <$> parseJSON (Object v)) <|> return Nothing parseJSON _ = mempty diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,4 +1,4 @@ -git-annex (8.20200523) UNRELEASED; urgency=medium +git-annex (8.20200523) upstream; urgency=medium Transition notice: Commands like `git-annex get foo*` silently skip over files that are not checked into git. Since that can be surprising in many diff --git a/Remote.hs b/Remote.hs --- a/Remote.hs +++ b/Remote.hs @@ -1,6 +1,6 @@ {- git-annex remotes - - - Copyright 2011-2019 Joey Hess + - Copyright 2011-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -73,6 +73,7 @@ import Logs.UUID import Logs.Trust import Logs.Location hiding (logStatus) +import Logs.Remote import Logs.Web import Remote.List import Remote.List.Util @@ -337,31 +338,53 @@ return (sortBy (comparing cost) validremotes, validtrustedlocations) -{- Displays known locations of a key. -} +{- Displays known locations of a key and helps the user take action + - to make them accessible. -} showLocations :: Bool -> Key -> [UUID] -> String -> Annex () showLocations separateuntrusted key exclude nolocmsg = do u <- getUUID + remotes <- remoteList uuids <- keyLocations key untrusteduuids <- if separateuntrusted then trustGet UnTrusted else pure [] - let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids) + let uuidswanted = filteruuids uuids (u:exclude++untrusteduuids) let uuidsskipped = filteruuids uuids (u:exclude++uuidswanted) - ppuuidswanted <- prettyPrintUUIDs "wanted" uuidswanted - ppuuidsskipped <- prettyPrintUUIDs "skipped" uuidsskipped - let msg = message ppuuidswanted ppuuidsskipped - unless (null msg) $ - showLongNote msg - ignored <- remoteList - >>= filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) + let remoteuuids = map uuid remotes + let isremoteuuid x = elem x remoteuuids + let (remotesmakeavailable, uuidsothers) = + partition isremoteuuid uuidswanted + isspecialremote <- flip M.member <$> remoteConfigMap + let (enablespecialremotes, addgitremotes) = + partition isspecialremote uuidsothers + + -- Add "wanted" field to the JSON. While it's since been split + -- up more, this avoids breaking any JSON parsers that expect it. + ifM jsonOutputEnabled + ( void $ prettyPrintUUIDs "wanted" uuidswanted + , do + ppremotesmakeavailable <- pp "remotes" remotesmakeavailable + "Try making some of these remotes available" + ppenablespecialremotes <- pp "enableremote" enablespecialremotes + "Maybe enable some of these special remotes (git annex initremote ...)" + ppaddgitremotes <- pp "repos" addgitremotes + "Maybe add some of these git remotes (git remote add ...)" + ppuuidsskipped <- pp "skipped" uuidsskipped + "Also these untrusted repositories may contain the file" + showLongNote $ case ppremotesmakeavailable ++ ppenablespecialremotes ++ ppaddgitremotes ++ ppuuidsskipped of + [] -> nolocmsg + s -> s + ) + ignored <- filterM (liftIO . getDynamicConfig . remoteAnnexIgnore . gitconfig) remotes unless (null ignored) $ showLongNote $ "(Note that these git remotes have annex-ignore set: " ++ unwords (map name ignored) ++ ")" where filteruuids l x = filter (`notElem` x) l - message [] [] = nolocmsg - message rs [] = "Try making some of these repositories available:\n" ++ rs - message [] us = "Also these untrusted repositories may contain the file:\n" ++ us - message rs us = message rs [] ++ message [] us + + pp jh l h = addheader h <$> prettyPrintUUIDs jh l + + addheader _ [] = [] + addheader h l = h ++ ":\n" ++ l showTriedRemotes :: [Remote] -> Annex () showTriedRemotes [] = noop diff --git a/Remote/BitTorrent.hs b/Remote/BitTorrent.hs --- a/Remote/BitTorrent.hs +++ b/Remote/BitTorrent.hs @@ -307,16 +307,16 @@ ariaProgress Nothing _ ps = runAria ps ariaProgress (Just sz) meter ps = do oh <- mkOutputHandler - liftIO . commandMeter (parseAriaProgress sz) oh meter "aria2c" + liftIO . commandMeter (parseAriaProgress sz) oh Nothing meter "aria2c" =<< ariaParams ps parseAriaProgress :: Integer -> ProgressParser parseAriaProgress totalsize = go [] . reverse . splitc '\r' where - go remainder [] = (Nothing, remainder) + go remainder [] = (Nothing, Nothing, remainder) go remainder (x:xs) = case readish (findpercent x) of Nothing -> go (x++remainder) xs - Just p -> (Just (frompercent p), remainder) + Just p -> (Just (frompercent p), Nothing, remainder) -- "(N%)" findpercent = takeWhile (/= '%') . drop 1 . dropWhile (/= '(') diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -109,7 +109,7 @@ -- correctly. resetup gcryptid r = do let u' = genUUIDInNameSpace gCryptNameSpace gcryptid - v <- M.lookup u' <$> readRemoteLog + v <- M.lookup u' <$> remoteConfigMap case (Git.remoteName baser, v) of (Just remotename, Just rc') -> do pc <- parsedRemoteConfig remote rc' diff --git a/Remote/GitLFS.hs b/Remote/GitLFS.hs --- a/Remote/GitLFS.hs +++ b/Remote/GitLFS.hs @@ -187,9 +187,9 @@ configKnownUrl :: Git.Repo -> Annex (Maybe Git.Repo) configKnownUrl r | Git.repoIsUrl r = do - l <- readRemoteLog + m <- remoteConfigMap g <- Annex.gitRepo - case Annex.SpecialRemote.Config.findByRemoteConfig (match g) l of + case Annex.SpecialRemote.Config.findByRemoteConfig (match g) m of ((u, _, mcu):[]) -> Just <$> go u mcu _ -> return Nothing | otherwise = return Nothing diff --git a/Remote/HttpAlso.hs b/Remote/HttpAlso.hs --- a/Remote/HttpAlso.hs +++ b/Remote/HttpAlso.hs @@ -105,7 +105,9 @@ _url <- maybe (giveup "Specify url=") (return . fromProposedAccepted) (M.lookup urlField c) - (c', _encsetup) <- encryptionSetup c gc + c' <- if isJust (M.lookup encryptionField c) + then fst <$> encryptionSetup c gc + else pure c gitConfigSpecialRemote u c' [("httpalso", "true")] return (c', u) diff --git a/Remote/List.hs b/Remote/List.hs --- a/Remote/List.hs +++ b/Remote/List.hs @@ -72,7 +72,7 @@ remoteList' :: Bool -> Annex [Remote] remoteList' autoinit = do - m <- readRemoteLog + m <- remoteConfigMap rs <- concat <$> mapM (process m) remoteTypes Annex.changeState $ \s -> s { Annex.remotes = rs } return rs @@ -96,7 +96,7 @@ {- Updates a local git Remote, re-reading its git config. -} updateRemote :: Remote -> Annex (Maybe Remote) updateRemote remote = do - m <- readRemoteLog + m <- remoteConfigMap remote' <- updaterepo =<< getRepo remote remoteGen m (remotetype remote) remote' where diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -36,6 +36,7 @@ import System.Log.Logger import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar +import Data.Maybe import Annex.Common import Types.Remote @@ -63,6 +64,7 @@ import Utility.DataUnits import Annex.Content import qualified Annex.Url as Url +import Utility.Url (extractFromResourceT) import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env @@ -343,12 +345,11 @@ let req = (putObject info object rbody) { S3.poContentType = encodeBS <$> contenttype } resp <- sendS3Handle h req - let vid = mkS3VersionID object (S3.porVersionId resp) - -- FIXME Actual aws version that supports this is not known, - -- patch not merged yet. - -- https://github.com/aristidb/aws/issues/258 -#if MIN_VERSION_aws(0,99,0) - return (Just (S3.porETag resp), vid) + vid <- mkS3VersionID object + <$> extractFromResourceT (S3.porVersionId resp) +#if MIN_VERSION_aws(0,22,0) + etag <- extractFromResourceT (Just (S3.porETag resp)) + return (etag, vid) #else return (Nothing, vid) #endif @@ -389,7 +390,9 @@ resp <- sendS3Handle h $ S3.postCompleteMultipartUpload (bucket info) object uploadid (zip [1..] etags) - return (Just (S3.cmurETag resp), mkS3VersionID object (S3.cmurVersionId resp)) + etag <- extractFromResourceT (Just (S3.cmurETag resp)) + vid <- extractFromResourceT (S3.cmurVersionId resp) + return (etag, mkS3VersionID object vid) getcontenttype = maybe (pure Nothing) (flip getMagicMimeType f) magic {- Implemented as a fileRetriever, that uses conduit to stream the chunks @@ -474,7 +477,7 @@ checkKeyHelper' :: S3Info -> S3Handle -> S3.Object -> (S3.HeadObject -> S3.HeadObject) -> Annex Bool checkKeyHelper' info h o limit = liftIO $ runResourceT $ do rsp <- sendS3Handle h req - return (isJust $ S3.horMetadata rsp) + extractFromResourceT (isJust $ S3.horMetadata rsp) where req = limit $ S3.headObject (bucket info) o @@ -552,7 +555,8 @@ Nothing -> do warning $ needS3Creds (uuid r) return Nothing - Just h -> catchMaybeIO $ liftIO $ runResourceT $ startlist h + Just h -> catchMaybeIO $ liftIO $ runResourceT $ + extractFromResourceT =<< startlist h where startlist h | versioning info = do @@ -678,10 +682,7 @@ storeExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> [ContentIdentifier] -> MeterUpdate -> Annex ContentIdentifier storeExportWithContentIdentifierS3 hv r rs info magic src k loc _overwritablecids p | versioning info = go - -- FIXME Actual aws version that supports getting Etag for a store - -- is not known; patch not merged yet. - -- https://github.com/aristidb/aws/issues/258 -#if MIN_VERSION_aws(0,99,0) +#if MIN_VERSION_aws(0,22,0) | otherwise = go #else | otherwise = giveup "git-annex is built with too old a version of the aws library to support this operation" @@ -733,11 +734,12 @@ where go _ _ (Right True) = noop go info h _ = do - v <- liftIO $ tryNonAsync $ runResourceT $ - sendS3Handle h (S3.getBucket $ bucket info) - case v of - Right _ -> noop - Left _ -> do + r <- liftIO $ tryNonAsync $ runResourceT $ do + void $ sendS3Handle h (S3.getBucket $ bucket info) + return True + case r of + Right True -> noop + _ -> do showAction $ "creating bucket in " ++ datacenter void $ liftIO $ runResourceT $ sendS3Handle h $ (S3.putBucket (bucket info)) @@ -787,8 +789,7 @@ Left _ -> return False Right r -> do v <- AWS.loadToMemory r - let !ok = check v - return ok + extractFromResourceT (check v) where check (S3.GetObjectMemoryResponse _meta rsp) = responseStatus rsp == ok200 && responseBody rsp == uuidb diff --git a/Remote/Web.hs b/Remote/Web.hs --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -90,9 +90,7 @@ r <- untilTrue urls $ \u -> do let (u', downloader) = getDownloader u case downloader of - YoutubeDownloader -> do - showOutput - youtubeDlTo key u' dest + YoutubeDownloader -> youtubeDlTo key u' dest p _ -> Url.withUrlOptions $ downloadUrl key p [u'] dest unless r $ giveup "download failed" diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -245,15 +245,13 @@ finalCleanup :: IO () finalCleanup = whenM (doesDirectoryExist tmpdir) $ do - Annex.Action.reapZombies Command.Uninit.prepareRemoveAnnexDir' tmpdir catchIO (removeDirectoryForCleanup tmpdir) $ \e -> do print e putStrLn "sleeping 10 seconds and will retry directory cleanup" Utility.ThreadScheduler.threadDelaySeconds $ Utility.ThreadScheduler.Seconds 10 - whenM (doesDirectoryExist tmpdir) $ do - Annex.Action.reapZombies + whenM (doesDirectoryExist tmpdir) $ removeDirectoryForCleanup tmpdir checklink :: FilePath -> Assertion diff --git a/Types/Command.hs b/Types/Command.hs --- a/Types/Command.hs +++ b/Types/Command.hs @@ -38,13 +38,18 @@ - returns the overall success/fail of the command. -} type CommandCleanup = Annex Bool +{- Input that was seeked on to make an ActionItem. Eg, the input filename, + - or directory name. -} +newtype SeekInput = SeekInput { fromSeekInput :: [String] } + deriving (Show) + {- Message that is displayed when starting to perform an action on - something. The String is typically the name of the command or action - being performed. -} data StartMessage - = StartMessage String ActionItem - | StartUsualMessages String ActionItem + = StartMessage String ActionItem SeekInput + | StartUsualMessages String ActionItem SeekInput -- ^ Like StartMessage, but makes sure to enable usual message -- display in case it was disabled by cmdnomessages. | StartNoMessage ActionItem @@ -56,8 +61,8 @@ deriving (Show) instance MkActionItem StartMessage where - mkActionItem (StartMessage _ ai) = ai - mkActionItem (StartUsualMessages _ ai) = ai + mkActionItem (StartMessage _ ai _) = ai + mkActionItem (StartUsualMessages _ ai _) = ai mkActionItem (StartNoMessage ai) = ai mkActionItem (CustomOutput ai) = ai diff --git a/Types/Concurrency.hs b/Types/Concurrency.hs --- a/Types/Concurrency.hs +++ b/Types/Concurrency.hs @@ -17,3 +17,8 @@ parseConcurrency "cpus" = Just ConcurrentPerCpu parseConcurrency "cpu" = Just ConcurrentPerCpu parseConcurrency s = Concurrent <$> readish s + +-- Concurrency can be configured at the command line or by git config. +data ConcurrencySetting + = ConcurrencyCmdLine Concurrency + | ConcurrencyGitConfig Concurrency diff --git a/Types/Export.hs b/Types/Export.hs --- a/Types/Export.hs +++ b/Types/Export.hs @@ -5,6 +5,8 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE DeriveGeneric #-} + module Types.Export ( ExportLocation, mkExportLocation, @@ -20,12 +22,16 @@ import Utility.FileSystemEncoding import qualified System.FilePath.Posix as Posix +import GHC.Generics +import Control.DeepSeq -- A location on a remote that a key can be exported to. -- The RawFilePath will be relative to the top of the remote, -- and uses unix-style path separators. newtype ExportLocation = ExportLocation RawFilePath - deriving (Show, Eq) + deriving (Show, Eq, Generic) + +instance NFData ExportLocation mkExportLocation :: RawFilePath -> ExportLocation mkExportLocation = ExportLocation . toInternalGitPath diff --git a/Types/FileMatcher.hs b/Types/FileMatcher.hs --- a/Types/FileMatcher.hs +++ b/Types/FileMatcher.hs @@ -1,6 +1,6 @@ {- git-annex file matcher types - - - Copyright 2013-2019 Joey Hess + - Copyright 2013-2020 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -23,31 +23,42 @@ = MatchingFile FileInfo | MatchingKey Key AssociatedFile | MatchingInfo ProvidedInfo + | MatchingUserInfo UserProvidedInfo data FileInfo = FileInfo - { currFile :: RawFilePath - -- ^ current path to the file, for operations that examine it + { contentFile :: Maybe RawFilePath + -- ^ path to a file containing the content, for operations + -- that examine it , matchFile :: RawFilePath -- ^ filepath to match on; may be relative to top of repo or cwd } --- This is used when testing a matcher, with values to match against --- provided in some way, rather than queried from files on disk. data ProvidedInfo = ProvidedInfo - { providedFilePath :: OptInfo FilePath - , providedKey :: OptInfo Key - , providedFileSize :: OptInfo FileSize - , providedMimeType :: OptInfo MimeType - , providedMimeEncoding :: OptInfo MimeEncoding + { providedFilePath :: RawFilePath + , providedKey :: Maybe Key + , providedFileSize :: FileSize + , providedMimeType :: Maybe MimeType + , providedMimeEncoding :: Maybe MimeEncoding } -type OptInfo a = Either (IO a) a +-- This is used when testing a matcher, with values to match against +-- provided by the user. +data UserProvidedInfo = UserProvidedInfo + { userProvidedFilePath :: UserInfo FilePath + , userProvidedKey :: UserInfo Key + , userProvidedFileSize :: UserInfo FileSize + , userProvidedMimeType :: UserInfo MimeType + , userProvidedMimeEncoding :: UserInfo MimeEncoding + } --- If the OptInfo is not available, accessing it may result in eg an +-- This may fail if the user did not provide the information. +type UserInfo a = Either (IO a) a + +-- If the UserInfo is not available, accessing it may result in eg an -- exception being thrown. -getInfo :: MonadIO m => OptInfo a -> m a -getInfo (Right i) = return i -getInfo (Left e) = liftIO e +getUserInfo :: MonadIO m => UserInfo a -> m a +getUserInfo (Right i) = return i +getUserInfo (Left e) = liftIO e type FileMatcherMap a = M.Map UUID (FileMatcher a) @@ -55,12 +66,23 @@ type AssumeNotPresent = S.Set UUID -type MatchFiles a = AssumeNotPresent -> MatchInfo -> a Bool +data MatchFiles a = MatchFiles + { matchAction :: AssumeNotPresent -> MatchInfo -> a Bool + , matchNeedsFileName :: Bool + -- ^ does the matchAction need a filename in order to match? + , matchNeedsFileContent :: Bool + -- ^ does the matchAction need the file content to be present in + -- order to succeed? + , matchNeedsKey :: Bool + -- ^ does the matchAction look at information about the key? + , matchNeedsLocationLog :: Bool + -- ^ does the matchAction look at the location log? + } type FileMatcher a = Matcher (MatchFiles a) -- This is a matcher that can have tokens added to it while it's being -- built, and once complete is compiled to an unchangable matcher. data ExpandableMatcher a - = BuildingMatcher [Token (MatchInfo -> a Bool)] - | CompleteMatcher (Matcher (MatchInfo -> a Bool)) + = BuildingMatcher [Token (MatchFiles a)] + | CompleteMatcher (Matcher (MatchFiles a)) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -9,7 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} module Types.GitConfig ( - Configurable(..), + GlobalConfigurable(..), ConfigSource(..), GitConfig(..), extractGitConfig, @@ -53,7 +53,7 @@ -- | A configurable value, that may not be fully determined yet because -- the global git config has not yet been loaded. -data Configurable a +data GlobalConfigurable a = HasGitConfig a -- ^ The git config has a value. | HasGlobalConfig a @@ -84,17 +84,17 @@ , annexDelayAdd :: Maybe Int , annexHttpHeaders :: [String] , annexHttpHeadersCommand :: Maybe String - , annexAutoCommit :: Configurable Bool - , annexResolveMerge :: Configurable Bool - , annexSyncContent :: Configurable Bool - , annexSyncOnlyAnnex :: Configurable Bool + , annexAutoCommit :: GlobalConfigurable Bool + , annexResolveMerge :: GlobalConfigurable Bool + , annexSyncContent :: GlobalConfigurable Bool + , annexSyncOnlyAnnex :: GlobalConfigurable Bool , annexDebug :: Bool , annexWebOptions :: [String] , annexYoutubeDlOptions :: [String] , annexAriaTorrentOptions :: [String] , annexCrippledFileSystem :: Bool - , annexLargeFiles :: Configurable (Maybe String) - , annexDotFiles :: Configurable Bool + , annexLargeFiles :: GlobalConfigurable (Maybe String) + , annexDotFiles :: GlobalConfigurable Bool , annexGitAddToAnnex :: Bool , annexAddSmallFiles :: Bool , annexFsckNudge :: Bool @@ -111,7 +111,7 @@ , annexVerify :: Bool , annexPidLock :: Bool , annexPidLockTimeout :: Seconds - , annexAddUnlocked :: Configurable (Maybe String) + , annexAddUnlocked :: GlobalConfigurable (Maybe String) , annexSecureHashesOnly :: Bool , annexRetry :: Maybe Integer , annexForwardRetry :: Maybe Integer diff --git a/Types/Import.hs b/Types/Import.hs --- a/Types/Import.hs +++ b/Types/Import.hs @@ -5,10 +5,14 @@ - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE DeriveGeneric #-} + module Types.Import where import qualified Data.ByteString as S import Data.Char +import Control.DeepSeq +import GHC.Generics import Types.Export import Utility.QuickCheck @@ -29,8 +33,10 @@ - the repository. It should be reasonably short since it is stored in the - git-annex branch. -} newtype ContentIdentifier = ContentIdentifier S.ByteString - deriving (Eq, Ord, Show) + deriving (Eq, Ord, Show, Generic) +instance NFData ContentIdentifier + instance Arbitrary ContentIdentifier where -- Avoid non-ascii ContentIdentifiers because fully arbitrary -- strings may not be encoded using the filesystem @@ -47,4 +53,6 @@ -- files that are stored in them. This is equivilant to a git -- commit history. } - deriving (Show) + deriving (Show, Generic) + +instance NFData info => NFData (ImportableContents info) diff --git a/Upgrade/V7.hs b/Upgrade/V7.hs --- a/Upgrade/V7.hs +++ b/Upgrade/V7.hs @@ -17,6 +17,7 @@ import qualified Git.LsFiles as LsFiles import qualified Git import Git.FilePath +import Config upgrade :: Bool -> Annex Bool upgrade automatic = do @@ -96,7 +97,7 @@ -- annex object. That work is only done once, and then the object will -- finally get its inode cached. populateKeysDb :: Annex () -populateKeysDb = do +populateKeysDb = unlessM isBareRepo $ do top <- fromRepo Git.repoPath (l, cleanup) <- inRepo $ LsFiles.inodeCaches [top] forM_ l $ \case diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs --- a/Utility/Matcher.hs +++ b/Utility/Matcher.hs @@ -10,12 +10,12 @@ - Is forgiving about misplaced closing parens, so "foo and (bar or baz" - will be handled, as will "foo and ( bar or baz ) )" - - - Copyright 2011-2013 Joey Hess + - Copyright 2011-2020 Joey Hess - - License: BSD-2-clause -} -{-# LANGUAGE Rank2Types, KindSignatures #-} +{-# LANGUAGE Rank2Types, KindSignatures, DeriveFoldable #-} module Utility.Matcher ( Token(..), @@ -27,6 +27,7 @@ matchMrun, isEmpty, combineMatchers, + introspect, prop_matcher_sane ) where @@ -43,7 +44,7 @@ | MOr (Matcher op) (Matcher op) | MNot (Matcher op) | MOp op - deriving (Show, Eq) + deriving (Show, Eq, Foldable) {- Converts a word of syntax into a token. Doesn't handle operations. -} syntaxToken :: String -> Either String (Token op) @@ -146,6 +147,10 @@ | isEmpty a = b | isEmpty b = a | otherwise = a `MOr` b + +{- Checks if anything in the matcher meets the condition. -} +introspect :: (a -> Bool) -> Matcher a -> Bool +introspect = any prop_matcher_sane :: Bool prop_matcher_sane = all (\m -> match dummy m ()) $ map generate diff --git a/Utility/Metered.hs b/Utility/Metered.hs --- a/Utility/Metered.hs +++ b/Utility/Metered.hs @@ -11,6 +11,7 @@ MeterUpdate, nullMeterUpdate, combineMeterUpdate, + TotalSize(..), BytesProcessed(..), toBytesProcessed, fromBytesProcessed, @@ -29,6 +30,8 @@ ProgressParser, commandMeter, commandMeter', + commandMeterExitCode, + commandMeterExitCode', demeterCommand, demeterCommandEnv, avoidProgress, @@ -228,31 +231,44 @@ } {- Parses the String looking for a command's progress output, and returns - - Maybe the number of bytes done so far, and any any remainder of the - - string that could be an incomplete progress output. That remainder - - should be prepended to future output, and fed back in. This interface - - allows the command's output to be read in any desired size chunk, or - - even one character at a time. + - Maybe the number of bytes done so far, optionally a total size, + - and any any remainder of the string that could be an incomplete + - progress output. That remainder should be prepended to future output, + - and fed back in. This interface allows the command's output to be read + - in any desired size chunk, or even one character at a time. -} -type ProgressParser = String -> (Maybe BytesProcessed, String) +type ProgressParser = String -> (Maybe BytesProcessed, Maybe TotalSize, String) +newtype TotalSize = TotalSize Integer + {- Runs a command and runs a ProgressParser on its output, in order - to update a meter. + - + - If the Meter is provided, the ProgressParser can report the total size, + - which allows creating a Meter before the size is known. -} -commandMeter :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool -commandMeter progressparser oh meterupdate cmd params = do - ret <- commandMeter' progressparser oh meterupdate cmd params +commandMeter :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO Bool +commandMeter progressparser oh meter meterupdate cmd params = + commandMeter' progressparser oh meter meterupdate cmd params id + +commandMeter' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO Bool +commandMeter' progressparser oh meter meterupdate cmd params mkprocess = do + ret <- commandMeterExitCode' progressparser oh meter meterupdate cmd params mkprocess return $ case ret of Just ExitSuccess -> True _ -> False -commandMeter' :: ProgressParser -> OutputHandler -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode) -commandMeter' progressparser oh meterupdate cmd params = - outputFilter cmd params Nothing - (feedprogress zeroBytesProcessed []) +commandMeterExitCode :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> IO (Maybe ExitCode) +commandMeterExitCode progressparser oh meter meterupdate cmd params = + commandMeterExitCode' progressparser oh meter meterupdate cmd params id + +commandMeterExitCode' :: ProgressParser -> OutputHandler -> Maybe Meter -> MeterUpdate -> FilePath -> [CommandParam] -> (CreateProcess -> CreateProcess) -> IO (Maybe ExitCode) +commandMeterExitCode' progressparser oh mmeter meterupdate cmd params mkprocess = + outputFilter cmd params mkprocess Nothing + (feedprogress mmeter zeroBytesProcessed []) handlestderr where - feedprogress prev buf h = do + feedprogress sendtotalsize prev buf h = do b <- S.hGetSome h 80 if S.null b then return () @@ -261,13 +277,18 @@ S.hPut stdout b hFlush stdout let s = decodeBS b - let (mbytes, buf') = progressparser (buf++s) + let (mbytes, mtotalsize, buf') = progressparser (buf++s) + sendtotalsize' <- case (sendtotalsize, mtotalsize) of + (Just meter, Just (TotalSize n)) -> do + setMeterTotalSize meter n + return Nothing + _ -> return sendtotalsize case mbytes of - Nothing -> feedprogress prev buf' h + Nothing -> feedprogress sendtotalsize' prev buf' h (Just bytes) -> do when (bytes /= prev) $ meterupdate bytes - feedprogress bytes buf' h + feedprogress sendtotalsize' bytes buf' h handlestderr h = unlessM (hIsEOF h) $ do stderrHandler oh =<< hGetLine h @@ -283,7 +304,7 @@ demeterCommandEnv :: OutputHandler -> FilePath -> [CommandParam] -> Maybe [(String, String)] -> IO Bool demeterCommandEnv oh cmd params environ = do - ret <- outputFilter cmd params environ + ret <- outputFilter cmd params id environ (\outh -> avoidProgress True outh stdouthandler) (\errh -> avoidProgress True errh $ stderrHandler oh) return $ case ret of @@ -308,11 +329,12 @@ outputFilter :: FilePath -> [CommandParam] + -> (CreateProcess -> CreateProcess) -> Maybe [(String, String)] -> (Handle -> IO ()) -> (Handle -> IO ()) -> IO (Maybe ExitCode) -outputFilter cmd params environ outfilter errfilter = +outputFilter cmd params mkprocess environ outfilter errfilter = catchMaybeIO $ withCreateProcess p go where go _ (Just outh) (Just errh) pid = do @@ -338,7 +360,7 @@ return ret go _ _ _ _ = error "internal" - p = (proc cmd (toCommand params)) + p = mkprocess (proc cmd (toCommand params)) { env = environ , std_out = CreatePipe , std_err = CreatePipe diff --git a/Utility/Path.hs b/Utility/Path.hs --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -19,7 +19,9 @@ relPathDirToFile, relPathDirToFileAbs, segmentPaths, + segmentPaths', runSegmentPaths, + runSegmentPaths', relHome, inPath, searchPath, @@ -215,22 +217,33 @@ - that many paths in doesn't care too much about order of the later ones. -} segmentPaths :: (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[a]] -segmentPaths _ [] new = [new] -segmentPaths _ [_] new = [new] -- optimisation -segmentPaths c (l:ls) new = found : segmentPaths c ls rest +segmentPaths = segmentPaths' (\_ r -> r) + +segmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> [RawFilePath] -> [a] -> [[r]] +segmentPaths' f _ [] new = [map (f Nothing) new] +segmentPaths' f _ [i] new = [map (f (Just i)) new] -- optimisation +segmentPaths' f c (i:is) new = + map (f (Just i)) found : segmentPaths' f c is rest where - (found, rest) = if length ls < 100 - then partition inl new - else break (not . inl) new - inl f = l' `dirContains` fromRawFilePath (c f) - l' = fromRawFilePath l + (found, rest) = if length is < 100 + then partition ini new + else break (not . ini) new + ini p = i' `dirContains` fromRawFilePath (c p) + i' = fromRawFilePath i {- This assumes that it's cheaper to call segmentPaths on the result, - than it would be to run the action separately with each path. In - the case of git file list commands, that assumption tends to hold. -} -runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO [a]) -> [RawFilePath] -> IO [[a]] -runSegmentPaths c a paths = segmentPaths c paths <$> a paths +runSegmentPaths :: (a -> RawFilePath) -> ([RawFilePath] -> IO ([a], v)) -> [RawFilePath] -> IO ([[a]], v) +runSegmentPaths c a paths = do + (l, cleanup) <- a paths + return (segmentPaths c paths l, cleanup) + +runSegmentPaths' :: (Maybe RawFilePath -> a -> r) -> (a -> RawFilePath) -> ([RawFilePath] -> IO ([a], v)) -> [RawFilePath] -> IO ([[r]], v) +runSegmentPaths' si c a paths = do + (l, cleanup) <- a paths + return (segmentPaths' si c paths l, cleanup) {- Converts paths in the home directory to use ~/ -} relHome :: FilePath -> IO String diff --git a/Utility/Process.hs b/Utility/Process.hs --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -173,8 +173,9 @@ -- | Wrapper around 'System.Process.createProcess' that does debug logging. createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) createProcess p = do - debugProcess p - Utility.Process.Shim.createProcess p + r@(_, _, _, h) <- Utility.Process.Shim.createProcess p + debugProcess p h + return r -- | Wrapper around 'System.Process.withCreateProcess' that does debug logging. withCreateProcess :: CreateProcess -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) -> IO a @@ -182,11 +183,14 @@ (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) -- | Debugging trace for a CreateProcess. -debugProcess :: CreateProcess -> IO () -debugProcess p = debugM "Utility.Process" $ unwords - [ action ++ ":" - , showCmd p - ] +debugProcess :: CreateProcess -> ProcessHandle -> IO () +debugProcess p h = do + pid <- getPid h + debugM "Utility.Process" $ unwords + [ describePid pid + , action ++ ":" + , showCmd p + ] where action | piped (std_in p) && piped (std_out p) = "chat" @@ -196,11 +200,17 @@ piped Inherit = False piped _ = True +describePid :: Maybe Utility.Process.Shim.Pid -> String +describePid Nothing = "process" +describePid (Just p) = "process [" ++ show p ++ "]" + -- | Wrapper around 'System.Process.waitForProcess' that does debug logging. waitForProcess :: ProcessHandle -> IO ExitCode waitForProcess h = do + -- Have to get pid before waiting, which closes the ProcessHandle. + pid <- getPid h r <- Utility.Process.Shim.waitForProcess h - debugM "Utility.Process" ("process done " ++ show r) + debugM "Utility.Process" (describePid pid ++ " done " ++ show r) return r cleanupProcess :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO () diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -114,7 +114,7 @@ -} rsyncProgress :: OutputHandler -> MeterUpdate -> [CommandParam] -> IO Bool rsyncProgress oh meter ps = - commandMeter' parseRsyncProgress oh meter "rsync" (rsyncParamsFixup ps) >>= \case + commandMeterExitCode parseRsyncProgress oh Nothing meter "rsync" (rsyncParamsFixup ps) >>= \case Just ExitSuccess -> return True Just (ExitFailure exitcode) -> do when (exitcode /= 1) $ @@ -136,10 +136,10 @@ parseRsyncProgress :: ProgressParser parseRsyncProgress = go [] . reverse . progresschunks where - go remainder [] = (Nothing, remainder) + go remainder [] = (Nothing, Nothing, remainder) go remainder (x:xs) = case parsebytes (findbytesstart x) of Nothing -> go (delim:x++remainder) xs - Just b -> (Just (toBytesProcessed b), remainder) + Just b -> (Just (toBytesProcessed b), Nothing, remainder) delim = '\r' diff --git a/Utility/Url.hs b/Utility/Url.hs --- a/Utility/Url.hs +++ b/Utility/Url.hs @@ -41,6 +41,7 @@ GetBasicAuth, noBasicAuth, applyBasicAuth', + extractFromResourceT, ) where import Common @@ -60,8 +61,10 @@ import qualified Data.ByteString.UTF8 as B8 import qualified Data.ByteString.Lazy as L import qualified Data.Set as S -import Control.Exception (throwIO) +import Control.Exception (throwIO, evaluate) import Control.Monad.Trans.Resource +import Control.Monad.IO.Class (MonadIO) +import Control.DeepSeq import Network.HTTP.Conduit import Network.HTTP.Client import Network.HTTP.Simple (getResponseHeader) @@ -269,12 +272,10 @@ debugM "url" (show req') join $ runResourceT $ do resp <- http req' (httpManager uo) - -- forces processing the response while - -- within the runResourceT - liftIO $ if responseStatus resp == ok200 + if responseStatus resp == ok200 then do - let !len = extractlen resp - let !fn = extractfilename resp + len <- extractFromResourceT (extractlen resp) + fn <- extractFromResourceT (extractfilename resp) return $ found len fn else if responseStatus resp == unauthorized401 then return $ getBasicAuth uo' (show (getUri req)) >>= \case @@ -463,11 +464,13 @@ then do store zeroBytesProcessed WriteMode resp return (return ()) - else if responseStatus resp == unauthorized401 - then return $ getBasicAuth uo (show (getUri req')) >>= \case - Nothing -> respfailure resp - Just ba -> retryauthed ba - else return $ respfailure resp + else do + rf <- extractFromResourceT (respfailure resp) + if responseStatus resp == unauthorized401 + then return $ getBasicAuth uo (show (getUri req')) >>= \case + Nothing -> giveup rf + Just ba -> retryauthed ba + else return $ giveup rf where req' = applyRequest uo $ req -- Override http-client's default decompression of gzip @@ -498,11 +501,13 @@ then do store zeroBytesProcessed WriteMode resp return (return ()) - else if responseStatus resp == unauthorized401 - then return $ getBasicAuth uo (show (getUri req'')) >>= \case - Nothing -> respfailure resp - Just ba -> retryauthed ba - else return $ respfailure resp + else do + rf <- extractFromResourceT (respfailure resp) + if responseStatus resp == unauthorized401 + then return $ getBasicAuth uo (show (getUri req'')) >>= \case + Nothing -> giveup rf + Just ba -> retryauthed ba + else return $ giveup rf alreadydownloaded sz s h = s == requestedRangeNotSatisfiable416 && case lookup hContentRange h of @@ -521,7 +526,7 @@ store initialp mode resp = sinkResponseFile meterupdate initialp file mode resp - respfailure = giveup . B8.toString . statusMessage . responseStatus + respfailure = B8.toString . statusMessage . responseStatus retryauthed (ba, signalsuccess) = do r <- tryNonAsync $ downloadConduit @@ -710,3 +715,11 @@ applyBasicAuth' ba = applyBasicAuth (encodeBS (basicAuthUser ba)) (encodeBS (basicAuthPassword ba)) + +{- Make sure whatever is returned is fully evaluated. Avoids any possible + - issues with laziness deferring processing until a time when the resource + - has been freed. -} +extractFromResourceT :: (MonadIO m, NFData a) => a -> ResourceT m a +extractFromResourceT v = do + liftIO $ evaluate (rnf v) + return v diff --git a/doc/git-annex-add.mdwn b/doc/git-annex-add.mdwn --- a/doc/git-annex-add.mdwn +++ b/doc/git-annex-add.mdwn @@ -38,7 +38,7 @@ # OPTIONS -* `--force` +* `--no-check-gitignore` Add gitignored files. 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 @@ -85,6 +85,12 @@ Use to adjust the filenames that are created by addurl. For example, `--suffix=.mp3` can be used to add an extension to the file. +* `--no-check-gitignore` + + By default, gitignores are honored and it will refuse to download an + url to a file that would be ignored. This makes such files be added + despite any ignores. + * `--jobs=N` `-JN` Enables parallel downloads when multiple urls are being added. 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 @@ -31,7 +31,7 @@ You can only import from special remotes that were configured with `importtree=yes` when set up with [[git-annex-initremote]](1). Only some kinds of special remotes will let you configure them this way. A perhaps -non-exhastive list is the directory, s3, and adb special remotes. +non-exhaustive list is the directory, s3, and adb special remotes. To import from a special remote, you must specify the name of a branch. A corresponding remote tracking branch will be updated by `git annex import`. @@ -72,6 +72,9 @@ git config remote.myremote.annex-tracking-branch master git annex sync --content +Any files that are gitignored will not be included in the import, +but will be left on the remote. + When the special remote has a preferred content expression set by [[git-annex-wanted]](1), it will be honored when importing from it. Files that are not preferred content of the remote will not be @@ -91,33 +94,14 @@ * `--content`, `--no-content` - Controls whether content is downloaded from the special remote. + Controls whether annexed content is downloaded from the special remote. + The default is to download content into the git-annex repository. With --no-content, git-annex keys are generated from information provided by the special remote, without downloading it. Commands like `git-annex get` can later be used to download files, as desired. - - The --no-content option is not supported by all special remotes, - and the kind of git-annex key that is generated is left up to - each special remote. So while the directory special remote hashes - the file and generates the same key it usually would, other - special remotes may use unusual keys like SHA1, or WORM, depending - on the limitations of the special remote. - - The annex.securehashesonly configuration, if set, will prevent - --no-content importing from a special remote that uses insecure keys. - - Using --no-content prevents annex.largefiles from being checked, - because the files are not downloaded. So, when using --no-content, - files that would usually be considered non-large will be added to the - annex, rather than adding them directly to the git repository. - - Note that a different git tree will often be generated when using - --no-content than would be generated when using --content, because - the options cause different kinds of keys to be used when importing - new/changed files. So mixing uses of --content and --no-content can - lead to merge conflicts in some situations. + The --no-content option is not supported by all special remotes. # IMPORTING FROM A DIRECTORY @@ -200,6 +184,10 @@ For example: `-J4` Setting this to "cpus" will run one job per CPU core. + +* `--no-check-gitignore` + + Add gitignored files. * `--json` 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 @@ -89,6 +89,12 @@ (These use the UTC time zone, not the local time zone.) +* `--no-check-gitignore` + + By default, gitignores are honored and it will refuse to download an + url to a file that would be ignored. This makes such files be added + despite any ignores. + # SEE ALSO [[git-annex]](1) 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 @@ -108,12 +108,14 @@ This behavior can be overridden by configuring the preferred content of a repository. See [[git-annex-preferred-content]](1). - When `remote..annex-tracking-branch` is configured for a special remote - and that branch is checked out, syncing content will import changes from - the remote, merge them into the branch, and export any changes that have - been committed to the branch back to the remote. See - See [[git-annex-import]](1) and [[git-annex-export]](1) for details about - how importing and exporting work. + When `remote..annex-tracking-branch` is configured for a special + remote and that branch is checked out, syncing with --content will + import changes from the remote, merge them into the branch, and export + any changes that have been committed to the branch back to the remote. + With --no-content, imports will only be made from special remotes that + support importing without transferting files, and no exports will be done. + See [[git-annex-import]](1) and [[git-annex-export]](1) for details + about how importing and exporting work. * `--content-of=path` `-C path` diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1014,6 +1014,8 @@ Setting this to "cpus" will run one job per CPU core. + When the `--batch` option is used, this configuration is ignored. + * `annex.queuesize` git-annex builds a queue of git commands, in order to combine similar diff --git a/git-annex.cabal b/git-annex.cabal --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 8.20200908 +Version: 8.20201007 Cabal-Version: >= 1.10 License: AGPL-3 Maintainer: Joey Hess @@ -270,7 +270,7 @@ Flag Benchmark Description: Enable benchmarking - Default: False + Default: True Flag DebugLocks Description: Debug location of MVar/STM deadlocks diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -8,7 +8,7 @@ magicmime: false dbus: false debuglocks: false - benchmark: false + benchmark: true networkbsd: true gitlfs: true httpclientrestricted: true @@ -28,4 +28,4 @@ - network-3.1.0.1 explicit-setup-deps: git-annex: true -resolver: lts-16.10 +resolver: lts-16.16