diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -37,7 +37,6 @@ import Annex.Version import Annex.Difference import Annex.UUID -import Annex.WorkTree import Annex.Fixup import Annex.Path import Config @@ -102,8 +101,8 @@ Right username -> [username, at, hostname, ":", reldir] Left _ -> [hostname, ":", reldir] -initialize :: Bool -> Maybe String -> Maybe RepoVersion -> Annex () -initialize autoinit mdescription mversion = checkInitializeAllowed $ \initallowed -> do +initialize :: Maybe String -> Maybe RepoVersion -> Annex () +initialize mdescription mversion = checkInitializeAllowed $ \initallowed -> do {- Has to come before any commits are made as the shared - clone heuristic expects no local objects. -} sharedclone <- checkSharedClone @@ -113,7 +112,7 @@ ensureCommit $ Annex.Branch.create prepUUID - initialize' autoinit mversion initallowed + initialize' mversion initallowed initSharedClone sharedclone @@ -125,8 +124,8 @@ -- Everything except for uuid setup, shared clone setup, and initial -- description. -initialize' :: Bool -> Maybe RepoVersion -> InitializeAllowed -> Annex () -initialize' autoinit mversion _initallowed = do +initialize' :: Maybe RepoVersion -> InitializeAllowed -> Annex () +initialize' mversion _initallowed = do checkLockSupport checkFifoSupport checkCrippledFileSystem @@ -143,8 +142,6 @@ unlessM isBareRepo $ do hookWrite postCheckoutHook hookWrite postMergeHook - unless autoinit $ - scanAnnexedFiles AdjustedBranch.checkAdjustedClone >>= \case AdjustedBranch.InAdjustedClone -> return () @@ -206,7 +203,7 @@ where needsinit = ifM autoInitializeAllowed ( do - tryNonAsync (initialize True Nothing Nothing) >>= \case + tryNonAsync (initialize Nothing Nothing) >>= \case Right () -> noop Left e -> giveup $ show e ++ "\n" ++ "git-annex: automatic initialization failed due to above problems" @@ -259,7 +256,7 @@ where needsinit = whenM (initializeAllowed <&&> autoInitializeAllowed) $ do - initialize True Nothing Nothing + initialize Nothing Nothing autoEnableSpecialRemotes remotelist {- Checks if a repository is initialized. Does not check version for ugrade. -} diff --git a/Annex/Locations.hs b/Annex/Locations.hs --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -50,6 +50,7 @@ gitAnnexSmudgeLog, gitAnnexSmudgeLock, gitAnnexRestageLog, + gitAnnexRestageLogOld, gitAnnexRestageLock, gitAnnexMoveLog, gitAnnexMoveLock, @@ -384,6 +385,10 @@ - restaged in git -} gitAnnexRestageLog :: Git.Repo -> RawFilePath gitAnnexRestageLog r = gitAnnexDir r P. "restage.log" + +{- .git/annex/restage.old is used while restaging files in git -} +gitAnnexRestageLogOld :: Git.Repo -> RawFilePath +gitAnnexRestageLogOld r = gitAnnexDir r P. "restage.old" gitAnnexRestageLock :: Git.Repo -> RawFilePath gitAnnexRestageLock r = gitAnnexDir r P. "restage.lck" diff --git a/Annex/YoutubeDl.hs b/Annex/YoutubeDl.hs --- a/Annex/YoutubeDl.hs +++ b/Annex/YoutubeDl.hs @@ -249,8 +249,9 @@ return (opts ++ addopts) youtubeDlCommand :: Annex String -youtubeDlCommand = fromMaybe "youtube-dl" . annexYoutubeDlCommand - <$> Annex.getGitConfig +youtubeDlCommand = annexYoutubeDlCommand <$> Annex.getGitConfig >>= \case + Just c -> pure c + Nothing -> fromMaybe "yt-dlp" <$> liftIO (searchPath "youtube-dl") supportedScheme :: UrlOptions -> URLString -> Bool supportedScheme uo url = case parseURIRelaxed url of @@ -264,8 +265,10 @@ _ -> allowedScheme uo u {- Strategy: Look for chunks prefixed with \r, which look approximately - - like this: + - like this for youtube-dl: - "ESC[K[download] 26.6% of 60.22MiB at 254.69MiB/s ETA 00:00" + - or for yt-dlp, like this: + - "\r[download] 1.8% of 1.14GiB at 1.04MiB/s ETA 18:23" - Look at the number before "% of " and the number and unit after, - to determine the number of bytes. -} @@ -291,8 +294,11 @@ calc percent total = round (percent * fromIntegral total / 100) parsepercent :: String -> Maybe Double - parsepercent = readMaybe . reverse . takeWhile (not . isSpace) . reverse + parsepercent = readMaybe + . reverse . takeWhile (not . isSpace) . reverse + . dropWhile isSpace - parsebytes = readSize units . takeWhile (not . isSpace) + parsebytes = readSize units . takeWhile (not . isSpace) + . dropWhile isSpace units = committeeUnits ++ storageUnits diff --git a/Assistant/MakeRepo.hs b/Assistant/MakeRepo.hs --- a/Assistant/MakeRepo.hs +++ b/Assistant/MakeRepo.hs @@ -85,7 +85,7 @@ initRepo' :: Maybe String -> Maybe StandardGroup -> Annex () initRepo' desc mgroup = unlessM isInitialized $ do - initialize False desc Nothing + initialize desc Nothing u <- getUUID maybe noop (defaultStandardGroup u) mgroup {- Ensure branch gets committed right away so it is diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,28 @@ +git-annex (10.20221212) upstream; urgency=medium + + * Fix a hang that occasionally occurred during commands such as move, + when operating on unlocked files. (A bug introduced in 10.20220927) + * When youtube-dl is not available in PATH, use yt-dlp instead. + * Support parsing yt-dpl output to display download progress. + * init: Avoid scanning for annexed files, which can be lengthy in a + large repository. Instead that scan is done on demand. + * Sped up the initial scan for annexed files by 21%. + * test: Add --test-debug option. + * Support quettabyte and yottabyte. + + -- Joey Hess Mon, 12 Dec 2022 12:20:06 -0400 + +git-annex (10.20221104) upstream; urgency=medium + + * export: Fix a bug that left a file on a special remote when + two files with the same content were both deleted in the exported tree. + * S3: Support signature=anonymous to access a S3 bucket anonymously. + This can be used, for example, with importtree=yes to import from + a public bucket. + This feature needs git-annex to be built with aws-0.23. + + -- Joey Hess Thu, 03 Nov 2022 14:07:31 -0400 + git-annex (10.20221103) upstream; urgency=medium * Doubled the speed of git-annex drop when operating on many files, diff --git a/Command/ConfigList.hs b/Command/ConfigList.hs --- a/Command/ConfigList.hs +++ b/Command/ConfigList.hs @@ -47,7 +47,7 @@ else ifM (Annex.Branch.hasSibling <||> (isJust <$> Fields.getField Fields.autoInit)) ( do liftIO checkNotReadOnly - initialize True Nothing Nothing + initialize Nothing Nothing getUUID , return NoUUID ) diff --git a/Command/Export.hs b/Command/Export.hs --- a/Command/Export.hs +++ b/Command/Export.hs @@ -149,23 +149,24 @@ [] -> updateExportTree db emptyTree new [oldtreesha] -> do diffmap <- mkDiffMap oldtreesha new db - let seekdiffmap a = commandActions $ - map a (M.toList diffmap) + let seekdiffmap a = mapM_ a (M.toList diffmap) -- Rename old files to temp, or delete. - seekdiffmap $ \(ek, (moldf, mnewf)) -> do - case (moldf, mnewf) of - (Just oldf, Just _newf) -> + let deleteoldf = \ek oldf -> commandAction $ + startUnexport' r db oldf ek + seekdiffmap $ \case + (ek, (oldf:oldfs, _newf:_)) -> do + commandAction $ startMoveToTempName r db oldf ek - (Just oldf, Nothing) -> - startUnexport' r db oldf ek - _ -> stop + forM_ oldfs (deleteoldf ek) + (ek, (oldfs, [])) -> + forM_ oldfs (deleteoldf ek) + (_ek, ([], _)) -> noop waitForAllRunningCommandActions -- Rename from temp to new files. - seekdiffmap $ \(ek, (moldf, mnewf)) -> - case (moldf, mnewf) of - (Just _oldf, Just newf) -> - startMoveFromTempName r db ek newf - _ -> stop + seekdiffmap $ \case + (ek, (_oldf:_, newf:_)) -> commandAction $ + startMoveFromTempName r db ek newf + _ -> noop waitForAllRunningCommandActions ts -> do warning "Resolving export conflict.." @@ -204,7 +205,7 @@ void $ liftIO cleanup -- Map of old and new filenames for each changed Key in a diff. -type DiffMap = M.Map Key (Maybe TopFilePath, Maybe TopFilePath) +type DiffMap = M.Map Key ([TopFilePath], [TopFilePath]) mkDiffMap :: Git.Ref -> Git.Ref -> ExportHandle -> Annex DiffMap mkDiffMap old new db = do @@ -213,14 +214,14 @@ void $ liftIO cleanup return diffmap where - combinedm (srca, dsta) (srcb, dstb) = (srca <|> srcb, dsta <|> dstb) + combinedm (srca, dsta) (srcb, dstb) = (srca ++ srcb, dsta ++ dstb) mkdm i = do srcek <- getek (Git.DiffTree.srcsha i) dstek <- getek (Git.DiffTree.dstsha i) updateExportTree' db srcek dstek i return $ catMaybes - [ (, (Just (Git.DiffTree.file i), Nothing)) <$> srcek - , (, (Nothing, Just (Git.DiffTree.file i))) <$> dstek + [ (, ([Git.DiffTree.file i], [])) <$> srcek + , (, ([], [Git.DiffTree.file i])) <$> dstek ] getek sha | sha `elem` nullShas = return Nothing diff --git a/Command/Init.hs b/Command/Init.hs --- a/Command/Init.hs +++ b/Command/Init.hs @@ -75,7 +75,7 @@ Just v | v /= wantversion -> giveup $ "This repository is already a initialized with version " ++ show (fromRepoVersion v) ++ ", not changing to requested version." _ -> noop - initialize False + initialize (if null (initDesc os) then Nothing else Just (initDesc os)) (initVersion os) unless (noAutoEnable os) diff --git a/Command/Reinit.hs b/Command/Reinit.hs --- a/Command/Reinit.hs +++ b/Command/Reinit.hs @@ -35,6 +35,6 @@ then return $ toUUID s else Remote.nameToUUID s storeUUID u - checkInitializeAllowed $ initialize' False Nothing + checkInitializeAllowed $ initialize' Nothing Annex.SpecialRemote.autoEnable next $ return True diff --git a/Command/Upgrade.hs b/Command/Upgrade.hs --- a/Command/Upgrade.hs +++ b/Command/Upgrade.hs @@ -45,6 +45,6 @@ start _ = starting "upgrade" (ActionItemOther Nothing) (SeekInput []) $ do whenM (isNothing <$> getVersion) $ do - initialize False Nothing Nothing + initialize Nothing Nothing r <- upgrade False latestVersion next $ return r diff --git a/Database/Keys.hs b/Database/Keys.hs --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -132,10 +132,10 @@ let db = dbdir P. "db" dbexists <- liftIO $ R.doesPathExist db case dbexists of - True -> open db + True -> open db False False -> do initDb db SQL.createTables - open db + open db True where -- If permissions don't allow opening the database, and it's being -- opened for read, treat it as if it does not exist. @@ -143,9 +143,9 @@ | forwrite = throwM e | otherwise = return DbUnavailable - open db = do + open db dbisnew = do qh <- liftIO $ H.openDbQueue db SQL.containedTable - tc <- reconcileStaged qh + tc <- reconcileStaged dbisnew qh return $ DbOpen (qh, tc) {- Closes the database if it was open. Any writes will be flushed to it. @@ -260,8 +260,8 @@ - So when using getAssociatedFiles, have to make sure the file still - is an associated file. -} -reconcileStaged :: H.DbQueue -> Annex DbTablesChanged -reconcileStaged qh = ifM (Git.Config.isBare <$> gitRepo) +reconcileStaged :: Bool -> H.DbQueue -> Annex DbTablesChanged +reconcileStaged dbisnew qh = ifM (Git.Config.isBare <$> gitRepo) ( return mempty , do gitindex <- inRepo currentIndexFile @@ -384,7 +384,7 @@ Nothing -> return False send mdfeeder (Ref dstsha) $ \case Just key -> do - liftIO $ SQL.addAssociatedFile key + liftIO $ addassociatedfile key (asTopFilePath file) (SQL.WriteHandle qh) when (dstmode /= fmtTreeItemType TreeSymlink) $ @@ -496,6 +496,18 @@ -- takes less than half a second, so that seems about right. largediff :: Int largediff = 1000 + + -- When the database is known to have been newly created and empty + -- before reconcileStaged started, it is more efficient to use + -- newAssociatedFile. It's safe to use it here because this is run + -- with a lock held that blocks any other process that opens the + -- database, and when the database is newly created, there is no + -- existing process that has it open already. And it's not possible + -- for reconcileStaged to call this twice on the same filename with + -- two different keys. + addassociatedfile + | dbisnew = SQL.newAssociatedFile + | otherwise = SQL.addAssociatedFile {- Normally the keys database is updated incrementally when opened, - by reconcileStaged. Calling this explicitly allows running the diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -1,6 +1,6 @@ {- Sqlite database of information about Keys - - - Copyright 2015-2021 Joey Hess + - Copyright 2015-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -73,8 +73,8 @@ queueDb :: SqlPersistM () -> WriteHandle -> IO () queueDb a (WriteHandle h) = H.queueDb h checkcommit a where - -- commit queue after 1000 changes - checkcommit sz _lastcommittime = pure (sz > 1000) + -- commit queue after 10000 changes + checkcommit sz _lastcommittime = pure (sz > 10000) -- Insert the associated file. -- When the file was associated with a different key before, @@ -85,6 +85,15 @@ (FileKeyIndex af k) (Associated k af) [AssociatedFile =. af, AssociatedKey =. k] + where + af = SFilePath (getTopFilePath f) + +-- Faster than addAssociatedFile, but only safe to use when the file +-- was not associated with a different key before, as it does not delete +-- any old key. +newAssociatedFile :: Key -> TopFilePath -> WriteHandle -> IO () +newAssociatedFile k f = queueDb $ + void $ insert $ Associated k af where af = SFilePath (getTopFilePath f) diff --git a/Logs/File.hs b/Logs/File.hs --- a/Logs/File.hs +++ b/Logs/File.hs @@ -13,8 +13,10 @@ appendLogFile, modifyLogFile, streamLogFile, + streamLogFileUnsafe, checkLogFile, calcLogFile, + calcLogFileUnsafe, ) where import Annex.Common @@ -98,7 +100,12 @@ -- | Folds a function over lines of a log file to calculate a value. calcLogFile :: RawFilePath -> RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t -calcLogFile f lck start update = withSharedLock lck $ bracket setup cleanup go +calcLogFile f lck start update = + withSharedLock lck $ calcLogFileUnsafe f start update + +-- | Unsafe version that does not do locking. +calcLogFileUnsafe :: RawFilePath -> t -> (L.ByteString -> t -> t) -> Annex t +calcLogFileUnsafe f start update = bracket setup cleanup go where setup = liftIO $ tryWhenExists $ openFile f' ReadMode cleanup Nothing = noop @@ -125,7 +132,15 @@ -- is running. streamLogFile :: FilePath -> RawFilePath -> Annex () -> (String -> Annex ()) -> Annex () streamLogFile f lck finalizer processor = - withExclusiveLock lck $ bracketOnError setup cleanup go + withExclusiveLock lck $ do + streamLogFileUnsafe f finalizer processor + liftIO $ writeFile f "" + setAnnexFilePerm (toRawFilePath f) + +-- Unsafe version that does not do locking, and does not empty the file +-- at the end. +streamLogFileUnsafe :: FilePath -> Annex () -> (String -> Annex ()) -> Annex () +streamLogFileUnsafe f finalizer processor = bracketOnError setup cleanup go where setup = liftIO $ tryWhenExists $ openFile f ReadMode cleanup Nothing = noop @@ -135,8 +150,6 @@ mapM_ processor =<< liftIO (lines <$> hGetContents h) liftIO $ hClose h finalizer - liftIO $ writeFile f "" - setAnnexFilePerm (toRawFilePath f) createDirWhenNeeded :: RawFilePath -> Annex () -> Annex () createDirWhenNeeded f a = a `catchNonAsync` \_e -> do diff --git a/Logs/Restage.hs b/Logs/Restage.hs --- a/Logs/Restage.hs +++ b/Logs/Restage.hs @@ -13,9 +13,11 @@ import Git.FilePath import Logs.File import Utility.InodeCache +import Annex.LockFile import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L +import qualified Utility.RawFilePath as R -- | Log a file whose pointer needs to be restaged in git. -- The content of the file may not be a pointer, if it is populated with @@ -27,31 +29,61 @@ lckf <- fromRepo gitAnnexRestageLock appendLogFile logf lckf $ L.fromStrict $ formatRestageLog f ic --- | Streams the content of the restage log, and then empties the log at --- the end. +-- | Streams the content of the restage log. -- --- If the processor or finalizer is interrupted or throws an exception, --- the log file is left unchanged. +-- First, the content of the log file is moved to the restage.old file. +-- If that file already exists, the content is appended, otherwise it's +-- renamed to that. -- --- Locking is used to prevent new items being added to the log while this --- is running. +-- The log file is kept locked during that, but the lock is then +-- released. The processor may do something that itself needs to take the +-- lock, so it's important that the lock not be held while running it. +-- +-- The content of restage.old file is then streamed to the processor, +-- and then the finalizer is run, ending with emptying restage.old. +-- +-- If the processor or finalizer is interrupted or throws an exception, +-- restage.old is left populated to be processed later. streamRestageLog :: Annex () -> (TopFilePath -> InodeCache -> Annex ()) -> Annex () streamRestageLog finalizer processor = do logf <- fromRepo gitAnnexRestageLog + oldf <- fromRepo gitAnnexRestageLogOld + let oldf' = fromRawFilePath oldf lckf <- fromRepo gitAnnexRestageLock - streamLogFile (fromRawFilePath logf) lckf finalizer $ \l -> + + withExclusiveLock lckf $ liftIO $ + whenM (R.doesPathExist logf) $ + ifM (R.doesPathExist oldf) + ( do + h <- openFile oldf' AppendMode + hPutStr h =<< readFile (fromRawFilePath logf) + hClose h + liftIO $ removeWhenExistsWith R.removeLink logf + , moveFile logf oldf + ) + + streamLogFileUnsafe oldf' finalizer $ \l -> case parseRestageLog l of Just (f, ic) -> processor f ic Nothing -> noop + + liftIO $ removeWhenExistsWith R.removeLink oldf +-- | Calculate over both the current restage log, and also over the old +-- one if it had started to be processed but did not get finished due +-- to an interruption. calcRestageLog :: t -> ((TopFilePath, InodeCache) -> t -> t) -> Annex t calcRestageLog start update = do logf <- fromRepo gitAnnexRestageLog + oldf <- fromRepo gitAnnexRestageLogOld lckf <- fromRepo gitAnnexRestageLock - calcLogFile logf lckf start $ \l v -> - case parseRestageLog (decodeBL l) of - Just pl -> update pl v - Nothing -> v + withSharedLock lckf $ do + mid <- calcLogFileUnsafe logf start process + calcLogFileUnsafe oldf mid process + where + process l v = case parseRestageLog (decodeBL l) of + Just pl -> update pl v + Nothing -> v formatRestageLog :: TopFilePath -> InodeCache -> S.ByteString formatRestageLog f ic = encodeBS (showInodeCache ic) <> ":" <> getTopFilePath f diff --git a/Remote/S3.hs b/Remote/S3.hs --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -1,6 +1,6 @@ {- S3 remotes - - - Copyright 2011-2020 Joey Hess + - Copyright 2011-2022 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -156,7 +156,9 @@ signatureField :: RemoteConfigField signatureField = Accepted "signature" -newtype SignatureVersion = SignatureVersion Int +data SignatureVersion + = SignatureVersion Int + | Anonymous signatureVersionParser :: RemoteConfigField -> FieldDesc -> RemoteConfigFieldParser signatureVersionParser f fd = @@ -165,10 +167,17 @@ where go "v2" = Just (SignatureVersion 2) go "v4" = Just (SignatureVersion 4) + go "anonymous" = Just Anonymous go _ = Nothing defver = SignatureVersion 2 +isAnonymous :: ParsedRemoteConfig -> Bool +isAnonymous c = + case getRemoteConfigValue signatureField c of + Just Anonymous -> True + _ -> False + portField :: RemoteConfigField portField = Accepted "port" @@ -272,7 +281,9 @@ (c', encsetup) <- encryptionSetup (c `M.union` defaults) gc pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c' - c'' <- setRemoteCredPair ss encsetup pc gc (AWS.creds u) mcreds + c'' <- if isAnonymous pc + then pure c' + else setRemoteCredPair ss encsetup pc gc (AWS.creds u) mcreds pc' <- either giveup return . parseRemoteConfig c'' =<< configParser remote c'' info <- extractS3Info pc' @@ -286,7 +297,9 @@ showNote "Internet Archive mode" pc <- either giveup return . parseRemoteConfig c =<< configParser remote c - c' <- setRemoteCredPair ss noEncryptionUsed pc gc (AWS.creds u) mcreds + c' <- if isAnonymous pc + then pure c + else setRemoteCredPair ss noEncryptionUsed pc gc (AWS.creds u) mcreds -- Ensure user enters a valid bucket name, since -- this determines the name of the archive.org item. let validbucket = replace " " "-" $ map toLower $ @@ -402,19 +415,20 @@ - that is difficult. -} retrieve :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> Retriever retrieve hv r rs c info = fileRetriever' $ \f k p iv -> withS3Handle hv $ \case - (Just h) -> + Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case Left failreason -> do warning failreason giveup "cannot download content" Right loc -> retrieveHelper info h loc (fromRawFilePath f) p iv - Nothing -> + Left S3HandleNeedCreds -> getPublicWebUrls' (uuid r) rs info c k >>= \case Left failreason -> do warning failreason giveup "cannot download content" Right us -> unlessM (withUrlOptions $ downloadUrl False k p iv us (fromRawFilePath f)) $ giveup "failed to download content" + Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) retrieveHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> FilePath -> MeterUpdate -> Maybe IncrementalVerifier -> Annex () retrieveHelper info h loc f p iv = retrieveHelper' h f p iv $ @@ -449,12 +463,12 @@ checkKey :: S3HandleVar -> Remote -> RemoteStateHandle -> ParsedRemoteConfig -> S3Info -> CheckPresent checkKey hv r rs c info k = withS3Handle hv $ \case - Just h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case + Right h -> eitherS3VersionID info rs c k (T.pack $ bucketObject info k) >>= \case Left failreason -> do warning failreason giveup "cannot check content" Right loc -> checkKeyHelper info h loc - Nothing -> + Left S3HandleNeedCreds -> getPublicWebUrls' (uuid r) rs info c k >>= \case Left failreason -> do warning failreason @@ -463,6 +477,7 @@ let check u = withUrlOptions $ Url.checkBoth u (fromKey keySize k) anyM check us + Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) checkKeyHelper :: S3Info -> S3Handle -> (Either S3.Object S3VersionID) -> Annex Bool checkKeyHelper info h loc = checkKeyHelper' info h o limit @@ -485,8 +500,8 @@ storeExportS3' :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Maybe Magic -> FilePath -> Key -> ExportLocation -> MeterUpdate -> Annex (Maybe S3Etag, Maybe S3VersionID) storeExportS3' hv r rs info magic f k loc p = withS3Handle hv $ \case - Just h -> go h - Nothing -> giveup $ needS3Creds (uuid r) + Right h -> go h + Left pr -> giveupS3HandleProblem pr (uuid r) where go h = do let o = T.pack $ bucketExportLocation info loc @@ -497,45 +512,44 @@ retrieveExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> FilePath -> MeterUpdate -> Annex Verification retrieveExportS3 hv r info k loc f p = verifyKeyContentIncrementally AlwaysVerify k $ \iv -> withS3Handle hv $ \case - Just h -> retrieveHelper info h (Left (T.pack exportloc)) f p iv - Nothing -> case getPublicUrlMaker info of + Right h -> retrieveHelper info h (Left (T.pack exportloc)) f p iv + Left S3HandleNeedCreds -> case getPublicUrlMaker info of Just geturl -> either giveup return =<< Url.withUrlOptions (Url.download' p iv (geturl exportloc) f) Nothing -> giveup $ needS3Creds (uuid r) + Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) where exportloc = bucketExportLocation info loc removeExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> Annex () removeExportS3 hv r rs info k loc = withS3Handle hv $ \case - Just h -> do + Right h -> do checkVersioning info rs k liftIO $ runResourceT $ do S3.DeleteObjectResponse <- sendS3Handle h $ S3.DeleteObject (T.pack $ bucketExportLocation info loc) (bucket info) return () - Nothing -> giveup $ needS3Creds (uuid r) - where + Left p -> giveupS3HandleProblem p (uuid r) checkPresentExportS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> Annex Bool checkPresentExportS3 hv r info k loc = withS3Handle hv $ \case - Just h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc)) - Nothing -> case getPublicUrlMaker info of + Right h -> checkKeyHelper info h (Left (T.pack $ bucketExportLocation info loc)) + Left S3HandleNeedCreds -> case getPublicUrlMaker info of Just geturl -> withUrlOptions $ Url.checkBoth (geturl $ bucketExportLocation info loc) (fromKey keySize k) - Nothing -> do - warning $ needS3Creds (uuid r) - giveup "No S3 credentials configured" + Nothing -> giveupS3HandleProblem S3HandleNeedCreds (uuid r) + Left S3HandleAnonymousOldAws -> giveupS3HandleProblem S3HandleAnonymousOldAws (uuid r) -- S3 has no move primitive; copy and delete. renameExportS3 :: S3HandleVar -> Remote -> RemoteStateHandle -> S3Info -> Key -> ExportLocation -> ExportLocation -> Annex (Maybe ()) renameExportS3 hv r rs info k src dest = Just <$> go where go = withS3Handle hv $ \case - Just h -> do + Right h -> do checkVersioning info rs k go' h - Nothing -> giveup $ needS3Creds (uuid r) + Left p -> giveupS3HandleProblem p (uuid r) go' h = liftIO $ runResourceT $ do let co = S3.copyObject (bucket info) dstobject @@ -551,8 +565,8 @@ listImportableContentsS3 :: S3HandleVar -> Remote -> S3Info -> ParsedRemoteConfig -> Annex (Maybe (ImportableContentsChunkable Annex (ContentIdentifier, ByteSize))) listImportableContentsS3 hv r info c = withS3Handle hv $ \case - Nothing -> giveup $ needS3Creds (uuid r) - Just h -> Just <$> go h + Right h -> Just <$> go h + Left p -> giveupS3HandleProblem p (uuid r) where go h = do ic <- liftIO $ runResourceT $ extractFromResourceT =<< startlist h @@ -665,7 +679,7 @@ return (k, v) where go iv = withS3Handle hv $ \case - Just h -> do + Right h -> do rewritePreconditionException $ retrieveHelper' h dest p iv $ limitGetToContentIdentifier cid $ S3.getObject (bucket info) o @@ -677,7 +691,7 @@ setS3VersionID info rs k vid Left _ -> noop return k - Nothing -> giveup $ needS3Creds (uuid r) + Left pr -> giveupS3HandleProblem pr (uuid r) o = T.pack $ bucketExportLocation info loc retrieveExportWithContentIdentifierS3 _ _ _ _ _ [] _ _ _ = giveup "missing content identifier" @@ -726,12 +740,9 @@ checkPresentExportWithContentIdentifierS3 :: S3HandleVar -> Remote -> S3Info -> Key -> ExportLocation -> [ContentIdentifier] -> Annex Bool checkPresentExportWithContentIdentifierS3 hv r info _k loc knowncids = - withS3Handle hv $ \case - Just h -> flip anyM knowncids $ + withS3HandleOrFail (uuid r) hv $ \h -> + flip anyM knowncids $ checkKeyHelper' info h o . limitHeadToContentIdentifier - Nothing -> do - warning $ needS3Creds (uuid r) - giveup "No S3 credentials configured" where o = T.pack $ bucketExportLocation info loc @@ -841,24 +852,43 @@ -> ResourceT IO a sendS3Handle h r = AWS.pureAws (hawscfg h) (hs3cfg h) (hmanager h) r -type S3HandleVar = TVar (Either (Annex (Maybe S3Handle)) (Maybe S3Handle)) +type S3HandleVar = TVar (Either (Annex (Either S3HandleProblem S3Handle)) (Either S3HandleProblem S3Handle)) +data S3HandleProblem + = S3HandleNeedCreds + | S3HandleAnonymousOldAws + +giveupS3HandleProblem :: S3HandleProblem -> UUID -> Annex a +giveupS3HandleProblem S3HandleNeedCreds u = do + warning $ needS3Creds u + giveup "No S3 credentials configured" +giveupS3HandleProblem S3HandleAnonymousOldAws _ = + giveup "This S3 special remote is configured with signature=anonymous, but git-annex is buit with too old a version of the aws library to support that." + {- Prepares a S3Handle for later use. Does not connect to S3 or do anything - else expensive. -} mkS3HandleVar :: ParsedRemoteConfig -> RemoteGitConfig -> UUID -> Annex S3HandleVar -mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ do - mcreds <- getRemoteCredPair c gc (AWS.creds u) - case mcreds of - Just creds -> do - awscreds <- liftIO $ genCredentials creds - let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing - ou <- getUrlOptions - return $ Just $ S3Handle (httpManager ou) awscfg s3cfg - Nothing -> return Nothing +mkS3HandleVar c gc u = liftIO $ newTVarIO $ Left $ + if isAnonymous c + then +#if MIN_VERSION_aws(0,23,0) + go =<< liftIO AWS.anonymousCredentials +#else + return (Left S3HandleAnonymousOldAws) +#endif + else do + mcreds <- getRemoteCredPair c gc (AWS.creds u) + case mcreds of + Just creds -> go =<< liftIO (genCredentials creds) + Nothing -> return (Left S3HandleNeedCreds) where s3cfg = s3Configuration c + go awscreds = do + let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing + ou <- getUrlOptions + return $ Right $ S3Handle (httpManager ou) awscfg s3cfg -withS3Handle :: S3HandleVar -> (Maybe S3Handle -> Annex a) -> Annex a +withS3Handle :: S3HandleVar -> (Either S3HandleProblem S3Handle -> Annex a) -> Annex a withS3Handle hv a = liftIO (readTVarIO hv) >>= \case Right hdl -> a hdl Left mkhdl -> do @@ -868,10 +898,8 @@ withS3HandleOrFail :: UUID -> S3HandleVar -> (S3Handle -> Annex a) -> Annex a withS3HandleOrFail u hv a = withS3Handle hv $ \case - Just hdl -> a hdl - Nothing -> do - warning $ needS3Creds u - giveup "No S3 credentials configured" + Right hdl -> a hdl + Left p -> giveupS3HandleProblem p u needS3Creds :: UUID -> String needS3Creds u = missingCredPairFor "S3" (AWS.creds u) diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -92,7 +92,7 @@ optParser :: Parser TestOptions optParser = TestOptions - <$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty mempty))) + <$> snd (tastyParser (tests 1 False True (TestOptions mempty False False Nothing mempty False mempty))) <*> switch ( long "keep-failures" <> help "preserve repositories on test failure" @@ -111,6 +111,10 @@ <> help "run tests with a git config set" <> metavar "NAME=VALUE" )) + <*> switch + ( long "test-debug" + <> help "show debug messages for commands run by test suite" + ) <*> cmdParams "non-options are for internal use only" where parseconfigvalue s = case break (== '=') s of @@ -355,7 +359,15 @@ mk l = testGroup groupname (initTests : map adddep l) adddep = Test.Tasty.after AllSucceed (groupname ++ "." ++ initTestsName) groupname = "Repo Tests " ++ note - sep = sep' (replicate numparts []) + sep l = + -- Avoid separating into parts that contain less than + -- 5 tests each. Since the tests depend on the + -- initTests, this avoids spending too much work running + -- the initTests once per part. + let numparts' = if length l `div` numparts > 5 + then numparts + else length l `div` 5 + in sep' (replicate numparts' []) l sep' (p:ps) (l:ls) = sep' (ps++[l:p]) ls sep' ps [] = ps sep' [] _ = [] diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -65,11 +65,20 @@ -- Run a process. The output and stderr is captured, and is only -- displayed if the process does not return the expected value. +-- +-- In debug mode, the output is allowed to pass through. testProcess :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> String -> Assertion testProcess command params environ expectedret faildesc = do let p = (proc command params) { env = environ } - (transcript, ret) <- Utility.Process.Transcript.processTranscript' p Nothing - (expectedret ret) @? (faildesc ++ " failed (transcript follows)\n" ++ transcript) + debug <- testDebug . testOptions <$> getTestMode + if debug + then do + ret <- withCreateProcess p $ \_ _ _ pid -> + waitForProcess pid + (expectedret (ret == ExitSuccess)) @? (faildesc ++ " failed") + else do + (transcript, ret) <- Utility.Process.Transcript.processTranscript' p Nothing + (expectedret ret) @? (faildesc ++ " failed (transcript follows)\n" ++ transcript) -- Run git. (Do not use to run git-annex as the one being tested -- may not be in path.) @@ -98,7 +107,11 @@ git_annex'' :: (Bool -> Bool) -> String -> [String] -> Maybe [(String, String)] -> String -> Assertion git_annex'' expectedret command params environ faildesc = do pp <- Annex.Path.programPath - testProcess pp (command:params) environ expectedret faildesc + debug <- testDebug . testOptions <$> getTestMode + let params' = if debug + then "--debug":params + else params + testProcess pp (command:params') environ expectedret faildesc {- Runs git-annex and returns its standard output. -} git_annex_output :: String -> [String] -> IO String @@ -736,7 +749,12 @@ -- Make more parts than there are jobs, because some parts -- are larger, and this allows the smaller parts to be packed -- in more efficiently, speeding up the test suite overall. - numparts = numjobs * 2 + -- + -- When there is a pattern, splitting into parts will cause + -- extra work. + numparts = if haspattern + then 1 + else numjobs * 2 worker rs nvar a = do (n, m) <- atomically $ do @@ -801,15 +819,16 @@ , exitFailure ) - tastyopts = case lookupOption (tastyOptionSet opts) of + (haspattern, tastyopts) = case lookupOption (tastyOptionSet opts) of -- Work around limitation of tasty; when tests to run -- are limited to a pattern, it does not include their -- dependencies. So, add another pattern including the -- init tests, which are a dependency of most tests. TestPattern (Just p) -> - setOption (TestPattern (Just (TP.Or p (TP.ERE initTestsName)))) - (tastyOptionSet opts) - TestPattern Nothing -> tastyOptionSet opts + (True, setOption (TestPattern (Just (TP.Or p (TP.ERE initTestsName)))) + (tastyOptionSet opts)) + TestPattern Nothing -> + (False, tastyOptionSet opts) topLevelTestGroup :: [TestTree] -> TestTree topLevelTestGroup = testGroup "Tests" diff --git a/Types/Test.hs b/Types/Test.hs --- a/Types/Test.hs +++ b/Types/Test.hs @@ -19,6 +19,7 @@ , fakeSsh :: Bool , concurrentJobs :: Maybe Concurrency , testGitConfig :: [(ConfigKey, ConfigValue)] + , testDebug :: Bool , internalData :: CmdParams } diff --git a/Utility/DataUnits.hs b/Utility/DataUnits.hs --- a/Utility/DataUnits.hs +++ b/Utility/DataUnits.hs @@ -73,7 +73,9 @@ {- Storage units are (stupidly) powers of ten. -} storageUnits :: [Unit] storageUnits = - [ Unit (p 8) "YB" "yottabyte" + [ Unit (p 10) "QB" "quettabyte" + , Unit (p 9) "RB" "ronnabyte" + , Unit (p 8) "YB" "yottabyte" , Unit (p 7) "ZB" "zettabyte" , Unit (p 6) "EB" "exabyte" , Unit (p 5) "PB" "petabyte" diff --git a/Utility/LockFile/Windows.hs b/Utility/LockFile/Windows.hs --- a/Utility/LockFile/Windows.hs +++ b/Utility/LockFile/Windows.hs @@ -61,7 +61,7 @@ openLock :: ShareMode -> LockFile -> IO (Maybe LockHandle) openLock sharemode f = do f' <- convertToNativeNamespace f -#if MIN_VERSION_Win32(2,13,3) +#if MIN_VERSION_Win32(2,13,4) r <- tryNonAsync $ createFile_NoRetry f' gENERIC_READ sharemode security_attributes oPEN_ALWAYS fILE_ATTRIBUTE_NORMAL (maybePtr Nothing) 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 @@ -175,7 +175,8 @@ * `--cleanup` Removes the local and remote `synced/` branches, which were created - and pushed by `git-annex sync`. + and pushed by `git-annex sync`. This option prevents all other syncing + activities. This can come in handy when you've synced a change to remotes and now want to reset your master branch back before that change. So you diff --git a/doc/git-annex-test.mdwn b/doc/git-annex-test.mdwn --- a/doc/git-annex-test.mdwn +++ b/doc/git-annex-test.mdwn @@ -44,6 +44,16 @@ One valid use of this is to change a git configuration to a value that is planned to be the new default in a future version of git. +* `--test-debug` + + Normally output of commands run by the test suite is hidden, so even + when annex.debug or --debug is enabled, it will not be displayed. + This option makes the full output of commands run by the test suite be + displayed. It also makes the test suite run git-annex with --debug. + + It's a good idea to use `-J1` in combinaton with this, otherwise + the output of concurrent tests will be mixed together. + # SEE ALSO [[git-annex]](1) diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1719,8 +1719,8 @@ * `annex.youtube-dl-options` - Options to pass to youtube-dl when using it to find the url to download - for a video. + Options to pass to youtube-dl (or yt-dlp) when using it to find the url + to download for a video. Some options may break git-annex's integration with youtube-dl. For example, the --output option could cause it to store files somewhere @@ -1730,7 +1730,8 @@ * `annex.youtube-dl-command` - Command to run for youtube-dl. Default is "youtube-dl". + Command to run for youtube-dl. Default is to use "youtube-dl" or + if that is not available in the PATH, to use "yt-dlp". * `annex.aria-torrent-options` 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: 10.20221103 +Version: 10.20221212 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -416,7 +416,7 @@ if (os(windows)) Build-Depends: - Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.3.1), + Win32 ((>= 2.6.1.0 && < 2.12.0.0) || >= 2.13.4.0), setenv, process (>= 1.6.2.0), silently (>= 1.2.5.1)