runAnnexHook :: Git.Hook -> (GitConfig -> Maybe String) -> Annex ()
runAnnexHook hook commandcfg = runAnnexHook' hook commandcfg >>= \case
- Nothing -> noop
- Just failedcommanddesc ->
+ HookSuccess -> noop
+ HookFailed 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)
+data HookResult
+ = HookSuccess
+ | HookFailed String
+ -- ^ A description of the hook command that failed.
+ deriving (Eq, Show)
+
+runAnnexHook' :: Git.Hook -> (GitConfig -> Maybe String) -> Annex HookResult
runAnnexHook' hook commandcfg = ifM (doesAnnexHookExist hook)
( runhook
, runcommandcfg
)
where
runhook = ifM (inRepo $ Git.runHook boolSystem hook [])
- ( return Nothing
+ ( return HookSuccess
, do
h <- fromRepo (Git.hookFile hook)
- commandfailed (fromOsPath h)
+ return $ HookFailed $ fromOsPath h
)
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
- Nothing -> return Nothing
+ Nothing -> return HookSuccess
Just command ->
ifM (liftIO $ boolSystem "sh" [Param "-c", Param command])
- ( return Nothing
- , commandfailed $ "git configured command '" ++ command ++ "'"
+ ( return HookSuccess
+ , return $ HookFailed $ "git configured command '" ++ command ++ "'"
)
- commandfailed c = return $ Just c
-runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> OsPath -> Annex Bool
+runAnnexPathHook :: String -> Git.Hook -> (GitConfig -> Maybe String) -> OsPath -> Annex HookResult
runAnnexPathHook pathtoken hook commandcfg p = ifM (doesAnnexHookExist hook)
( runhook
, runcommandcfg
)
where
- runhook = inRepo $ Git.runHook boolSystem hook [ File p' ]
+ runhook = ifM (inRepo $ Git.runHook boolSystem hook [ File p' ])
+ ( return HookSuccess
+ , do
+ h <- fromRepo (Git.hookFile hook)
+ return $ HookFailed $ fromOsPath h
+ )
runcommandcfg = commandcfg <$> Annex.getGitConfig >>= \case
- Nothing -> return True
- Just basecmd -> liftIO $
- boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
+ Nothing -> return HookSuccess
+ Just basecmd ->
+ ifM (liftIO $ boolSystem "sh" [Param "-c", Param (gencmd basecmd)])
+ ( return HookSuccess
+ , return $ HookFailed $ "git configured command '" ++ basecmd ++ "'"
+ )
gencmd = massReplace [ (pathtoken, shellEscape p') ]
p' = fromOsPath p
uninitialize,
probeCrippledFileSystem,
probeCrippledFileSystem',
+ isCrippledFileSystem,
) where
import Annex.Common
checkInitializeAllowed :: (InitializeAllowed -> Annex a) -> Annex a
checkInitializeAllowed a = guardSafeToUseRepo $ noAnnexFileContent' >>= \case
Nothing -> runAnnexHook' preInitAnnexHook annexPreInitCommand >>= \case
- Nothing -> do
+ HookSuccess -> do
checkSqliteWorks
a InitializeAllowed
- Just failedcommanddesc -> do
+ HookFailed failedcommanddesc -> do
initpreventedby failedcommanddesc
notinitialized
Just noannexmsg -> do
initializeAllowed :: Annex Bool
initializeAllowed = noAnnexFileContent' >>= \case
Nothing -> runAnnexHook' preInitAnnexHook annexPreInitCommand >>= \case
- Nothing -> return True
- Just _ -> return False
+ HookSuccess -> return True
+ HookFailed _ -> return False
Just _ -> return False
noAnnexFileContent' :: Annex (Maybe String)
isInitialized = maybe Annex.Branch.hasSibling (const $ return True) =<< getVersion
{- A crippled filesystem is one that does not allow making symlinks,
- - or removing write access from files. -}
-probeCrippledFileSystem :: Annex Bool
-probeCrippledFileSystem = withEventuallyCleanedOtherTmp $ \tmp -> do
- (r, warnings) <- probeCrippledFileSystem' tmp
+ - or removing write access from files.
+ -
+ - This displays messages about problems detected with the filesystem.
+ -
+ - If a freeze or thaw hook is configured, but exits nonzero,
+ - this returns Nothing after displaying a message to the user about the
+ - problem. Such a hook can in some cases make a filesystem
+ - that would otherwise be detected as crippled work ok, so this avoids
+ - a false positive.
+ -}
+probeCrippledFileSystem :: Annex (Maybe Bool)
+probeCrippledFileSystem = do
+ (r, warnings) <- isCrippledFileSystem'
+ mapM_ (warning . UnquotedString) warnings
+ return r
+
+isCrippledFileSystem :: Annex Bool
+isCrippledFileSystem = do
+ (r, _warnings) <- isCrippledFileSystem'
+ return (fromMaybe True r)
+
+isCrippledFileSystem' :: Annex (Maybe Bool, [String])
+isCrippledFileSystem' = withEventuallyCleanedOtherTmp $ \tmp ->
+ probeCrippledFileSystem' tmp
(Just (freezeContent' UnShared))
(Just (thawContent' UnShared))
=<< hasFreezeHook
- mapM_ (warning . UnquotedString) warnings
- return r
probeCrippledFileSystem'
:: (MonadIO m, MonadCatch m)
=> OsPath
- -> Maybe (OsPath -> m ())
- -> Maybe (OsPath -> m ())
+ -> Maybe (OsPath -> m HookResult)
+ -> Maybe (OsPath -> m HookResult)
-> Bool
- -> m (Bool, [String])
+ -> m (Maybe Bool, [String])
#ifdef mingw32_HOST_OS
-probeCrippledFileSystem' _ _ _ _ = return (True, [])
+probeCrippledFileSystem' _ _ _ _ = return (Just True, [])
#else
probeCrippledFileSystem' tmp freezecontent thawcontent hasfreezehook = do
let f = tmp </> literalOsPath "gaprobe"
liftIO $ F.writeFile' f ""
- r <- probe f
- void $ tryNonAsync $ (fromMaybe (liftIO . allowWrite) thawcontent) f
+ r <- freezethaw f probe
liftIO $ removeFile f
return r
where
- probe f = catchDefaultIO (True, []) $ do
+ fallbackfreezecontent f = do
+ liftIO $ preventWrite f
+ return HookSuccess
+
+ fallbackthawcontent f = do
+ liftIO $ allowWrite f
+ return HookSuccess
+
+ freezethaw f cont =
+ (fromMaybe fallbackfreezecontent freezecontent) f >>= \case
+ HookFailed failedcommanddesc ->
+ return (Nothing, [hookfailed failedcommanddesc])
+ HookSuccess -> do
+ r <- cont f
+ tryNonAsync ((fromMaybe fallbackthawcontent thawcontent) f)
+ >>= return . \case
+ Right (HookFailed failedcommanddesc) ->
+ let (_, warnings) = r
+ in (Nothing, hookfailed failedcommanddesc : warnings)
+ _ -> r
+
+ hookfailed failedcommanddesc = "Failed to run " ++ failedcommanddesc
+ ++ ". Unable to initialize until this is fixed."
+
+ probe f = catchDefaultIO (Just True, []) $ do
let f2 = f <> literalOsPath "2"
liftIO $ removeWhenExistsWith removeFile f2
liftIO $ R.createSymbolicLink (fromOsPath f) (fromOsPath f2)
liftIO $ removeWhenExistsWith removeFile f2
- (fromMaybe (liftIO . preventWrite) freezecontent) f
-- Should be unable to write to the file (unless
-- running as root). But some crippled
-- filesystems ignore write bit removals or ignore
-- permissions entirely.
ifM ((== Just False) <$> liftIO (checkContentWritePerm' UnShared f Nothing hasfreezehook))
- ( return (True, ["Filesystem does not allow removing write bit from files."])
+ ( return (Just True, ["Filesystem does not allow removing write bit from files."])
, liftIO $ ifM ((== 0) <$> getRealUserID)
- ( return (False, [])
+ ( return (Just False, [])
, do
r <- catchBoolIO $ do
F.writeFile' f "2"
return True
if r
- then return (True, ["Filesystem allows writing to files whose write bit is not set."])
- else return (False, [])
+ then return (Just True, ["Filesystem allows writing to files whose write bit is not set."])
+ else return (Just False, [])
)
)
#endif
checkCrippledFileSystem :: Annex ()
-checkCrippledFileSystem = whenM probeCrippledFileSystem $ do
- warning "Detected a crippled filesystem."
- setCrippledFileSystem True
-
- {- Normally git disables core.symlinks itself when the:w
- -
- - filesystem does not support them. But, even if symlinks are
- - supported, we don't use them by default in a crippled
- - filesystem. -}
- whenM (coreSymlinks <$> Annex.getGitConfig) $ do
- warning "Disabling core.symlinks."
- setConfig "core.symlinks"
- (Git.Config.boolConfig False)
+checkCrippledFileSystem = probeCrippledFileSystem >>= \case
+ Just True -> do
+ warning "Detected a crippled filesystem."
+ setCrippledFileSystem True
+
+ {- Normally git disables core.symlinks itself when the
+ -
+ - filesystem does not support them. But, even if symlinks are
+ - supported, we don't use them by default in a crippled
+ - filesystem. -}
+ whenM (coreSymlinks <$> Annex.getGitConfig) $ do
+ warning "Disabling core.symlinks."
+ setConfig "core.symlinks"
+ (Git.Config.boolConfig False)
+ Just False -> noop
+ Nothing -> giveup "Not initialized."
probeLockSupport :: Annex Bool
#ifdef mingw32_HOST_OS
- that happens with write permissions.
-}
freezeContent :: OsPath -> Annex ()
-freezeContent file =
- withShared $ \sr -> freezeContent' sr file
+freezeContent file = withShared $ \sr -> void $ freezeContent' sr file
-freezeContent' :: SharedRepository -> OsPath -> Annex ()
+freezeContent' :: SharedRepository -> OsPath -> Annex HookResult
freezeContent' sr file = freezeContent'' sr file =<< getVersion
-freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex ()
+freezeContent'' :: SharedRepository -> OsPath -> Maybe RepoVersion -> Annex HookResult
freezeContent'' sr file rv = do
fastDebug "Annex.Perms" ("freezing content " ++ fromOsPath file)
unlessM crippledFileSystem $ go sr
{- Allows writing to an annexed file that freezeContent was called on
- before. -}
thawContent :: OsPath -> Annex ()
-thawContent file = withShared $ \sr -> thawContent' sr file
+thawContent file = withShared $ \sr -> void $ thawContent' sr file
-thawContent' :: SharedRepository -> OsPath -> Annex ()
+thawContent' :: SharedRepository -> OsPath -> Annex HookResult
thawContent' sr file = do
fastDebug "Annex.Perms" ("thawing content " ++ fromOsPath file)
thawPerms (go sr) (thawHook file)
- fail on a crippled filesystem. But, if file modes are supported on a
- crippled filesystem, the file may be frozen, so try to thaw its
- permissions. -}
-thawPerms :: Annex () -> Annex () -> Annex ()
+thawPerms :: Annex () -> Annex HookResult -> Annex HookResult
thawPerms a hook = ifM crippledFileSystem
- ( hook >> void (tryNonAsync a)
- , hook >> a
+ ( void (tryNonAsync a) `after` hook
+ , a `after` hook
)
{- Blocks writing to the directory an annexed file is in, to prevent the
freezeContentDir file = do
fastDebug "Annex.Perms" ("freezing content directory " ++ fromOsPath dir)
unlessM crippledFileSystem $ withShared go
- freezeHook dir
+ void $ freezeHook dir
where
dir = parentDir file
go UnShared = liftIO $ preventWrite dir
thawContentDir :: OsPath -> Annex ()
thawContentDir file = do
fastDebug "Annex.Perms" ("thawing content directory " ++ fromOsPath dir)
- thawPerms (withShared (liftIO . go)) (thawHook dir)
+ void $ thawPerms (withShared (liftIO . go)) (thawHook dir)
where
dir = parentDir file
go UnShared = allowWrite dir
unlessM (liftIO $ doesDirectoryExist dir) $
createAnnexDirectory dir
-- might have already existed with restricted perms
- thawHook dir
+ void $ thawHook dir
unlessM crippledFileSystem $ liftIO $ allowWrite dir
where
dir = parentDir dest
<||>
(doesAnnexHookExist thawContentAnnexHook)
-freezeHook :: OsPath -> Annex ()
-freezeHook = void . runAnnexPathHook "%path"
+freezeHook :: OsPath -> Annex HookResult
+freezeHook = runAnnexPathHook "%path"
freezeContentAnnexHook annexFreezeContentCommand
-thawHook :: OsPath -> Annex ()
-thawHook = void . runAnnexPathHook "%path"
+thawHook :: OsPath -> Annex HookResult
+thawHook = runAnnexPathHook "%path"
thawContentAnnexHook annexThawContentCommand
{- Calculate mode to use for a directory from the mode to use for a file.
* assistant: Avoid hanging at startup when a process has a *.lock file
open in the .git directory.
+ * When annex.freezecontent-command or annex.thawcontent-command is
+ configured but fails, prevent initialization. This allows the user to
+ fix their configuration and avoid crippled filesystem detection
+ entering an adjusted branch.
-- Joey Hess <id@joeyh.name> Thu, 22 May 2025 12:43:38 -0400
_ -> noop
void $ liftIO $ tryIO $ removeDirectory annexobjectdir
- notcrippledfilesystem = not <$> probeCrippledFileSystem
+ notcrippledfilesystem = not <$> isCrippledFileSystem
nonbuggygitversion = liftIO $
flip notElem buggygitversions <$> Git.Version.installed
go Nothing = summarizeresults $ withConcurrentOutput $ do
ensuredir tmpdir
- crippledfilesystem <- fst <$> Annex.Init.probeCrippledFileSystem'
- (toOsPath tmpdir)
- Nothing Nothing False
+ crippledfilesystem <- fromMaybe False . fst
+ <$> Annex.Init.probeCrippledFileSystem'
+ (toOsPath tmpdir)
+ Nothing Nothing False
adjustedbranchok <- Annex.AdjustedBranch.isGitVersionSupported
let ts = mkts numparts crippledfilesystem adjustedbranchok opts
let warnings = fst (tastyParser ts)
--- /dev/null
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 3"""
+ date="2025-05-27T16:16:38Z"
+ content="""
+I agreee it makes sense to detect freeze/thaw hook fail at init and error
+out rather than switching to an adjusted branch, and rather than start
+using a repisitory that is not configured as desired from the start.
+I've implemented that now.
+
+I think that change is arguably enough to consider this done. It avoids
+the user initializing a broken repository, or otherwise starting from an
+unexpected state. Fixing problems that happen later is the
+job of `git-annex fsck`.
+"""]]
--- /dev/null
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 6"""
+ date="2025-05-27T14:53:52Z"
+ content="""
+Note that this bug is closed, and it would need to be moved out of
+this archive to be reopened.
+
+Anyway, I agree that if the freeze/thaw hook is configured, but fails,
+it would make sense for crippled filesystem probing to tell the user to
+fix their configuration, and abort initialization, rather than
+unnecessarily entering an adjusted branch. I have implemented that now.
+
+As far as situations where the hook is configured at first but later
+is not configured, `git-annex fsck` re-runs the hook to freeze content.
+So that is not dissimilar from other situations where permissions prevent
+proper freezing, which fsck also fixes.
+"""]]
projects / git-annex.git / commitdiff