diff --git a/Annex/Branch.hs b/Annex/Branch.hs --- a/Annex/Branch.hs +++ b/Annex/Branch.hs @@ -257,7 +257,7 @@ mergeIndex jl refs let commitrefs = nub $ fullname:refs ifM (handleTransitions jl localtransitions commitrefs) - ( runAnnexHook postUpdateAnnexHook + ( runAnnexHook postUpdateAnnexHook annexPostUpdateCommand , do ff <- if dirty then return False @@ -521,12 +521,10 @@ createMessage = fromMaybe "branch created" <$> getCommitMessage getCommitMessage :: Annex (Maybe String) -getCommitMessage = do - config <- Annex.getGitConfig - case annexCommitMessageCommand config of - Nothing -> return (annexCommitMessage config) - Just cmd -> catchDefaultIO (annexCommitMessage config) $ - Just <$> liftIO (readProcess "sh" ["-c", cmd]) +getCommitMessage = + outputOfAnnexHook commitMessageAnnexHook annexCommitMessageCommand + <|> + (annexCommitMessage <$> Annex.getGitConfig) {- Stages the journal, and commits staged changes to the branch. -} commit :: String -> Annex () @@ -724,7 +722,7 @@ setIndexSha ref = do f <- fromRepo gitAnnexIndexStatus writeLogFile f $ fromRef ref ++ "\n" - runAnnexHook postUpdateAnnexHook + runAnnexHook postUpdateAnnexHook annexPostUpdateCommand {- Stages the journal into the index, and runs an action that - commits the index to the branch. Note that the action is run diff --git a/Annex/Content.hs b/Annex/Content.hs --- a/Annex/Content.hs +++ b/Annex/Content.hs @@ -106,9 +106,7 @@ import Utility.Metered import Utility.HumanTime import Utility.TimeStamp -#ifndef mingw32_HOST_OS import Utility.FileMode -#endif import qualified Utility.RawFilePath as R import qualified System.FilePath.ByteString as P @@ -512,6 +510,12 @@ moveAnnex :: Key -> AssociatedFile -> RawFilePath -> Annex Bool moveAnnex key af src = ifM (checkSecureHashes' key) ( do +#ifdef mingw32_HOST_OS + {- Windows prevents deletion of files that are not + - writable, and the file could have such a mode. + - So avoid problems with deleting the file, now or later. -} + void $ liftIO $ tryIO $ allowWrite src +#endif withObjectLoc key storeobject return True , return False @@ -733,7 +737,11 @@ -} whenM hasThawHook $ void $ tryIO $ thawContent file - +#ifdef mingw32_HOST_OS + {- Windows prevents deletion of files that are not writable. -} + void $ liftIO $ tryIO $ allowWrite file +#endif + cleaner cleanObjectDirs file diff --git a/Annex/Content/LowLevel.hs b/Annex/Content/LowLevel.hs --- a/Annex/Content/LowLevel.hs +++ b/Annex/Content/LowLevel.hs @@ -10,6 +10,7 @@ module Annex.Content.LowLevel where import Annex.Common +import Annex.Hook import Logs.Transfer import qualified Annex import Utility.DiskFree @@ -25,11 +26,8 @@ - File may or may not be deleted at the end; caller is responsible for - making sure it's deleted. -} secureErase :: RawFilePath -> Annex () -secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig - where - go basecmd = void $ liftIO $ - boolSystem "sh" [Param "-c", Param $ gencmd basecmd] - gencmd = massReplace [ ("%file", shellEscape (fromRawFilePath file)) ] +secureErase = void . runAnnexPathHook "%file" + secureEraseAnnexHook annexSecureEraseCommand data LinkedOrCopied = Linked | Copied diff --git a/Annex/Hook.hs b/Annex/Hook.hs --- a/Annex/Hook.hs +++ b/Annex/Hook.hs @@ -4,7 +4,7 @@ - git-annex not change, otherwise removing old hooks using an old - version of the script would fail. - - - Copyright 2013-2019 Joey Hess + - Copyright 2013-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -48,6 +48,24 @@ postUpdateAnnexHook :: Git.Hook postUpdateAnnexHook = Git.Hook "post-update-annex" "" [] +preInitAnnexHook :: Git.Hook +preInitAnnexHook = Git.Hook "pre-init-annex" "" [] + +freezeContentAnnexHook :: Git.Hook +freezeContentAnnexHook = Git.Hook "freezecontent-annex" "" [] + +thawContentAnnexHook :: Git.Hook +thawContentAnnexHook = Git.Hook "thawcontent-annex" "" [] + +secureEraseAnnexHook :: Git.Hook +secureEraseAnnexHook = Git.Hook "secure-erase-annex" "" [] + +commitMessageAnnexHook :: Git.Hook +commitMessageAnnexHook = Git.Hook "commitmessage-annex" "" [] + +httpHeadersAnnexHook :: Git.Hook +httpHeadersAnnexHook = Git.Hook "http-headers-annex" "" [] + mkHookScript :: String -> String mkHookScript s = unlines [ shebang @@ -69,20 +87,70 @@ warning $ UnquotedString $ Git.hookName h ++ " hook (" ++ Git.hookFile h r ++ ") " ++ msg -{- Runs a hook. To avoid checking if the hook exists every time, - - the existing hooks are cached. -} -runAnnexHook :: Git.Hook -> Annex () -runAnnexHook hook = do +{- To avoid checking if the hook exists every time, the existing hooks + - are cached. -} +doesAnnexHookExist :: Git.Hook -> Annex Bool +doesAnnexHookExist hook = do m <- Annex.getState Annex.existinghooks case M.lookup hook m of - Just True -> run - Just False -> noop + Just exists -> return exists Nothing -> do exists <- inRepo $ Git.hookExists hook Annex.changeState $ \s -> s { Annex.existinghooks = M.insert hook exists m } - when exists run + return exists + +runAnnexHook :: Git.Hook -> (GitConfig -> Maybe String) -> Annex () +runAnnexHook hook commandcfg = runAnnexHook' hook commandcfg >>= \case + Nothing -> noop + Just failedcommanddesc -> + warning $ UnquotedString $ failedcommanddesc ++ " failed" + +-- Returns Nothing if the hook or GitConfig command succeeded, or a +-- description of what failed. +runAnnexHook' :: Git.Hook -> (GitConfig -> Maybe String) -> Annex (Maybe String) +runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook) + ( runhook + , runcommandcfg + ) where - run = unlessM (inRepo $ Git.runHook hook) $ do - h <- fromRepo $ Git.hookFile hook - warning $ UnquotedString $ h ++ " failed" + runhook = ifM (inRepo $ Git.runHook boolSystem hook []) + ( return Nothing + , do + h <- fromRepo (Git.hookFile hook) + commandfailed h + ) + runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case + Nothing -> return Nothing + Just command -> + ifM (liftIO $ boolSystem "sh" [Param "-c", Param command]) + ( return Nothing + , commandfailed $ "git configured command '" ++ command ++ "'" + ) + commandfailed c = return $ Just c + +runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> RawFilePath -> Annex Bool +runAnnexPathHook pathtoken hook commandcfg p = ifM (doesAnnexHookExist hook) + ( runhook + , runcommandcfg + ) + where + runhook = inRepo $ Git.runHook boolSystem hook [ File (fromRawFilePath p) ] + runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case + Nothing -> return True + Just basecmd -> liftIO $ + boolSystem "sh" [Param "-c", Param $ gencmd basecmd] + gencmd = massReplace [ (pathtoken, shellEscape (fromRawFilePath p)) ] + +outputOfAnnexHook :: Git.Hook -> (GitConfig -> Maybe String) -> Annex (Maybe String) +outputOfAnnexHook hook commandcfg = ifM (doesAnnexHookExist hook) + ( runhook + , runcommandcfg + ) + where + runhook = inRepo (Git.runHook runhook' hook []) + runhook' c ps = Just <$> readProcess c (toCommand ps) + runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case + Nothing -> return Nothing + Just command -> liftIO $ + Just <$> readProcess "sh" ["-c", command] diff --git a/Annex/Init.hs b/Annex/Init.hs --- a/Annex/Init.hs +++ b/Annex/Init.hs @@ -1,6 +1,6 @@ {- git-annex repository initialization - - - Copyright 2011-2024 Joey Hess + - Copyright 2011-2025 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -74,17 +74,29 @@ checkInitializeAllowed :: (InitializeAllowed -> Annex a) -> Annex a checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case - Nothing -> do - checkSqliteWorks - a InitializeAllowed + Nothing -> runAnnexHook' preInitAnnexHook annexPreInitCommand >>= \case + Nothing -> do + checkSqliteWorks + a InitializeAllowed + Just failedcommanddesc -> do + initpreventedby failedcommanddesc + notinitialized Just noannexmsg -> do - warning "Initialization prevented by .noannex file (remove the file to override)" + initpreventedby ".noannex file (remove the file to override)" unless (null noannexmsg) $ warning (UnquotedString noannexmsg) - giveup "Not initialized." + notinitialized + where + initpreventedby r = warning $ UnquotedString $ + "Initialization prevented by " ++ r + notinitialized = giveup "Not initialized." initializeAllowed :: Annex Bool -initializeAllowed = isNothing <$> noAnnexFileContent' +initializeAllowed = noAnnexFileContent' >>= \case + Nothing -> runAnnexHook' preInitAnnexHook annexPreInitCommand >>= \case + Nothing -> return True + Just _ -> return False + Just _ -> return False noAnnexFileContent' :: Annex (Maybe String) noAnnexFileContent' = inRepo $ @@ -268,7 +280,7 @@ getInitializedVersion >>= maybe needsinit checkUpgrade where needsinit = - whenM (initializeAllowed <&&> check) $ do + whenM (check <&&> initializeAllowed) $ do initialize startupannex Nothing Nothing autoEnableSpecialRemotes remotelist diff --git a/Annex/Perms.hs b/Annex/Perms.hs --- a/Annex/Perms.hs +++ b/Annex/Perms.hs @@ -33,6 +33,7 @@ ) where import Annex.Common +import Annex.Hook import Utility.FileMode import Git import Git.ConfigTypes @@ -340,24 +341,24 @@ either throwM return v hasFreezeHook :: Annex Bool -hasFreezeHook = isJust . annexFreezeContentCommand <$> Annex.getGitConfig +hasFreezeHook = + (isJust . annexFreezeContentCommand <$> Annex.getGitConfig) + <||> + (doesAnnexHookExist freezeContentAnnexHook) hasThawHook :: Annex Bool -hasThawHook = isJust . annexThawContentCommand <$> Annex.getGitConfig +hasThawHook = + (isJust . annexThawContentCommand <$> Annex.getGitConfig) + <||> + (doesAnnexHookExist thawContentAnnexHook) freezeHook :: RawFilePath -> Annex () -freezeHook p = maybe noop go =<< annexFreezeContentCommand <$> Annex.getGitConfig - where - go basecmd = void $ liftIO $ - boolSystem "sh" [Param "-c", Param $ gencmd basecmd] - gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ] +freezeHook = void . runAnnexPathHook "%path" + freezeContentAnnexHook annexFreezeContentCommand thawHook :: RawFilePath -> Annex () -thawHook p = maybe noop go =<< annexThawContentCommand <$> Annex.getGitConfig - where - go basecmd = void $ liftIO $ - boolSystem "sh" [Param "-c", Param $ gencmd basecmd] - gencmd = massReplace [ ("%path", shellEscape (fromRawFilePath p)) ] +thawHook = void . runAnnexPathHook "%path" + thawContentAnnexHook annexThawContentCommand {- Calculate mode to use for a directory from the mode to use for a file. - diff --git a/Annex/Url.hs b/Annex/Url.hs --- a/Annex/Url.hs +++ b/Annex/Url.hs @@ -35,6 +35,7 @@ import qualified Annex import qualified Utility.Url as U import qualified Utility.Url.Parse as U +import Annex.Hook import Utility.Hash (IncrementalVerifier) import Utility.IPAddress import Network.HTTP.Client.Restricted @@ -75,9 +76,11 @@ <*> pure (Just (\u -> "Configuration of annex.security.allowed-url-schemes does not allow accessing " ++ show u)) <*> pure U.noBasicAuth - headers = annexHttpHeadersCommand <$> Annex.getGitConfig >>= \case - Just cmd -> lines <$> liftIO (readProcess "sh" ["-c", cmd]) - Nothing -> annexHttpHeaders <$> Annex.getGitConfig + headers = + outputOfAnnexHook httpHeadersAnnexHook annexHttpHeadersCommand + >>= \case + Just output -> pure (lines output) + Nothing -> annexHttpHeaders <$> Annex.getGitConfig checkallowedaddr = words . annexAllowedIPAddresses <$> Annex.getGitConfig >>= \case ["all"] -> do diff --git a/Backend/VURL.hs b/Backend/VURL.hs --- a/Backend/VURL.hs +++ b/Backend/VURL.hs @@ -31,8 +31,12 @@ -- Normally there will always be an key -- recorded when a VURL's content is available, -- because downloading the content from the web in - -- the first place records one. - [] -> return False + -- the first place records one. But, when the + -- content is downloaded from some other special + -- remote that claims an url, that might not be the + -- case. So, default to True when no key is + -- recorded. + [] -> return True eks -> do let check ek = getbackend ek >>= \case Nothing -> pure False diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,33 @@ +git-annex (10.20250115) upstream; urgency=medium + + * Improve handing of ssh connection problems during + remote annex.uuid discovery. + * log: Support --key, as well as --branch and --unused. + * Avoid verification error when addurl --verifiable is used + with an url claimed by a special remote other than the web. + * Fix installation on Android. + * Allow enableremote of an existing webdav special remote that has + read-only access. + * git-remote-annex: Use enableremote rather than initremote. + * Windows: Fix permission denied error when dropping files that + have the readonly attribute set. + * Added freezecontent-annex and thawcontent-annex hooks that + correspond to the git configs annex.freezecontent and + annex.thawcontent. + * Added secure-erase-annex hook that corresponds to the git config + annex.secure-erase-command. + * Added commitmessage-annex hook that corresponds to the git config + annex.commitmessage-command. + * Added http-headers-annex hook that corresponds to the git config + annex.http-headers-command. + * Added git configs annex.post-update-command and annex.pre-commit-command + that correspond to the post-update-annex and pre-commit-annex hooks. + * Added annex.pre-init-command git config and pre-init-annex hook + that is run before git-annex repository initialization. + * Linux standalone builds' bundled rsync updated to fix security holes. + + -- Joey Hess Wed, 15 Jan 2025 11:39:12 -0400 + git-annex (10.20250102) upstream; urgency=medium * Added config `url..annexInsteadOf` corresponding to git's diff --git a/CmdLine/GitRemoteAnnex.hs b/CmdLine/GitRemoteAnnex.hs --- a/CmdLine/GitRemoteAnnex.hs +++ b/CmdLine/GitRemoteAnnex.hs @@ -586,14 +586,15 @@ Nothing -> specialRemoteFromUrl sab inittempremote where -- Initialize a new special remote with the provided configuration - -- and name. + -- and name. This actually does a Remote.Enable, because the + -- special remote has already been initialized somewhere before. initremote remotename = do let c = M.insert SpecialRemote.nameField (Proposed remotename) $ M.delete (Accepted "config-uuid") $ specialRemoteConfig cfg t <- either giveup return (SpecialRemote.findType c) dummycfg <- liftIO dummyRemoteGitConfig - (c', u) <- Remote.setup t Remote.Init (Just (specialRemoteUUID cfg)) + (c', u) <- Remote.setup t (Remote.Enable c) (Just (specialRemoteUUID cfg)) Nothing c dummycfg `onException` cleanupremote remotename Logs.Remote.configSet u c' diff --git a/Command/Log.hs b/Command/Log.hs --- a/Command/Log.hs +++ b/Command/Log.hs @@ -46,7 +46,7 @@ data LogOptions = LogOptions { logFiles :: CmdParams - , allOption :: Bool + , keyOptions :: Maybe KeyOptions , sizesOfOption :: Maybe (DeferredParse UUID) , sizesOption :: Bool , totalSizesOption :: Bool @@ -62,11 +62,7 @@ optParser :: CmdParamsDesc -> Parser LogOptions optParser desc = LogOptions <$> cmdParams desc - <*> switch - ( long "all" - <> short 'A' - <> help "display location log changes to all files" - ) + <*> optional parseKeyOptions <*> optional ((parseUUIDOption <$> strOption ( long "sizesof" <> metavar (paramRemote `paramOr` paramDesc `paramOr` paramUUID) @@ -138,22 +134,24 @@ zone <- liftIO getCurrentTimeZone outputter <- mkOutputter m zone o <$> jsonOutputEnabled let seeker = AnnexedFileSeeker - { startAction = const $ start o outputter + { startAction = const $ \si file key -> + start o outputter (si, key, mkActionItem (file, key)) , checkContentPresent = Nothing -- the way this uses the location log would not be -- helped by precaching the current value , usesLocationLog = False } - case (logFiles o, allOption o) of - (fs, False) -> withFilesInGitAnnex ww seeker + case (logFiles o, keyOptions o) of + ([], Just WantAllKeys) -> + commandAction (startAll o outputter) + (fs, ko) -> withKeyOptions ko False + seeker (commandAction . start o outputter) + (withFilesInGitAnnex ww seeker) =<< workTreeItems ww fs - ([], True) -> commandAction (startAll o outputter) - (_, True) -> giveup "Cannot specify both files and --all" -start :: LogOptions -> (ActionItem -> SeekInput -> Outputter) -> SeekInput -> RawFilePath -> Key -> CommandStart -start o outputter si file key = do +start :: LogOptions -> (ActionItem -> SeekInput -> Outputter) -> (SeekInput, Key, ActionItem) -> CommandStart +start o outputter (si, key, ai) = do (changes, cleanup) <- getKeyLog key (passthruOptions o) - let ai = mkActionItem (file, key) showLogIncremental (outputter ai si) changes void $ liftIO cleanup stop diff --git a/Command/PreCommit.hs b/Command/PreCommit.hs --- a/Command/PreCommit.hs +++ b/Command/PreCommit.hs @@ -44,7 +44,7 @@ -- files in the worktree won't be populated, so populate them here Command.Smudge.updateSmudged (Restage False) - runAnnexHook preCommitAnnexHook + runAnnexHook preCommitAnnexHook annexPreCommitCommand -- committing changes to a view updates metadata currentView >>= \case diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -255,9 +255,9 @@ {- Runs a command to get the configuration of a repo, - and returns a repo populated with the configuration, as well as the raw - - output and the standard error of the command. -} -fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Either SomeException (Repo, S.ByteString, String)) -fromPipe r cmd params st = tryNonAsync $ withCreateProcess p go + - output and the exit status and standard error of the command. -} +fromPipe :: Repo -> String -> [CommandParam] -> ConfigStyle -> IO (Repo, S.ByteString, ExitCode, String) +fromPipe r cmd params st = withCreateProcess p go where p = (proc cmd $ toCommand params) { std_out = CreatePipe @@ -267,9 +267,13 @@ withAsync (getstderr pid herr []) $ \errreader -> do val <- S.hGetContents hout err <- wait errreader - forceSuccessProcess p pid - r' <- store val st r - return (r', val, err) + exitcode <- waitForProcess pid + case exitcode of + ExitSuccess -> do + r' <- store val st r + return (r', val, exitcode, err) + ExitFailure _ -> + return (r, val, exitcode, err) go _ _ _ _ = error "internal" getstderr pid herr c = hGetLineUntilExitOrEOF pid herr >>= \case @@ -278,7 +282,7 @@ {- Reads git config from a specified file and returns the repo populated - with the configuration. -} -fromFile :: Repo -> FilePath -> IO (Either SomeException (Repo, S.ByteString, String)) +fromFile :: Repo -> FilePath -> IO (Repo, S.ByteString, ExitCode, String) fromFile r f = fromPipe r "git" [ Param "config" , Param "--file" diff --git a/Git/Hook.hs b/Git/Hook.hs --- a/Git/Hook.hs +++ b/Git/Hook.hs @@ -108,8 +108,8 @@ doesFileExist f #endif -runHook :: Hook -> Repo -> IO Bool -runHook h r = do +runHook :: (FilePath -> [CommandParam] -> IO a) -> Hook -> [CommandParam] -> Repo -> IO a +runHook runner h ps r = do let f = hookFile h r - (c, ps) <- findShellCommand f - boolSystem c ps + (c, cps) <- findShellCommand f + runner c (cps ++ ps) diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -22,7 +22,6 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified System.FilePath.ByteString as P -import Control.Exception import Data.Default import Annex.Common @@ -59,7 +58,6 @@ import Logs.Remote import Utility.Gpg import Utility.SshHost -import Utility.Tuple import Utility.Directory.Create import Messages.Progress import Types.ProposedAccepted @@ -508,16 +506,25 @@ getGCryptId fast r gc | Git.repoIsLocal r || Git.repoIsLocalUnknown r = extract <$> liftIO (catchMaybeIO $ Git.Config.read r) - | not fast = extract . liftM fst3 <$> getM (eitherToMaybe <$>) - [ Ssh.onRemote NoConsumeStdin r (\f p -> liftIO (Git.Config.fromPipe r f p Git.Config.ConfigList), return (Left $ giveup "configlist failed")) "configlist" [] [] - , getConfigViaRsync r gc + | not fast = extract <$> getM id + [ Ssh.onRemote NoConsumeStdin r (configpipe, return Nothing) "configlist" [] [] + , getconfig $ getConfigViaRsync r gc ] | otherwise = return (Nothing, r) where extract Nothing = (Nothing, r) extract (Just r') = (fromConfigValue <$> Git.Config.getMaybe coreGCryptId r', r') -getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Either SomeException (Git.Repo, S.ByteString, String)) + configpipe f p = getconfig $ liftIO $ + Git.Config.fromPipe r f p Git.Config.ConfigList + + getconfig a = do + (r', _, exitcode, _) <- a + if exitcode == ExitSuccess + then return (Just r') + else return Nothing + +getConfigViaRsync :: Git.Repo -> RemoteGitConfig -> Annex (Git.Repo, S.ByteString, ExitCode, String) getConfigViaRsync r gc = do let (rsynctransport, rsyncurl, _) = rsyncTransport r gc opts <- rsynctransport diff --git a/Remote/Git.hs b/Remote/Git.hs --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -278,14 +278,25 @@ | Git.repoIsSsh r = storeUpdatedRemote $ do v <- Ssh.onRemote NoConsumeStdin r ( pipedconfig Git.Config.ConfigList autoinit (Git.repoDescribe r) - , return (Left "configlist failed") + , error "internal" ) "configlist" [] configlistfields case v of Right r' | haveconfig r' -> return r' - | otherwise -> configlist_failed - Left _ -> configlist_failed + | otherwise -> do + configlist_failed + return r + Left exitcode -> do + -- ssh exits 255 when there was an error + -- connecting to the remote server. + if exitcode /= ExitFailure 255 + then do + configlist_failed + return r + else do + warning $ UnquotedString $ "Unable to connect to repository " ++ Git.repoDescribe r ++ " to get its annex.uuid configuration." + return r | Git.repoIsHttp r = storeUpdatedRemote geturlconfig | Git.GCrypt.isEncrypted r = handlegcrypt =<< getConfigMaybe (remoteAnnexConfig r "uuid") | Git.repoIsUrl r = do @@ -298,31 +309,35 @@ haveconfig = not . M.null . Git.config pipedconfig st mustincludeuuuid configloc cmd params = do - v <- liftIO $ Git.Config.fromPipe r cmd params st - case v of - Right (r', val, _err) -> do + (r', val, exitcode, _err) <- liftIO $ + Git.Config.fromPipe r cmd params st + if exitcode == ExitSuccess + then do unless (isUUIDConfigured r' || val == mempty || not mustincludeuuuid) $ do warning $ UnquotedString $ "Failed to get annex.uuid configuration of repository " ++ Git.repoDescribe r warning $ UnquotedString $ "Instead, got: " ++ show val warning "This is unexpected; please check the network transport!" return $ Right r' - Left l -> do + else do warning $ UnquotedString $ "Unable to parse git config from " ++ configloc - return $ Left (show l) + return $ Left exitcode geturlconfig = Url.withUrlOptionsPromptingCreds $ \uo -> do let url = Git.repoLocation r ++ "/config" v <- withTmpFile "git-annex.tmp" $ \tmpfile h -> do liftIO $ hClose h Url.download' nullMeterUpdate Nothing url tmpfile uo >>= \case - Right () -> pipedconfig Git.Config.ConfigNullList - False url "git" - [ Param "config" - , Param "--null" - , Param "--list" - , Param "--file" - , File tmpfile - ] + Right () -> + pipedconfig Git.Config.ConfigNullList + False url "git" + [ Param "config" + , Param "--null" + , Param "--list" + , Param "--file" + , File tmpfile + ] >>= return . \case + Right r' -> Right r' + Left exitcode -> Left $ "git config exited " ++ show exitcode Left err -> return (Left err) case v of Right r' -> do @@ -342,15 +357,7 @@ warning $ UnquotedString $ url ++ " " ++ err return r - {- Is this remote just not available, or does - - it not have git-annex-shell? - - Find out by trying to fetch from the remote. -} - configlist_failed = case Git.remoteName r of - Nothing -> return r - Just n -> do - whenM (inRepo $ Git.Command.runBool [Param "fetch", Param "--quiet", Param n]) $ do - set_ignore "does not have git-annex installed" True - return r + configlist_failed = set_ignore "does not have git-annex installed" True set_ignore msg longmessage = do case Git.remoteName r of diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -137,7 +137,9 @@ (c', encsetup) <- encryptionSetup c gc pc <- either giveup return . parseRemoteConfig c' =<< configParser remote c' creds <- maybe (getCreds pc gc u) (return . Just) mcreds - testDav url creds + case ss of + Init -> testDav url creds + _ -> noop gitConfigSpecialRemote u c' [("webdav", "true")] c'' <- setRemoteCredPair ss encsetup pc gc (davCreds u) creds return (c'', u) diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -97,6 +97,9 @@ , annexAlwaysCompact :: Bool , annexCommitMessage :: Maybe String , annexCommitMessageCommand :: Maybe String + , annexPreInitCommand :: Maybe String + , annexPreCommitCommand :: Maybe String + , annexPostUpdateCommand :: Maybe String , annexMergeAnnexBranches :: Bool , annexDelayAdd :: Maybe Int , annexHttpHeaders :: [String] @@ -190,6 +193,9 @@ , annexAlwaysCompact = getbool (annexConfig "alwayscompact") True , annexCommitMessage = getmaybe (annexConfig "commitmessage") , annexCommitMessageCommand = getmaybe (annexConfig "commitmessage-command") + , annexPreInitCommand = getmaybe (annexConfig "pre-init-command") + , annexPreCommitCommand = getmaybe (annexConfig "pre-commit-command") + , annexPostUpdateCommand = getmaybe (annexConfig "post-update-command") , annexMergeAnnexBranches = getbool (annexConfig "merge-annex-branches") True , annexDelayAdd = getmayberead (annexConfig "delayadd") , annexHttpHeaders = getlist (annexConfig "http-headers") 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.20250102 +Version: 10.20250115 Cabal-Version: 1.12 License: AGPL-3 Maintainer: Joey Hess