diff --git a/Annex/Path.hs b/Annex/Path.hs --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -1,6 +1,6 @@ {- git-annex program path - - - Copyright 2013-2022 Joey Hess + - Copyright 2013-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -18,9 +18,11 @@ import Config.Files import Utility.Env import Annex.PidLock +import CmdLine.Multicall import qualified Annex import System.Environment (getExecutablePath, getArgs, getProgName) +import qualified Data.Map as M {- A fully qualified path to the currently running git-annex program. - @@ -33,23 +35,35 @@ - getExecutablePath. It sets GIT_ANNEX_DIR to the location of the - standalone build directory, and there are wrapper scripts for git-annex - and git-annex-shell in that directory. + - + - When the currently running program is not git-annex, but is instead eg + - git-annex-shell or git-remote-annex, this finds a git-annex program + - instead. -} programPath :: IO FilePath programPath = go =<< getEnv "GIT_ANNEX_DIR" where go (Just dir) = do - name <- getProgName + name <- reqgitannex <$> getProgName return (dir name) go Nothing = do - exe <- getExecutablePath + name <- getProgName + exe <- if isgitannex name + then getExecutablePath + else pure "git-annex" p <- if isAbsolute exe then return exe else fromMaybe exe <$> readProgramFile maybe cannotFindProgram return =<< searchPath p + reqgitannex name + | isgitannex name = name + | otherwise = "git-annex" + isgitannex = flip M.notMember otherMulticallCommands + {- Returns the path for git-annex that is recorded in the programFile. -} readProgramFile :: IO (Maybe FilePath) -readProgramFile = do +readProgramFile = catchDefaultIO Nothing $ do programfile <- programFile headMaybe . lines <$> readFile programfile diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -45,6 +45,7 @@ import Utility.Tuple import Utility.Metered import qualified Utility.RawFilePath as R +import Git.FilePath import Data.Time.Clock import qualified Data.Set as S @@ -319,15 +320,19 @@ (LinkChange (Just key)) checksmall change - | not annexdotfiles && dotfile f = - return (Right change) - | otherwise = - ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f) - ( return (Left change) - , return (Right change) - ) + | not annexdotfiles = do + topfile <- liftAnnex $ + getTopFilePath <$> inRepo (toTopFilePath f) + if dotfile topfile + then return (Right change) + else checkmatcher + | otherwise = checkmatcher where f = toRawFilePath (changeFile change) + checkmatcher = ifM (liftAnnex $ checkFileMatcher NoLiveUpdate largefilematcher f) + ( return (Left change) + , return (Right change) + ) addsmall [] = noop addsmall toadd = liftAnnex $ void $ tryIO $ diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,35 @@ +git-annex (10.20241202) upstream; urgency=medium + + * add: Consistently treat files in a dotdir as dotfiles, even + when ran inside that dotdir. + * add: When adding a dotfile as a non-large file, mention that it's a + dotfile. + * p2phttp: Added --directory option which serves multiple git-annex + repositories located inside a directory. + * When remote.name.annexUrl is an annex+http(s) url, that + uses the same hostname as remote.name.url, which is itself a http(s) + url, they are assumed to share a username and password. This avoids + unnecessary duplicate password prompts. + * git-remote-annex: Fix a reversion introduced in version 10.20241031 + that broke cloning from a special remote. + * git-remote-annex: Fix cloning from a special remote on a crippled + filesystem. + * git-remote-annex: Fix buggy behavior when annex.stalldetection is + configured. + * git-remote-annex: Require git version 2.31 or newer, since old + ones had a buggy git bundle command. + * S3: Support versioning=yes with a readonly bucket. + (Needs aws-0.24.3) + * S3: Send git-annex or other configured User-Agent. + (Needs aws-0.24.3) + * S3: Fix infinite loop and memory blowup when importing from an + unversioned S3 bucket that is large enough to need pagination. + * S3: Use significantly less memory when importing from a + versioned S3 bucket. + * vpop: Only update state after successful checkout. + + -- Joey Hess Mon, 02 Dec 2024 12:31:08 -0400 + git-annex (10.20241031) upstream; urgency=medium * Sped up proxied downloads from special remotes, by streaming. diff --git a/CmdLine/GitAnnex/Options.hs b/CmdLine/GitAnnex/Options.hs --- a/CmdLine/GitAnnex/Options.hs +++ b/CmdLine/GitAnnex/Options.hs @@ -511,14 +511,18 @@ -- action in `allowConcurrentOutput`. jobsOption :: [AnnexOption] jobsOption = - [ annexOption (setAnnexState . setConcurrency . ConcurrencyCmdLine) $ - option (maybeReader parseConcurrency) - ( long "jobs" <> short 'J' - <> metavar (paramNumber `paramOr` "cpus") - <> help "enable concurrent jobs" - <> hidden - ) + [ annexOption (setAnnexState . setConcurrency . ConcurrencyCmdLine) + jobsOptionParser ] + +jobsOptionParser :: Parser Concurrency +jobsOptionParser = + option (maybeReader parseConcurrency) + ( long "jobs" <> short 'J' + <> metavar (paramNumber `paramOr` "cpus") + <> help "enable concurrent jobs" + <> hidden + ) timeLimitOption :: [AnnexOption] timeLimitOption = diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -48,6 +48,7 @@ import Annex.UUID import Annex.Content import Annex.Perms +import Annex.Tmp import Annex.SpecialRemote.Config import Remote.List import Remote.List.Util @@ -69,6 +70,8 @@ run :: [String] -> IO () run (remotename:url:[]) = do + unlessM Git.Bundle.versionSupported $ + giveup "git-remote-annex needs a newer version of git" repo <- getRepo state <- Annex.new repo Annex.eval state $ @@ -82,7 +85,7 @@ case parseSpecialRemoteNameUrl remotename u of Right src -> checkallowed src >>= run' u Left e -> giveup e -run (_remotename:[]) = giveup "remote url not configured" +run (remotename:[]) = giveup $ "remote url not configured for " ++ remotename run _ = giveup "expected remote name and url parameters" run' :: String -> SpecialRemoteConfig -> Annex () @@ -719,13 +722,14 @@ -- directory. The content of manifests is not stable, and so -- it needs to re-download it fresh every time, and the object -- file should not be stored locally. - gettotmp dl = withTmpFile "GITMANIFEST" $ \tmp tmph -> do - liftIO $ hClose tmph - _ <- dl tmp - b <- liftIO (B.readFile tmp) - case parseManifest b of - Right m -> Just <$> verifyManifest rmt m - Left err -> giveup err + gettotmp dl = withOtherTmp $ \othertmp -> + withTmpFileIn (fromRawFilePath othertmp) "GITMANIFEST" $ \tmp tmph -> do + liftIO $ hClose tmph + _ <- dl tmp + b <- liftIO (B.readFile tmp) + case parseManifest b of + Right m -> Just <$> verifyManifest rmt m + Left err -> giveup err getexport _ [] = return Nothing getexport mk (loc:locs) = @@ -1127,7 +1131,7 @@ -- If the git-annex branch did not exist when this command started, -- it was created empty by this command, and this command has avoided -- making any other commits to it, writing any temporary annex branch --- changes to thre alternateJournal, which can now be discarded. +-- changes to the alternateJournal, which can now be discarded. -- -- If nothing else has written to the branch while this command was running, -- the branch will be deleted. That allows for the git-annex branch that is @@ -1150,6 +1154,11 @@ -- does not contain any hooks. Since initialization installs -- hooks, have to work around that by not initializing, and -- delete the git bundle objects. +-- +-- Similarly, when on a crippled filesystem, doing initialization would +-- involve checking out an adjusted branch. But git clone wants to do its +-- own checkout. So no initialization is done then, and the git bundle +-- objects are deleted. cleanupInitialization :: StartAnnexBranch -> FilePath -> Annex () cleanupInitialization sab alternatejournaldir = void $ tryNonAsync $ do liftIO $ mapM_ removeFile =<< dirContents alternatejournaldir @@ -1171,7 +1180,7 @@ Nothing -> return () Just _ -> void $ tryNonAsync $ inRepo $ Git.Branch.delete Annex.Branch.fullname - ifM (Annex.Branch.hasSibling <&&> nonbuggygitversion) + ifM (Annex.Branch.hasSibling <&&> nonbuggygitversion <&&> notcrippledfilesystem) ( do autoInitialize' (pure True) startupAnnex remoteList differences <- allDifferences <$> recordedDifferences @@ -1187,6 +1196,8 @@ GitBundleKey -> lockContentForRemoval k noop removeAnnex _ -> noop void $ liftIO $ tryIO $ removeDirectory (decodeBS annexobjectdir) + + notcrippledfilesystem = not <$> probeCrippledFileSystem nonbuggygitversion = liftIO $ flip notElem buggygitversions <$> Git.Version.installed diff --git a/CmdLine/Multicall.hs b/CmdLine/Multicall.hs new file mode 100644 --- /dev/null +++ b/CmdLine/Multicall.hs @@ -0,0 +1,28 @@ +{- git-annex multicall binary + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +module CmdLine.Multicall where + +import qualified Data.Map as M + +-- Commands besides git-annex that can be run by the multicall binary. +-- +-- The reason git-annex itself is not included here is because the program +-- can be renamed to any other name than these and will behave the same as +-- git-annex. +data OtherMultiCallCommand + = GitAnnexShell + | GitRemoteAnnex + | GitRemoteTorAnnex + +otherMulticallCommands :: M.Map String OtherMultiCallCommand +otherMulticallCommands = M.fromList + [ ("git-annex-shell", GitAnnexShell) + , ("git-remote-annex", GitRemoteAnnex) + , ("git-remote-tor-annex", GitRemoteTorAnnex) + ] + diff --git a/Command/Add.hs b/Command/Add.hs --- a/Command/Add.hs +++ b/Command/Add.hs @@ -94,17 +94,21 @@ addunlockedmatcher <- addUnlockedMatcher annexdotfiles <- getGitConfigVal annexDotFiles let gofile includingsmall (si, file) = case largeFilesOverride o of - Nothing -> ifM (pure (annexdotfiles || not (dotfile file)) - <&&> (checkFileMatcher NoLiveUpdate largematcher file - <||> Annex.getRead Annex.force)) - ( start dr si file addunlockedmatcher - , if includingsmall - then ifM (annexAddSmallFiles <$> Annex.getGitConfig) - ( startSmall dr si file - , stop - ) - else stop - ) + Nothing -> do + isdotfile <- if annexdotfiles + then pure False + else dotfile . getTopFilePath + <$> inRepo (toTopFilePath file) + islarge <- checkFileMatcher NoLiveUpdate largematcher file + <||> Annex.getRead Annex.force + if (not isdotfile && islarge) + then start dr si file addunlockedmatcher + else if includingsmall + then ifM (annexAddSmallFiles <$> Annex.getGitConfig) + ( startSmall isdotfile dr si file + , stop + ) + else stop Just True -> start dr si file addunlockedmatcher Just False -> startSmallOverridden dr si file case batchOption o of @@ -136,17 +140,18 @@ dr = dryRunOption o {- Pass file off to git-add. -} -startSmall :: DryRun -> SeekInput -> RawFilePath -> CommandStart -startSmall dr si file = +startSmall :: Bool -> DryRun -> SeekInput -> RawFilePath -> CommandStart +startSmall isdotfile dr si file = liftIO (catchMaybeIO $ R.getSymbolicLinkStatus file) >>= \case Just s -> starting "add" (ActionItemTreeFile file) si $ - addSmall dr file s + addSmall isdotfile dr file s Nothing -> stop -addSmall :: DryRun -> RawFilePath -> FileStatus -> CommandPerform -addSmall dr file s = do - showNote "non-large file; adding content to git repository" +addSmall :: Bool -> DryRun -> RawFilePath -> FileStatus -> CommandPerform +addSmall isdotfile dr file s = do + showNote $ (if isdotfile then "dotfile" else "non-large file") + <> "; adding content to git repository" skipWhenDryRun dr $ next $ addFile Small file s startSmallOverridden :: DryRun -> SeekInput -> RawFilePath -> CommandStart diff --git a/Command/AddUrl.hs b/Command/AddUrl.hs --- a/Command/AddUrl.hs +++ b/Command/AddUrl.hs @@ -519,7 +519,7 @@ -- than the work tree file. liftIO $ moveFile file tmp go - else Command.Add.addSmall (DryRun False) file s + else Command.Add.addSmall False (DryRun False) file s >>= maybe noop void where go = do diff --git a/Command/Import.hs b/Command/Import.hs --- a/Command/Import.hs +++ b/Command/Import.hs @@ -261,7 +261,7 @@ >>= maybe stop (\addedk -> next $ Command.Add.cleanup addedk True) - , Command.Add.addSmall (DryRun False) destfile s + , Command.Add.addSmall False (DryRun False) destfile s ) notoverwriting why = do warning $ "not overwriting existing " <> QuotedPath destfile <> " " <> UnquotedString why diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs --- a/Command/P2PHttp.hs +++ b/Command/P2PHttp.hs @@ -11,11 +11,16 @@ module Command.P2PHttp where -import Command +import Command hiding (jobsOption) import P2P.Http.Server import P2P.Http.Url import qualified P2P.Protocol as P2P import Utility.Env +import Annex.UUID +import qualified Git +import qualified Git.Construct +import qualified Annex +import Types.Concurrency import Servant import qualified Network.Wai.Handler.Warp as Warp @@ -23,12 +28,14 @@ import Network.Socket (PortNumber) import qualified Data.Map as M import Data.String +import Control.Concurrent.STM cmd :: Command -cmd = noMessages $ withAnnexOptions [jobsOption] $ - command "p2phttp" SectionPlumbing - "communicate in P2P protocol over http" - paramNothing (seek <$$> optParser) +cmd = noMessages $ dontCheck repoExists $ + noRepo (startIO <$$> optParser) $ + command "p2phttp" SectionPlumbing + "communicate in P2P protocol over http" + paramNothing (startAnnex <$$> optParser) data Options = Options { portOption :: Maybe PortNumber @@ -43,7 +50,9 @@ , unauthNoLockingOption :: Bool , wideOpenOption :: Bool , proxyConnectionsOption :: Maybe Integer + , jobsOption :: Maybe Concurrency , clusterJobsOption :: Maybe Int + , directoryOption :: [FilePath] } optParser :: CmdParamsDesc -> Parser Options @@ -96,32 +105,80 @@ ( long "proxyconnections" <> metavar paramNumber <> help "maximum number of idle connections when proxying" )) + <*> optional jobsOptionParser <*> optional (option auto ( long "clusterjobs" <> metavar paramNumber <> help "number of concurrent node accesses per connection" )) + <*> many (strOption + ( long "directory" <> metavar paramPath + <> help "serve repositories in subdirectories of a directory" + )) -seek :: Options -> CommandSeek -seek o = getAnnexWorkerPool $ \workerpool -> - withP2PConnections workerpool - (fromMaybe 1 $ proxyConnectionsOption o) - (fromMaybe 1 $ clusterJobsOption o) - (go workerpool) - where - go workerpool acquireconn = liftIO $ do +startAnnex :: Options -> Annex () +startAnnex o + | null (directoryOption o) = ifM ((/=) NoUUID <$> getUUID) + ( do + authenv <- liftIO getAuthEnv + st <- mkServerState o authenv + liftIO $ runServer o st + -- Run in a git repository that is not a git-annex repository. + , liftIO $ startIO o + ) + | otherwise = liftIO $ startIO o + +startIO :: Options -> IO () +startIO o + | null (directoryOption o) = + giveup "Use the --directory option to specify which git-annex repositories to serve." + | otherwise = do authenv <- getAuthEnv - st <- mkP2PHttpServerState acquireconn workerpool $ - mkGetServerMode authenv o + st <- mkst authenv mempty + runServer o st + where + mkst authenv oldst = do + repos <- findRepos o + sts <- forM repos $ \r -> do + strd <- Annex.new r + Annex.eval strd (mkstannex authenv oldst) + return (mconcat sts) + { updateRepos = updaterepos authenv + } + + mkstannex authenv oldst = do + u <- getUUID + if u == NoUUID + then return mempty + else case M.lookup u (servedRepos oldst) of + Nothing -> mkServerState o authenv + Just old -> return $ P2PHttpServerState + { servedRepos = M.singleton u old + , serverShutdownCleanup = mempty + , updateRepos = mempty + } + + updaterepos authenv oldst = do + newst <- mkst authenv oldst + return $ newst + { serverShutdownCleanup = + serverShutdownCleanup newst + <> serverShutdownCleanup oldst + } + +runServer :: Options -> P2PHttpServerState -> IO () +runServer o mst = go `finally` serverShutdownCleanup mst + where + go = do let settings = Warp.setPort port $ Warp.setHost host $ Warp.defaultSettings + mstv <- newTMVarIO mst case (certFileOption o, privateKeyFileOption o) of - (Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp st) + (Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp mstv) (Just certfile, Just privatekeyfile) -> do let tlssettings = Warp.tlsSettingsChain certfile (chainFileOption o) privatekeyfile - Warp.runTLS tlssettings settings (p2pHttpApp st) + Warp.runTLS tlssettings settings (p2pHttpApp mstv) _ -> giveup "You must use both --certfile and --privatekeyfile options to enable HTTPS." - port = maybe (fromIntegral defaultP2PHttpProtocolPort) fromIntegral @@ -131,6 +188,15 @@ fromString (bindOption o) +mkServerState :: Options -> M.Map Auth P2P.ServerMode -> Annex P2PHttpServerState +mkServerState o authenv = + withAnnexWorkerPool (jobsOption o) $ + mkP2PHttpServerState + (mkGetServerMode authenv o) + return + (fromMaybe 1 $ proxyConnectionsOption o) + (fromMaybe 1 $ clusterJobsOption o) + mkGetServerMode :: M.Map Auth P2P.ServerMode -> Options -> GetServerMode mkGetServerMode _ o _ Nothing | wideOpenOption o = ServerMode @@ -197,3 +263,11 @@ case M.lookup user permmap of Nothing -> (auth, P2P.ServeReadWrite) Just perms -> (auth, perms) + +findRepos :: Options -> IO [Git.Repo] +findRepos o = do + files <- map toRawFilePath . concat + <$> mapM dirContents (directoryOption o) + map Git.Construct.newFrom . catMaybes + <$> mapM Git.Construct.checkForRepo files + diff --git a/Command/Smudge.hs b/Command/Smudge.hs --- a/Command/Smudge.hs +++ b/Command/Smudge.hs @@ -239,12 +239,14 @@ , checkunchanged checkwasannexed ) where - checkmatcher d - | dotfile file = ifM (getGitConfigVal annexDotFiles) - ( go - , d - ) - | otherwise = go + checkmatcher d = do + topfile <- getTopFilePath <$> inRepo (toTopFilePath file) + if dotfile topfile + then ifM (getGitConfigVal annexDotFiles) + ( go + , d + ) + else go where go = do matcher <- largeFilesMatcher diff --git a/Command/VPop.hs b/Command/VPop.hs --- a/Command/VPop.hs +++ b/Command/VPop.hs @@ -28,22 +28,29 @@ where go Nothing = giveup "Not in a view." go (Just (v, madj)) = starting "vpop" ai si $ do - removeView v - (oldvs, vs) <- splitAt (num - 1) . filter (sameparentbranch v) + (oldvs, vs) <- splitAt (num - 1) + . filter (sameparentbranch v) + . filter (/= v) <$> recentViews - mapM_ removeView oldvs - case vs of - (oldv:_) -> next $ do + let removeview = mapM_ removeView (v : oldvs) + ok <- case vs of + (oldv:_) -> do showOutput checkoutViewBranch oldv madj (\v' madj' -> return (branchView v' madj')) - _ -> next $ do + _ -> do showOutput inRepo $ Git.Command.runBool [ Param "checkout" , Param $ Git.fromRef $ Git.Ref.base $ viewParentBranch v ] + if ok + then + next $ do + removeview + return True + else next $ return False sameparentbranch a b = viewParentBranch a == viewParentBranch b num = fromMaybe 1 $ readish =<< headMaybe ps diff --git a/Git/Bundle.hs b/Git/Bundle.hs --- a/Git/Bundle.hs +++ b/Git/Bundle.hs @@ -12,9 +12,15 @@ import Common import Git import Git.Command +import qualified Git.Version import Data.Char (ord) import qualified Data.ByteString.Char8 as S8 + +-- Older versions of git had a git bundle command that sometimes omitted +-- refs, and that did not properly support --stdin. +versionSupported :: IO Bool +versionSupported = not <$> Git.Version.older "2.31" listHeads :: FilePath -> Repo -> IO [(Sha, Ref)] listHeads bundle repo = map gen . S8.lines <$> diff --git a/P2P/Http/Client.hs b/P2P/Http/Client.hs --- a/P2P/Http/Client.hs +++ b/P2P/Http/Client.hs @@ -24,13 +24,13 @@ import Utility.Metered import Utility.FileSize import Types.NumCopies - +import Types.Remote import Annex.Common +import qualified Git #ifdef WITH_SERVANT import qualified Annex import Annex.UUID import Annex.Url -import Types.Remote import P2P.Http import P2P.Http.Url import Annex.Concurrent @@ -83,8 +83,19 @@ -> (String -> Annex a) -> ClientAction a -> Annex (Maybe a) +p2pHttpClientVersions allowedversion rmt fallback clientaction = do + rmtrepo <- getRepo rmt + p2pHttpClientVersions' allowedversion rmt rmtrepo fallback clientaction + +p2pHttpClientVersions' + :: (ProtocolVersion -> Bool) + -> Remote + -> Git.Repo + -> (String -> Annex a) + -> ClientAction a + -> Annex (Maybe a) #ifdef WITH_SERVANT -p2pHttpClientVersions allowedversion rmt fallback clientaction = +p2pHttpClientVersions' allowedversion rmt rmtrepo fallback clientaction = case p2pHttpBaseUrl <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of Nothing -> error "internal" Just baseurl -> do @@ -139,9 +150,13 @@ ++ " " ++ decodeBS (statusMessage (responseStatusCode resp)) - credentialbaseurl = case p2pHttpUrlString <$> remoteAnnexP2PHttpUrl (gitconfig rmt) of + credentialbaseurl = case remoteAnnexP2PHttpUrl (gitconfig rmt) of + Just p2phttpurl + | isP2PHttpSameHost p2phttpurl rmtrepo -> + Git.repoLocation rmtrepo + | otherwise -> + p2pHttpUrlString p2phttpurl Nothing -> error "internal" - Just url -> url credauth cred = do ba <- Git.credentialBasicAuth cred @@ -159,7 +174,7 @@ M.insert (Git.CredentialBaseURL credentialbaseurl) cred cc Nothing -> noop #else -p2pHttpClientVersions _ _ fallback () = Just <$> fallback +p2pHttpClientVersions' _ _ _ fallback () = Just <$> fallback "This remote uses an annex+http url, but this version of git-annex is not built with support for that." #endif @@ -420,7 +435,7 @@ _ :<|> _ :<|> v4 :<|> v3 :<|> v2 :<|> v1 :<|> v0 :<|> _ = client p2pHttpAPI #else -clientPut _ _ _ _ _ _ _ = () +clientPut _ _ _ _ _ _ _ _ = () #endif clientPutOffset diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs --- a/P2P/Http/Server.hs +++ b/P2P/Http/Server.hs @@ -45,10 +45,10 @@ import System.IO.Unsafe import Data.Either -p2pHttpApp :: P2PHttpServerState -> Application +p2pHttpApp :: TMVar P2PHttpServerState -> Application p2pHttpApp = serve p2pHttpAPI . serveP2pHttp -serveP2pHttp :: P2PHttpServerState -> Server P2PHttpAPI +serveP2pHttp :: TMVar P2PHttpServerState -> Server P2PHttpAPI serveP2pHttp st = serveGet st :<|> serveGet st @@ -91,7 +91,7 @@ :<|> serveGetGeneric st serveGetGeneric - :: P2PHttpServerState + :: TMVar P2PHttpServerState -> B64UUID ServerSide -> B64Key -> Maybe (B64UUID ClientSide) @@ -109,7 +109,7 @@ serveGet :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -120,8 +120,8 @@ -> IsSecure -> Maybe Auth -> Handler (Headers '[DataLengthHeader] (S.SourceT IO B.ByteString)) -serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do - conn <- getP2PConnection apiver st cu su bypass sec auth ReadAction id +serveGet mst su apiver (B64Key k) cu bypass baf startat sec auth = do + (conn, st) <- getP2PConnection apiver mst cu su bypass sec auth ReadAction id bsv <- liftIO newEmptyTMVarIO endv <- liftIO newEmptyTMVarIO validityv <- liftIO newEmptyTMVarIO @@ -222,7 +222,7 @@ serveCheckPresent :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -233,14 +233,14 @@ -> Handler CheckPresentResult serveCheckPresent st su apiver (B64Key k) cu bypass sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth ReadAction id - $ \conn -> liftIO $ proxyClientNetProto conn $ checkPresent k + $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ checkPresent k case res of Right b -> return (CheckPresentResult b) Left err -> throwError $ err500 { errBody = encodeBL err } serveRemove :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> (RemoveResultPlus -> t) -> B64UUID ServerSide -> v @@ -252,7 +252,7 @@ -> Handler t serveRemove st resultmangle su apiver (B64Key k) cu bypass sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction id - $ \conn -> + $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ remove Nothing k case res of (Right b, plusuuids) -> return $ resultmangle $ @@ -262,7 +262,7 @@ serveRemoveBefore :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -274,7 +274,7 @@ -> Handler RemoveResultPlus serveRemoveBefore st su apiver (B64Key k) cu bypass (Timestamp ts) sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth RemoveAction id - $ \conn -> + $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ removeBeforeRemoteEndTime ts k case res of @@ -285,7 +285,7 @@ serveGetTimestamp :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> B64UUID ServerSide -> v -> B64UUID ClientSide @@ -295,7 +295,7 @@ -> Handler GetTimestampResult serveGetTimestamp st su apiver cu bypass sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth ReadAction id - $ \conn -> + $ \(conn, _) -> liftIO $ proxyClientNetProto conn getTimestamp case res of Right ts -> return $ GetTimestampResult (Timestamp ts) @@ -304,7 +304,7 @@ servePut :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> (PutResultPlus -> t) -> B64UUID ServerSide -> v @@ -319,28 +319,28 @@ -> IsSecure -> Maybe Auth -> Handler t -servePut st resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = do - res <- withP2PConnection' apiver st cu su bypass sec auth WriteAction +servePut mst resultmangle su apiver (Just True) _ k cu bypass baf _ _ sec auth = do + res <- withP2PConnection' apiver mst cu su bypass sec auth WriteAction (\cst -> cst { connectionWaitVar = False }) (liftIO . protoaction) servePutResult resultmangle res where - protoaction conn = servePutAction st conn k baf $ \_offset -> do + protoaction conn = servePutAction conn k baf $ \_offset -> do net $ sendMessage DATA_PRESENT checkSuccessPlus -servePut st resultmangle su apiver _datapresent (DataLength len) k cu bypass baf moffset stream sec auth = do +servePut mst resultmangle su apiver _datapresent (DataLength len) k cu bypass baf moffset stream sec auth = do validityv <- liftIO newEmptyTMVarIO let validitycheck = local $ runValidityCheck $ liftIO $ atomically $ readTMVar validityv tooshortv <- liftIO newEmptyTMVarIO content <- liftIO $ S.unSourceT stream (gather validityv tooshortv) - res <- withP2PConnection' apiver st cu su bypass sec auth WriteAction - (\cst -> cst { connectionWaitVar = False }) $ \conn -> do + res <- withP2PConnection' apiver mst cu su bypass sec auth WriteAction + (\cst -> cst { connectionWaitVar = False }) $ \(conn, st) -> do liftIO $ void $ async $ checktooshort conn tooshortv - liftIO (protoaction conn content validitycheck) + liftIO (protoaction conn st content validitycheck) servePutResult resultmangle res where - protoaction conn content validitycheck = - servePutAction st conn k baf $ \offset' -> + protoaction conn st content validitycheck = + servePutAction (conn, st) k baf $ \offset' -> let offsetdelta = offset' - offset in case compare offset' offset of EQ -> sendContent' nullMeterUpdate (Len len) @@ -396,13 +396,12 @@ closeP2PConnection conn servePutAction - :: P2PHttpServerState - -> P2PConnectionPair + :: (P2PConnectionPair, PerRepoServerState) -> B64Key -> Maybe B64FilePath -> (P2P.Protocol.Offset -> Proto (Maybe [UUID])) -> IO (Either SomeException (Either ProtoFailure (Maybe [UUID]))) -servePutAction st conn (B64Key k) baf a = inAnnexWorker st $ +servePutAction (conn, st) (B64Key k) baf a = inAnnexWorker st $ enteringStage (TransferStage Download) $ runFullProto (clientRunState conn) (clientP2PConnection conn) $ put' k af a @@ -422,7 +421,7 @@ servePut' :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> (PutResultPlus -> t) -> B64UUID ServerSide -> v @@ -440,7 +439,7 @@ servePutOffset :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> (PutOffsetResultPlus -> t) -> B64UUID ServerSide -> v @@ -452,7 +451,7 @@ -> Handler t servePutOffset st resultmangle su apiver (B64Key k) cu bypass sec auth = do res <- withP2PConnection apiver st cu su bypass sec auth WriteAction - (\cst -> cst { connectionWaitVar = False }) $ \conn -> + (\cst -> cst { connectionWaitVar = False }) $ \(conn, _) -> liftIO $ proxyClientNetProto conn $ getPutOffset k af case res of Right offset -> return $ resultmangle $ @@ -464,7 +463,7 @@ serveLockContent :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> B64UUID ServerSide -> v -> B64Key @@ -473,8 +472,8 @@ -> IsSecure -> Maybe Auth -> Handler LockResult -serveLockContent st su apiver (B64Key k) cu bypass sec auth = do - conn <- getP2PConnection apiver st cu su bypass sec auth LockAction id +serveLockContent mst su apiver (B64Key k) cu bypass sec auth = do + (conn, st) <- getP2PConnection apiver mst cu su bypass sec auth LockAction id let lock = do lockresv <- newEmptyTMVarIO unlockv <- newEmptyTMVarIO @@ -501,7 +500,7 @@ serveKeepLocked :: APIVersion v - => P2PHttpServerState + => TMVar P2PHttpServerState -> B64UUID ServerSide -> v -> LockID @@ -513,15 +512,15 @@ -> Maybe KeepAlive -> S.SourceT IO UnlockRequest -> Handler LockResult -serveKeepLocked st _su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do - checkAuthActionClass st sec auth LockAction $ \_ -> do +serveKeepLocked mst su _apiver lckid _cu _bypass sec auth _ _ unlockrequeststream = do + checkAuthActionClass mst su sec auth LockAction $ \st _ -> do liftIO $ keepingLocked lckid st - _ <- liftIO $ S.unSourceT unlockrequeststream go + _ <- liftIO $ S.unSourceT unlockrequeststream (go st) return (LockResult False Nothing) where - go S.Stop = dropLock lckid st - go (S.Error _err) = dropLock lckid st - go (S.Skip s) = go s - go (S.Effect ms) = ms >>= go - go (S.Yield (UnlockRequest False) s) = go s - go (S.Yield (UnlockRequest True) _) = dropLock lckid st + go st S.Stop = dropLock lckid st + go st (S.Error _err) = dropLock lckid st + go st (S.Skip s) = go st s + go st (S.Effect ms) = ms >>= go st + go st (S.Yield (UnlockRequest False) s) = go st s + go st (S.Yield (UnlockRequest True) _) = dropLock lckid st diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -26,6 +26,8 @@ import Types.WorkerPool import Annex.WorkerPool import Annex.BranchState +import Annex.Concurrent +import Types.Concurrency import Types.Cluster import CmdLine.Action (startConcurrency) import Utility.ThreadScheduler @@ -42,8 +44,37 @@ import qualified Data.Set as S import Control.Concurrent.Async import Data.Time.Clock.POSIX +import qualified Data.Semigroup as Sem +import Prelude data P2PHttpServerState = P2PHttpServerState + { servedRepos :: M.Map UUID PerRepoServerState + , serverShutdownCleanup :: IO () + , updateRepos :: UpdateRepos + } + +type UpdateRepos = P2PHttpServerState -> IO P2PHttpServerState + +instance Monoid P2PHttpServerState where + mempty = P2PHttpServerState + { servedRepos = mempty + , serverShutdownCleanup = noop + , updateRepos = const mempty + } + +instance Sem.Semigroup P2PHttpServerState where + a <> b = P2PHttpServerState + { servedRepos = servedRepos a <> servedRepos b + , serverShutdownCleanup = do + serverShutdownCleanup a + serverShutdownCleanup b + , updateRepos = \st -> do + a' <- updateRepos a st + b' <- updateRepos b st + return (a' <> b') + } + +data PerRepoServerState = PerRepoServerState { acquireP2PConnection :: AcquireP2PConnection , annexWorkerPool :: AnnexWorkerPool , getServerMode :: GetServerMode @@ -62,8 +93,8 @@ } | CannotServeRequests -mkP2PHttpServerState :: AcquireP2PConnection -> AnnexWorkerPool -> GetServerMode -> IO P2PHttpServerState -mkP2PHttpServerState acquireconn annexworkerpool getservermode = P2PHttpServerState +mkPerRepoServerState :: AcquireP2PConnection -> AnnexWorkerPool -> GetServerMode -> IO PerRepoServerState +mkPerRepoServerState acquireconn annexworkerpool getservermode = PerRepoServerState <$> pure acquireconn <*> pure annexworkerpool <*> pure getservermode @@ -75,7 +106,7 @@ withP2PConnection :: APIVersion v => v - -> P2PHttpServerState + -> TMVar P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -83,10 +114,10 @@ -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> (P2PConnectionPair -> Handler (Either ProtoFailure a)) + -> ((P2PConnectionPair, PerRepoServerState) -> Handler (Either ProtoFailure a)) -> Handler a -withP2PConnection apiver st cu su bypass sec auth actionclass fconnparams connaction = - withP2PConnection' apiver st cu su bypass sec auth actionclass fconnparams connaction' +withP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams connaction = + withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams connaction' where connaction' conn = connaction conn >>= \case Right r -> return r @@ -96,7 +127,7 @@ withP2PConnection' :: APIVersion v => v - -> P2PHttpServerState + -> TMVar P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -104,17 +135,17 @@ -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> (P2PConnectionPair -> Handler a) + -> ((P2PConnectionPair, PerRepoServerState) -> Handler a) -> Handler a -withP2PConnection' apiver st cu su bypass sec auth actionclass fconnparams connaction = do - conn <- getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams - connaction conn +withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams connaction = do + (conn, st) <- getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams + connaction (conn, st) `finally` liftIO (releaseP2PConnection conn) getP2PConnection :: APIVersion v => v - -> P2PHttpServerState + -> TMVar P2PHttpServerState -> B64UUID ClientSide -> B64UUID ServerSide -> [B64UUID Bypass] @@ -122,16 +153,16 @@ -> Maybe Auth -> ActionClass -> (ConnectionParams -> ConnectionParams) - -> Handler P2PConnectionPair -getP2PConnection apiver st cu su bypass sec auth actionclass fconnparams = - checkAuthActionClass st sec auth actionclass go + -> Handler (P2PConnectionPair, PerRepoServerState) +getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams = + checkAuthActionClass mst su sec auth actionclass go where - go servermode = liftIO (acquireP2PConnection st cp) >>= \case + go st servermode = liftIO (acquireP2PConnection st cp) >>= \case Left (ConnectionFailed err) -> throwError err502 { errBody = encodeBL err } Left TooManyConnections -> throwError err503 - Right v -> return v + Right v -> return (v, st) where cp = fconnparams $ ConnectionParams { connectionProtocolVersion = protocolVersion apiver @@ -142,30 +173,51 @@ , connectionWaitVar = True } +getPerRepoServerState :: TMVar P2PHttpServerState -> B64UUID ServerSide -> IO (Maybe PerRepoServerState) +getPerRepoServerState mstv su = do + mst <- atomically $ readTMVar mstv + case lookupst mst of + Just st -> return (Just st) + Nothing -> do + mst' <- atomically $ takeTMVar mstv + mst'' <- updateRepos mst' mst' + debug "P2P.Http" $ + "Rescanned for repositories, now serving UUIDs: " + ++ show (M.keys (servedRepos mst'')) + atomically $ putTMVar mstv mst'' + return $ lookupst mst'' + where + lookupst mst = M.lookup (fromB64UUID su) (servedRepos mst) + checkAuthActionClass - :: P2PHttpServerState + :: TMVar P2PHttpServerState + -> B64UUID ServerSide -> IsSecure -> Maybe Auth -> ActionClass - -> (P2P.ServerMode -> Handler a) + -> (PerRepoServerState -> P2P.ServerMode -> Handler a) -> Handler a -checkAuthActionClass st sec auth actionclass go = - case (sm, actionclass) of +checkAuthActionClass mstv su sec auth actionclass go = + liftIO (getPerRepoServerState mstv su) >>= \case + Just st -> select st + Nothing -> throwError err404 + where + select st = case (sm, actionclass) of (ServerMode { serverMode = P2P.ServeReadWrite }, _) -> - go P2P.ServeReadWrite + go st P2P.ServeReadWrite (ServerMode { unauthenticatedLockingAllowed = True }, LockAction) -> - go P2P.ServeReadOnly + go st P2P.ServeReadOnly (ServerMode { serverMode = P2P.ServeAppendOnly }, RemoveAction) -> throwError $ forbiddenWithoutAuth sm (ServerMode { serverMode = P2P.ServeAppendOnly }, _) -> - go P2P.ServeAppendOnly + go st P2P.ServeAppendOnly (ServerMode { serverMode = P2P.ServeReadOnly }, ReadAction) -> - go P2P.ServeReadOnly + go st P2P.ServeReadOnly (ServerMode { serverMode = P2P.ServeReadOnly }, _) -> throwError $ forbiddenWithoutAuth sm (CannotServeRequests, _) -> throwError basicAuthRequired - where - sm = getServerMode st sec auth + where + sm = getServerMode st sec auth forbiddenAction :: ServerError forbiddenAction = err403 @@ -204,13 +256,14 @@ = ConnectionParams -> IO (Either ConnectionProblem P2PConnectionPair) -withP2PConnections - :: AnnexWorkerPool +mkP2PHttpServerState + :: GetServerMode + -> UpdateRepos -> ProxyConnectionPoolSize -> ClusterConcurrency - -> (AcquireP2PConnection -> Annex a) - -> Annex a -withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do + -> AnnexWorkerPool + -> Annex P2PHttpServerState +mkP2PHttpServerState getservermode updaterepos proxyconnectionpoolsize clusterconcurrency workerpool = do enableInteractiveBranchAccess myuuid <- getUUID myproxies <- M.lookup myuuid <$> getProxies @@ -223,7 +276,13 @@ let endit = do liftIO $ atomically $ putTMVar endv () liftIO $ wait asyncservicer - a (acquireconn reqv) `finally` endit + let servinguuids = myuuid : map proxyRemoteUUID (maybe [] S.toList myproxies) + st <- liftIO $ mkPerRepoServerState (acquireconn reqv) workerpool getservermode + return $ P2PHttpServerState + { servedRepos = M.fromList $ zip servinguuids (repeat st) + , serverShutdownCleanup = endit + , updateRepos = updaterepos + } where acquireconn reqv connparams = do respvar <- newEmptyTMVarIO @@ -487,13 +546,13 @@ wait locktid return Nothing -storeLock :: LockID -> Locker -> P2PHttpServerState -> IO () +storeLock :: LockID -> Locker -> PerRepoServerState -> IO () storeLock lckid locker st = atomically $ do m <- takeTMVar (openLocks st) let !m' = M.insert lckid locker m putTMVar (openLocks st) m' -keepingLocked :: LockID -> P2PHttpServerState -> IO () +keepingLocked :: LockID -> PerRepoServerState -> IO () keepingLocked lckid st = do m <- atomically $ readTMVar (openLocks st) case M.lookup lckid m of @@ -502,7 +561,7 @@ atomically $ void $ tryPutTMVar (lockerTimeoutDisable locker) () -dropLock :: LockID -> P2PHttpServerState -> IO () +dropLock :: LockID -> PerRepoServerState -> IO () dropLock lckid st = do v <- atomically $ do m <- takeTMVar (openLocks st) @@ -520,13 +579,15 @@ Nothing -> return () Just locker -> wait (lockerThread locker) -getAnnexWorkerPool :: (AnnexWorkerPool -> Annex a) -> Annex a -getAnnexWorkerPool a = startConcurrency transferStages $ - Annex.getState Annex.workers >>= \case - Nothing -> giveup "Use -Jn or set annex.jobs to configure the number of worker threads." - Just wp -> a wp +withAnnexWorkerPool :: (Maybe Concurrency) -> (AnnexWorkerPool -> Annex a) -> Annex a +withAnnexWorkerPool mc a = do + maybe noop (setConcurrency . ConcurrencyCmdLine) mc + startConcurrency transferStages $ + Annex.getState Annex.workers >>= \case + Nothing -> giveup "Use -Jn or set annex.jobs to configure the number of worker threads." + Just wp -> a wp -inAnnexWorker :: P2PHttpServerState -> Annex a -> IO (Either SomeException a) +inAnnexWorker :: PerRepoServerState -> Annex a -> IO (Either SomeException a) inAnnexWorker st = inAnnexWorker' (annexWorkerPool st) inAnnexWorker' :: AnnexWorkerPool -> Annex a -> IO (Either SomeException a) diff --git a/P2P/Http/Url.hs b/P2P/Http/Url.hs --- a/P2P/Http/Url.hs +++ b/P2P/Http/Url.hs @@ -15,6 +15,9 @@ import System.FilePath.Posix as P import Servant.Client (BaseUrl(..), Scheme(..)) import Text.Read +import Data.Char +import qualified Git +import qualified Git.Url #endif defaultP2PHttpProtocolPort :: Int @@ -78,4 +81,16 @@ unavailableP2PHttpUrl p = p #ifdef WITH_SERVANT { p2pHttpBaseUrl = (p2pHttpBaseUrl p) { baseUrlHost = "!dne!" } } +#endif + +#ifdef WITH_SERVANT +-- When a p2phttp url is on the same host as a git repo, which also uses +-- http, the same username+password is assumed to be used for both. +isP2PHttpSameHost :: P2PHttpUrl -> Git.Repo -> Bool +isP2PHttpSameHost u repo + | not (Git.repoIsHttp repo) = False + | otherwise = + Just (map toLower $ baseUrlHost (p2pHttpBaseUrl u)) + == + (map toLower <$> (Git.Url.host repo)) #endif 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-2023 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -27,6 +27,8 @@ import qualified System.FilePath.Posix as Posix import Data.Char import Data.String +import Data.Maybe +import Data.Time.Clock import Network.Socket (HostName) import Network.HTTP.Conduit (Manager) import Network.HTTP.Client (responseStatus, responseBody, RequestBody(..)) @@ -36,7 +38,6 @@ import Control.Monad.Catch import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar -import Data.Maybe import Annex.Common import Types.Remote @@ -63,8 +64,8 @@ import Utility.DataUnits import Annex.Content import qualified Annex.Url as Url -import Utility.Url (extractFromResourceT) -import Annex.Url (getUrlOptions, withUrlOptions, UrlOptions(..)) +import Utility.Url (extractFromResourceT, UserAgent) +import Annex.Url (getUserAgent, getUrlOptions, withUrlOptions, UrlOptions(..)) import Utility.Env import Annex.Verify @@ -581,7 +582,7 @@ | versioning info = do rsp <- sendS3Handle h $ S3.getBucketObjectVersions (bucket info) - continuelistversioned h [] rsp + continuelistversioned Nothing h [] rsp | otherwise = do rsp <- sendS3Handle h $ (S3.getBucket (bucket info)) @@ -589,17 +590,31 @@ continuelistunversioned h [] rsp continuelistunversioned h l rsp - | S3.gbrIsTruncated rsp = do - rsp' <- sendS3Handle h $ - (S3.getBucket (bucket info)) - { S3.gbMarker = S3.gbrNextMarker rsp - , S3.gbPrefix = fileprefix - } - continuelistunversioned h (rsp:l) rsp' - | otherwise = return $ - mkImportableContentsUnversioned info (reverse (rsp:l)) - - continuelistversioned h l rsp + | S3.gbrIsTruncated rsp = + let marker = + S3.gbrNextMarker rsp + <|> + (S3.objectKey <$> lastMaybe (S3.gbrContents rsp)) + in case marker of + Just _ -> do + rsp' <- sendS3Handle h $ + (S3.getBucket (bucket info)) + { S3.gbMarker = marker + , S3.gbPrefix = fileprefix + } + l' <- extractFromResourceT $ + extractunversioned rsp + continuelistunversioned h (l':l) rsp' + Nothing -> nomore + | otherwise = nomore + where + nomore = do + l' <- extractFromResourceT $ + extractunversioned rsp + return $ mkImportableContentsUnversioned + (reverse (l':l)) + + continuelistversioned reuse h l rsp | S3.gbovrIsTruncated rsp = do rsp' <- sendS3Handle h $ (S3.getBucketObjectVersions (bucket info)) @@ -607,65 +622,84 @@ , S3.gbovVersionIdMarker = S3.gbovrNextVersionIdMarker rsp , S3.gbovPrefix = fileprefix } - continuelistversioned h (rsp:l) rsp' - | otherwise = return $ - mkImportableContentsVersioned info (reverse (rsp:l)) + (l', reuse') <- extractFromResourceT $ + extractversioned reuse rsp + continuelistversioned reuse' h (l':l) rsp' + | otherwise = do + (l', _) <- extractFromResourceT $ + extractversioned reuse rsp + return $ mkImportableContentsVersioned + (reverse (l':l)) -mkImportableContentsUnversioned :: S3Info -> [S3.GetBucketResponse] -> ImportableContents (ContentIdentifier, ByteSize) -mkImportableContentsUnversioned info l = ImportableContents - { importableContents = concatMap (mapMaybe extract . S3.gbrContents) l + extractunversioned = mapMaybe extractunversioned' . S3.gbrContents + extractunversioned' oi = do + loc <- bucketImportLocation info $ + T.unpack $ S3.objectKey oi + let sz = S3.objectSize oi + let cid = mkS3UnversionedContentIdentifier $ S3.objectETag oi + return (loc, (cid, sz)) + + extractversioned reuse = extractversioned' reuse . S3.gbovrContents + extractversioned' reuse [] = ([], reuse) + extractversioned' reuse (x:xs) = case extractversioned'' reuse x of + Just (v, reuse') -> + let (l, reuse'') = extractversioned' reuse' xs + in (v:l, reuse'') + Nothing -> extractversioned' reuse xs + extractversioned'' reuse ovi@(S3.ObjectVersion {}) = do + loc <- bucketImportLocation info $ + T.unpack $ S3.oviKey ovi + -- Avoid storing the same filename in memory repeatedly. + let loc' = case reuse of + Just reuseloc | reuseloc == loc -> reuseloc + _ -> loc + let sz = S3.oviSize ovi + let cid = mkS3VersionedContentIdentifier' ovi + return (((loc', (cid, sz)), S3.oviLastModified ovi), Just loc') + extractversioned'' _ (S3.DeleteMarker {}) = Nothing + +mkImportableContentsUnversioned :: [[(ImportLocation, (ContentIdentifier, ByteSize))]] -> ImportableContents (ContentIdentifier, ByteSize) +mkImportableContentsUnversioned l = ImportableContents + { importableContents = concat l , importableHistory = [] } - where - extract oi = do - loc <- bucketImportLocation info $ - T.unpack $ S3.objectKey oi - let sz = S3.objectSize oi - let cid = mkS3UnversionedContentIdentifier $ S3.objectETag oi - return (loc, (cid, sz)) -mkImportableContentsVersioned :: S3Info -> [S3.GetBucketObjectVersionsResponse] -> ImportableContents (ContentIdentifier, ByteSize) -mkImportableContentsVersioned info = build . groupfiles +mkImportableContentsVersioned :: [[((ImportLocation, (ContentIdentifier, ByteSize)), UTCTime)]] -> ImportableContents (ContentIdentifier, ByteSize) +mkImportableContentsVersioned = build . groupfiles where + ovilastmodified = snd + loc = fst . fst + build [] = ImportableContents [] [] build l = let (l', v) = latestversion l in ImportableContents - { importableContents = mapMaybe extract v + { importableContents = map fst v , importableHistory = case build l' of ImportableContents [] [] -> [] h -> [h] } - - extract ovi@(S3.ObjectVersion {}) = do - loc <- bucketImportLocation info $ - T.unpack $ S3.oviKey ovi - let sz = S3.oviSize ovi - let cid = mkS3VersionedContentIdentifier' ovi - return (loc, (cid, sz)) - extract (S3.DeleteMarker {}) = Nothing -- group files so all versions of a file are in a sublist, -- with the newest first. S3 uses such an order, so it's just a -- matter of breaking up the response list into sublists. - groupfiles = groupBy (\a b -> S3.oviKey a == S3.oviKey b) - . concatMap S3.gbovrContents + groupfiles = groupBy (\a b -> loc a == loc b) . concat latestversion [] = ([], []) latestversion ([]:rest) = latestversion rest latestversion l@((first:_old):remainder) = - go (S3.oviLastModified first) [first] remainder + go (ovilastmodified first) [first] remainder where go mtime c [] = (removemostrecent mtime l, reverse c) go mtime c ([]:rest) = go mtime c rest go mtime c ((latest:_old):rest) = - let !mtime' = max mtime (S3.oviLastModified latest) + let !mtime' = max mtime (ovilastmodified latest) in go mtime' (latest:c) rest removemostrecent _ [] = [] removemostrecent mtime ([]:rest) = removemostrecent mtime rest removemostrecent mtime (i@(curr:old):rest) - | S3.oviLastModified curr == mtime = + | ovilastmodified curr == mtime = old : removemostrecent mtime rest | otherwise = i : removemostrecent mtime rest @@ -885,10 +919,11 @@ 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 + ua <- getUserAgent + let awscfg = AWS.Configuration AWS.Timestamp awscreds debugMapper Nothing + let s3cfg = s3Configuration (Just ua) c return $ Right $ S3Handle (httpManager ou) awscfg s3cfg withS3Handle :: S3HandleVar -> (Either S3HandleProblem S3Handle -> Annex a) -> Annex a @@ -907,13 +942,20 @@ needS3Creds :: UUID -> String needS3Creds u = missingCredPairFor "S3" (AWS.creds u) -s3Configuration :: ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery -s3Configuration c = cfg +s3Configuration :: Maybe UserAgent -> ParsedRemoteConfig -> S3.S3Configuration AWS.NormalQuery +#if MIN_VERSION_aws(0,24,3) +s3Configuration ua c = cfg +#else +s3Configuration _ua c = cfg +#endif { S3.s3Port = port , S3.s3RequestStyle = case getRemoteConfigValue requeststyleField c of Just "path" -> S3.PathStyle Just s -> giveup $ "bad S3 requeststyle value: " ++ s Nothing -> S3.s3RequestStyle cfg +#if MIN_VERSION_aws(0,24,3) + , S3.s3UserAgent = T.pack <$> ua +#endif } where h = fromJust $ getRemoteConfigValue hostField c @@ -1157,7 +1199,7 @@ , Just ("versioning", if versioning info then "yes" else "no") ] where - s3c = s3Configuration c + s3c = s3Configuration Nothing c showstorageclass (S3.OtherStorageClass t) = T.unpack t showstorageclass sc = show sc @@ -1341,11 +1383,24 @@ where enableversioning b = do #if MIN_VERSION_aws(0,21,1) - showAction "enabling bucket versioning" + showAction "checking bucket versioning" hdl <- mkS3HandleVar c gc u + let setversioning = S3.putBucketVersioning b S3.VersioningEnabled withS3HandleOrFail u hdl $ \h -> - void $ liftIO $ runResourceT $ sendS3Handle h $ - S3.putBucketVersioning b S3.VersioningEnabled +#if MIN_VERSION_aws(0,24,3) + liftIO $ runResourceT $ + tryS3 (sendS3Handle h setversioning) >>= \case + Right _ -> return () + Left err -> do + res <- sendS3Handle h $ + S3.getBucketVersioning b + case S3.gbvVersioning res of + Just S3.VersioningEnabled -> return () + _ -> giveup $ "This bucket does not have versioning enabled, and enabling it failed: " + ++ T.unpack (S3.s3ErrorMessage err) +#else + void $ liftIO $ runResourceT $ sendS3Handle h setversioning +#endif #else showLongNote $ unlines [ "This version of git-annex cannot auto-enable S3 bucket versioning." diff --git a/Test.hs b/Test.hs --- a/Test.hs +++ b/Test.hs @@ -1,6 +1,6 @@ {- git-annex test suite - - - Copyright 2010-2023 Joey Hess + - Copyright 2010-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -37,6 +37,7 @@ import qualified Git.Ref import qualified Git.LsTree import qualified Git.FilePath +import qualified Git.Bundle import qualified Annex.Locations #ifndef mingw32_HOST_OS import qualified Types.GitConfig @@ -282,6 +283,8 @@ [ testCase "add dup" test_add_dup , testCase "add extras" test_add_extras , testCase "add moved link" test_add_moved + , testCase "git-remote-annex" (test_git_remote_annex False) + , testCase "git-remote-annex exporttree" (test_git_remote_annex True) , testCase "readonly remote" test_readonly_remote , testCase "ignore deleted files" test_ignore_deleted_files , testCase "metadata" test_metadata @@ -421,6 +424,39 @@ annexed_present wormannexedfile checkbackend wormannexedfile backendWORM +test_git_remote_annex :: Bool -> Assertion +#ifndef mingw32_HOST_OS +test_git_remote_annex exporttree + | exporttree = + runtest ["importtree=yes", "exporttree=yes"] $ + git_annex "export" ["master", "--to=foo"] "export" + | otherwise = + runtest [] $ + git_annex "copy" ["--to=foo"] "copy" + where + runtest cfg populate = whenM Git.Bundle.versionSupported $ + intmpclonerepo $ do + let cfg' = ["type=directory", "encryption=none", "directory=dir"] ++ cfg + createDirectory "dir" + git_annex "initremote" ("foo":("uuid=" ++ diruuid):cfg') "initremote" + git_annex "get" [] "get failed" + () <- populate + git "config" ["remote.foo.url", "annex::"] "git config" + -- git push does not always propagate nonzero exit + -- status from git-remote-annex, so remember the + -- transcript and display it if clone fails + pushtranscript <- testProcess' "git" ["push", "foo", "master", "git-annex"] Nothing (== True) (const True) "git push" + git "clone" ["annex::"++diruuid++"?"++intercalate "&" cfg', "clonedir"] + ("git clone from special remote (after git push with output: " ++ pushtranscript ++ ")") + inpath "clonedir" $ + git_annex "get" [annexedfile] "get from origin special remote" + diruuid="89ddefa4-a04c-11ef-87b5-e880882a4f98" +#else +test_git_remote_annex exporttree = + -- git-remote-annex is not currently installed on Windows + return () +#endif + test_add_moved :: Assertion test_add_moved = intmpclonerepo $ do git_annex "get" [annexedfile] "get failed" @@ -440,10 +476,10 @@ withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do pair r1 r2 - indir r1 $ do + intopdir r1 $ do git_annex "get" [annexedfile] "get failed in first repo" make_readonly r1 - indir r2 $ do + intopdir r2 $ do git_annex "sync" ["r1", "--no-push", "--no-content"] "sync with readonly repo" git_annex "get" [annexedfile, "--from", "r1"] "get from readonly repo" git "remote" ["rm", "origin"] "remote rm" @@ -1234,7 +1270,7 @@ withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> withtmpclonerepo $ \r3 -> do - forM_ [r1, r2, r3] $ \r -> indir r $ do + forM_ [r1, r2, r3] $ \r -> intopdir r $ do when (r /= r1) $ git "remote" ["add", "r1", "../" ++ r1] "remote add" when (r /= r2) $ @@ -1243,11 +1279,11 @@ git "remote" ["add", "r3", "../" ++ r3] "remote add" git_annex "get" [annexedfile] "get" git "remote" ["rm", "origin"] "remote rm" - forM_ [r3, r2, r1] $ \r -> indir r $ + forM_ [r3, r2, r1] $ \r -> intopdir r $ git_annex "sync" ["--no-content"] ("sync in " ++ r) - forM_ [r3, r2] $ \r -> indir r $ + forM_ [r3, r2] $ \r -> intopdir r $ git_annex "drop" ["--force", annexedfile] ("drop in " ++ r) - indir r1 $ do + intopdir r1 $ do git_annex "sync" ["--no-content"] "sync in r1" git_annex_expectoutput "find" ["--in", "r3"] [] {- This was the bug. The sync @@ -1261,19 +1297,19 @@ test_conflict_resolution_movein_regression = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do let rname r = if r == r1 then "r1" else "r2" - forM_ [r1, r2] $ \r -> indir r $ do + forM_ [r1, r2] $ \r -> intopdir r $ do {- Get all files, see check below. -} git_annex "get" [] "get" disconnectOrigin pair r1 r2 - forM_ [r1, r2] $ \r -> indir r $ do + forM_ [r1, r2] $ \r -> intopdir r $ do {- Set up a conflict. -} let newcontent = content annexedfile ++ rname r git_annex "unlock" [annexedfile] "unlock" writecontent annexedfile newcontent {- Sync twice in r1 so it gets the conflict resolution - update from r2 -} - forM_ [r1, r2, r1] $ \r -> indir r $ + forM_ [r1, r2, r1] $ \r -> intopdir r $ git_annex "sync" ["--force", "--no-content"] ("sync in " ++ rname r) {- After the sync, it should be possible to get all - files. This includes both sides of the conflict, @@ -1281,7 +1317,7 @@ - - The bug caused one repo to be missing the content - of the file that had been put in it. -} - forM_ [r1, r2] $ \r -> indir r $ do + forM_ [r1, r2] $ \r -> intopdir r $ do git_annex "get" [] ("get all files after merge conflict resolution in " ++ rname r) {- Simple case of conflict resolution; 2 different versions of annexed @@ -1290,18 +1326,18 @@ test_conflict_resolution = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do - indir r1 $ do + intopdir r1 $ do disconnectOrigin writecontent conflictor "conflictor1" add_annex conflictor "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" - indir r2 $ do + intopdir r2 $ do disconnectOrigin writecontent conflictor "conflictor2" add_annex conflictor "add conflicter" git_annex "sync" ["--no-content"] "sync in r2" pair r1 r2 - forM_ [r1,r2,r1] $ \r -> indir r $ + forM_ [r1,r2,r1] $ \r -> intopdir r $ git_annex "sync" ["--no-content"] "sync" checkmerge "r1" r1 checkmerge "r2" r2 @@ -1314,7 +1350,7 @@ length v == 2 @? (what ++ " not exactly 2 variant files in: " ++ show l) conflictor `notElem` l @? ("conflictor still present after conflict resolution") - indir d $ do + intopdir d $ do git_annex "get" v "get" git_annex_expectoutput "find" v v @@ -1323,12 +1359,12 @@ test_conflict_resolution_adjusted_branch = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> whenM (adjustedbranchsupported r2) $ do - indir r1 $ do + intopdir r1 $ do disconnectOrigin writecontent conflictor "conflictor1" add_annex conflictor "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" - indir r2 $ do + intopdir r2 $ do disconnectOrigin writecontent conflictor "conflictor2" add_annex conflictor "add conflicter" @@ -1338,7 +1374,7 @@ -- filesystem. So, --force it. git_annex "adjust" ["--unlock", "--force"] "adjust" pair r1 r2 - forM_ [r1,r2,r1] $ \r -> indir r $ + forM_ [r1,r2,r1] $ \r -> intopdir r $ git_annex "sync" ["--no-content"] "sync" checkmerge "r1" r1 checkmerge "r2" r2 @@ -1351,7 +1387,7 @@ length v == 2 @? (what ++ " not exactly 2 variant files in: " ++ show l) conflictor `notElem` l @? ("conflictor still present after conflict resolution") - indir d $ do + intopdir d $ do git_annex "get" v "get" git_annex_expectoutput "find" v v @@ -1364,12 +1400,12 @@ where check inr1 = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do - indir r1 $ do + intopdir r1 $ do disconnectOrigin writecontent conflictor "conflictor" add_annex conflictor "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" - indir r2 $ do + intopdir r2 $ do disconnectOrigin createDirectory conflictor writecontent subfile "subfile" @@ -1377,7 +1413,7 @@ git_annex "sync" ["--no-content"] "sync in r2" pair r1 r2 let l = if inr1 then [r1, r2] else [r2, r1] - forM_ l $ \r -> indir r $ + forM_ l $ \r -> intopdir r $ git_annex "sync" ["--no-content"] "sync in mixed conflict" checkmerge "r1" r1 checkmerge "r2" r2 @@ -1392,7 +1428,7 @@ @? (what ++ " conflictor variant file missing in: " ++ show l ) length v == 1 @? (what ++ " too many variant files in: " ++ show v) - indir d $ do + intopdir d $ do git_annex "get" (conflictor:v) ("get in " ++ what) git_annex_expectoutput "find" [conflictor] [fromRawFilePath (Git.FilePath.toInternalGitPath (toRawFilePath subfile))] git_annex_expectoutput "find" v v @@ -1406,23 +1442,23 @@ where check inr1 = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do - indir r1 $ do + intopdir r1 $ do disconnectOrigin writecontent conflictor "conflictor" add_annex conflictor "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" - indir r2 $ + intopdir r2 $ disconnectOrigin pair r1 r2 - indir r2 $ do + intopdir r2 $ do git_annex "sync" ["--no-content"] "sync in r2" git_annex "get" [conflictor] "get conflictor" git_annex "unlock" [conflictor] "unlock conflictor" writecontent conflictor "newconflictor" - indir r1 $ + intopdir r1 $ removeWhenExistsWith R.removeLink (toRawFilePath conflictor) let l = if inr1 then [r1, r2, r1] else [r2, r1, r2] - forM_ l $ \r -> indir r $ + forM_ l $ \r -> intopdir r $ git_annex "sync" ["--no-content"] "sync" checkmerge "r1" r1 checkmerge "r2" r2 @@ -1446,12 +1482,12 @@ where check inr1 = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do - indir r1 $ do + intopdir r1 $ do disconnectOrigin writecontent conflictor "conflictor" add_annex conflictor "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" - indir r2 $ do + intopdir r2 $ do disconnectOrigin writecontent conflictor nonannexed_content git "config" @@ -1462,7 +1498,7 @@ git_annex "sync" ["--no-content"] "sync in r2" pair r1 r2 let l = if inr1 then [r1, r2] else [r2, r1] - forM_ l $ \r -> indir r $ + forM_ l $ \r -> intopdir r $ git_annex "sync" ["--no-content"] "sync" checkmerge "r1" r1 checkmerge "r2" r2 @@ -1496,19 +1532,19 @@ check inr1 = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> whenM (checkRepo (Types.coreSymlinks <$> Annex.getGitConfig) r1) $ do - indir r1 $ do + intopdir r1 $ do disconnectOrigin writecontent conflictor "conflictor" add_annex conflictor "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" - indir r2 $ do + intopdir r2 $ do disconnectOrigin R.createSymbolicLink (toRawFilePath symlinktarget) (toRawFilePath "conflictor") git "add" [conflictor] "git add conflictor" git_annex "sync" ["--no-content"] "sync in r2" pair r1 r2 let l = if inr1 then [r1, r2] else [r2, r1] - forM_ l $ \r -> indir r $ + forM_ l $ \r -> intopdir r $ git_annex "sync" ["--no-content"] "sync" checkmerge "r1" r1 checkmerge "r2" r2 @@ -1543,19 +1579,19 @@ where check remoteconflictor = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do - indir r1 $ do + intopdir r1 $ do disconnectOrigin createDirectoryIfMissing True (fromRawFilePath (parentDir (toRawFilePath remoteconflictor))) writecontent remoteconflictor annexedcontent add_annex conflictor "add remoteconflicter" git_annex "sync" ["--no-content"] "sync in r1" - indir r2 $ do + intopdir r2 $ do disconnectOrigin writecontent conflictor localcontent pair r1 r2 -- this case is intentionally not handled -- since the user can recover on their own easily - indir r2 $ git_annex_shouldfail "sync" ["--no-content"] "sync should not succeed" + intopdir r2 $ git_annex_shouldfail "sync" ["--no-content"] "sync should not succeed" conflictor = "conflictor" localcontent = "local" annexedcontent = "annexed" @@ -1568,18 +1604,18 @@ withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> withtmpclonerepo $ \r3 -> do - indir r1 $ do + intopdir r1 $ do writecontent conflictor "conflictor" git_annex "add" [conflictor] "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" check_is_link conflictor "r1" - indir r2 $ do + intopdir r2 $ do createDirectory conflictor writecontent (conflictor "subfile") "subfile" git_annex "add" [conflictor] "add conflicter" git_annex "sync" ["--no-content"] "sync in r2" check_is_link (conflictor "subfile") "r2" - indir r3 $ do + intopdir r3 $ do writecontent conflictor "conflictor" git_annex "add" [conflictor] "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" @@ -1599,26 +1635,26 @@ test_mixed_lock_conflict_resolution = withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do - indir r1 $ do + intopdir r1 $ do disconnectOrigin writecontent conflictor "conflictor" git_annex "add" [conflictor] "add conflicter" git_annex "sync" ["--no-content"] "sync in r1" - indir r2 $ do + intopdir r2 $ do disconnectOrigin writecontent conflictor "conflictor" git_annex "add" [conflictor] "add conflicter" git_annex "unlock" [conflictor] "unlock conflicter" git_annex "sync" ["--no-content"] "sync in r2" pair r1 r2 - forM_ [r1,r2,r1] $ \r -> indir r $ + forM_ [r1,r2,r1] $ \r -> intopdir r $ git_annex "sync" ["--no-content"] "sync" checkmerge "r1" r1 checkmerge "r2" r2 where conflictor = "conflictor" variantprefix = conflictor ++ ".variant" - checkmerge what d = indir d $ do + checkmerge what d = intopdir d $ do l <- getDirectoryContents "." let v = filter (variantprefix `isPrefixOf`) l length v == 0 @@ -1643,14 +1679,14 @@ checkmerge "r2" r2 where conflictor = "conflictor" - setup r = indir r $ whensupported $ do + setup r = intopdir r $ whensupported $ do disconnectOrigin git_annex "upgrade" [] "upgrade" git_annex "adjust" ["--unlock", "--force"] "adjust" writecontent conflictor "conflictor" git_annex "add" [conflictor] "add conflicter" git_annex "sync" ["--no-content"] "sync" - checkmerge what d = indir d $ whensupported $ do + checkmerge what d = intopdir d $ whensupported $ do git_annex "sync" ["--no-content"] ("sync should not work in " ++ what) l <- getDirectoryContents "." conflictor `elem` l @@ -1664,7 +1700,7 @@ test_adjusted_branch_subtree_regression :: Assertion test_adjusted_branch_subtree_regression = withtmpclonerepo $ \r -> whenM (adjustedbranchsupported r) $ do - indir r $ do + intopdir r $ do disconnectOrigin origbranch <- annexeval origBranch git_annex "upgrade" [] "upgrade" @@ -2086,31 +2122,31 @@ withtmpclonerepo $ \r1 -> withtmpclonerepo $ \r2 -> do pair r1 r2 - indir r1 $ do + intopdir r1 $ do disconnectOrigin writecontent wormannexedfile $ content wormannexedfile git_annex "add" [wormannexedfile, "--backend=WORM"] "add" git_annex "sync" ["--no-content"] "sync" - indir r2 $ do + intopdir r2 $ do disconnectOrigin git_annex "sync" ["--no-content"] "sync" - indir r1 $ do + intopdir r1 $ do git_annex "sync" ["--no-content"] "sync" - indir r2 $ do + intopdir r2 $ do git_annex "get" [wormannexedfile] "get" git_annex "drop" [wormannexedfile] "drop" git_annex "get" [wormannexedfile] "get" git_annex "drop" [wormannexedfile] "drop" - indir r1 $ do + intopdir r1 $ do git_annex "drop" ["--force", wormannexedfile] "drop" git_annex "sync" ["--no-content"] "sync" git_annex "forget" ["--force"] "forget" git_annex "sync" ["--no-content"] "sync" emptylog - indir r2 $ do + intopdir r2 $ do git_annex "sync" ["--no-content"] "sync" emptylog - indir r1 $ do + intopdir r1 $ do git_annex "sync" ["--no-content"] "sync" emptylog where diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -73,7 +73,11 @@ -- In debug mode, the output is allowed to pass through. -- So the output does not get checked in debug mode. testProcess :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> (String -> Bool) -> String -> Assertion -testProcess command params environ expectedret expectedtranscript faildesc = do +testProcess command params environ expectedret expectedtranscript faildesc = + void $ testProcess' command params environ expectedret expectedtranscript faildesc + +testProcess' :: String -> [String] -> Maybe [(String, String)] -> (Bool -> Bool) -> (String -> Bool) -> String -> IO String +testProcess' command params environ expectedret expectedtranscript faildesc = do let p = (proc command params) { env = environ } debug <- testDebug . testOptions <$> getTestMode if debug @@ -81,10 +85,12 @@ ret <- withCreateProcess p $ \_ _ _ pid -> waitForProcess pid (expectedret (ret == ExitSuccess)) @? (faildesc ++ " failed with unexpected exit code") + return "" else do (transcript, ret) <- Utility.Process.Transcript.processTranscript' p Nothing (expectedret ret) @? (faildesc ++ " failed with unexpected exit code (transcript follows)\n" ++ transcript) (expectedtranscript transcript) @? (faildesc ++ " failed with unexpected output (transcript follows)\n" ++ transcript) + return transcript -- Run git. (Do not use to run git-annex as the one being tested -- may not be in path.) @@ -140,12 +146,12 @@ a `finally` Annex.Action.stopCoProcesses innewrepo :: IO () -> IO () -innewrepo a = withgitrepo $ \r -> indir r a +innewrepo a = withgitrepo $ \r -> intopdir r a inmainrepo :: IO a -> IO a inmainrepo a = do d <- mainrepodir - indir d a + intopdir d a with_ssh_origin :: (Assertion -> Assertion) -> (Assertion -> Assertion) with_ssh_origin cloner a = cloner $ do @@ -160,7 +166,7 @@ config = "remote.origin.url" intmpclonerepo :: Assertion -> Assertion -intmpclonerepo a = withtmpclonerepo $ \r -> indir r a +intmpclonerepo a = withtmpclonerepo $ \r -> intopdir r a checkRepo :: Types.Annex a -> FilePath -> IO a checkRepo getval d = do @@ -170,11 +176,11 @@ intmpbareclonerepo :: Assertion -> Assertion intmpbareclonerepo a = withtmpclonerepo' (newCloneRepoConfig { bareClone = True } ) $ - \r -> indir r a + \r -> intopdir r a intmpsharedclonerepo :: Assertion -> Assertion intmpsharedclonerepo a = withtmpclonerepo' (newCloneRepoConfig { sharedClone = True } ) $ - \r -> indir r a + \r -> intopdir r a withtmpclonerepo :: (FilePath -> Assertion) -> Assertion withtmpclonerepo = withtmpclonerepo' newCloneRepoConfig @@ -200,14 +206,19 @@ maindir <- mainrepodir bracket (setuprepo maindir) return a -indir :: FilePath -> IO a -> IO a -indir dir a = do +intopdir :: FilePath -> IO a -> IO a +intopdir dir a = do + topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set") + inpath (topdir ++ "/" ++ dir) a + +inpath :: FilePath -> IO a -> IO a +inpath path a = do currdir <- getCurrentDirectory -- Assertion failures throw non-IO errors; catch -- any type of error and change back to currdir before -- rethrowing. r <- bracket_ - (changeToTopDir dir) + (setCurrentDirectory path) (setCurrentDirectory currdir) (tryNonAsync a) case r of @@ -215,7 +226,7 @@ Left e -> throwM e adjustedbranchsupported :: FilePath -> IO Bool -adjustedbranchsupported repo = indir repo $ Annex.AdjustedBranch.isGitVersionSupported +adjustedbranchsupported repo = intopdir repo $ Annex.AdjustedBranch.isGitVersionSupported setuprepo :: FilePath -> IO FilePath setuprepo dir = do @@ -248,7 +259,7 @@ ] git "clone" cloneparams "git clone" configrepo new - indir new $ do + intopdir new $ do ver <- annexVersion <$> getTestMode git_annex "init" [ "-q" @@ -257,12 +268,12 @@ ] "git annex init" unless (bareClone cfg) $ - indir new $ + intopdir new $ setupTestMode return new configrepo :: FilePath -> IO () -configrepo dir = indir dir $ do +configrepo dir = intopdir dir $ do -- ensure git is set up to let commits happen git "config" ["user.name", "Test User"] "git config" @@ -556,11 +567,6 @@ git "commit" ["--allow-empty", "-m", "empty"] "git commit failed" git_annex "adjust" ["--unlock"] "git annex adjust failed" -changeToTopDir :: FilePath -> IO () -changeToTopDir t = do - topdir <- Utility.Env.getEnvDefault "TOPDIR" (error "TOPDIR not set") - setCurrentDirectory $ topdir ++ "/" ++ t - tmpdir :: String tmpdir = ".t" @@ -687,7 +693,7 @@ {- Set up repos as remotes of each other. -} pair :: FilePath -> FilePath -> Assertion -pair r1 r2 = forM_ [r1, r2] $ \r -> indir r $ do +pair r1 r2 = forM_ [r1, r2] $ \r -> intopdir r $ do when (r /= r1) $ git "remote" ["add", "r1", "../" ++ r1] "remote add" when (r /= r2) $ diff --git a/Utility/Directory/Create.hs b/Utility/Directory/Create.hs --- a/Utility/Directory/Create.hs +++ b/Utility/Directory/Create.hs @@ -77,11 +77,11 @@ | null dirs -> liftIO $ unlessM (doesDirectoryExist (fromRawFilePath topdir)) $ ioError $ customerror doesNotExistErrorType $ - "createDirectoryFrom: " ++ fromRawFilePath topdir ++ " does not exist" + "createDirectoryUnder: " ++ fromRawFilePath topdir ++ " does not exist" | otherwise -> createdirs $ map (topdir P.) (reverse (scanl1 (P.) dirs)) _ -> liftIO $ ioError $ customerror userErrorType - ("createDirectoryFrom: not located in " ++ unwords (map fromRawFilePath topdirs)) + ("createDirectoryUnder: not located in " ++ unwords (map fromRawFilePath topdirs)) where customerror t s = mkIOError t s Nothing (Just (fromRawFilePath dir0)) 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.20241031 +Version: 10.20241202 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess @@ -633,9 +633,10 @@ CmdLine.GitAnnexShell.Checks CmdLine.GitAnnexShell.Fields CmdLine.AnnexSetter - CmdLine.Option + CmdLine.Multicall CmdLine.GitRemoteAnnex CmdLine.GitRemoteTorAnnex + CmdLine.Option CmdLine.Seek CmdLine.Usage Command diff --git a/git-annex.hs b/git-annex.hs --- a/git-annex.hs +++ b/git-annex.hs @@ -10,7 +10,9 @@ import System.Environment (getArgs, getProgName) import System.FilePath import Network.Socket (withSocketsDo) +import qualified Data.Map as M +import CmdLine.Multicall import qualified CmdLine.GitAnnex import qualified CmdLine.GitAnnexShell import qualified CmdLine.GitRemoteAnnex @@ -34,11 +36,15 @@ #endif run ps =<< getProgName where - run ps n = case takeFileName n of - "git-annex-shell" -> CmdLine.GitAnnexShell.run ps - "git-remote-annex" -> CmdLine.GitRemoteAnnex.run ps - "git-remote-tor-annex" -> CmdLine.GitRemoteTorAnnex.run ps - _ -> CmdLine.GitAnnex.run Test.optParser Test.runner Benchmark.mkGenerator ps + run ps n = case M.lookup (takeFileName n) otherMulticallCommands of + Just GitAnnexShell -> CmdLine.GitAnnexShell.run ps + Just GitRemoteAnnex -> CmdLine.GitRemoteAnnex.run ps + Just GitRemoteTorAnnex -> CmdLine.GitRemoteTorAnnex.run ps + Nothing -> CmdLine.GitAnnex.run + Test.optParser + Test.runner + Benchmark.mkGenerator + ps #ifdef mingw32_HOST_OS {- On Windows, if HOME is not set, probe it and set it. diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -16,3 +16,4 @@ resolver: nightly-2024-07-29 extra-deps: - filepath-bytestring-1.4.100.3.2 +- aws-0.24.3