From 947d2a10bcf80e74758f65b3cc3fd5ac1bff3fa8 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 12 May 2021 15:08:03 -0400 Subject: [PATCH] assistant: Fix a crash on startup by avoiding using forkProcess ghc 8.8.4 seems to have changed something that broke code that has been successfully using forkProcess since 2012. Likely a change to GC internals. Since forkProcess has never had clear documentation about how to use it safely, avoid using it at all. Instead, when git-annex needs to daemonize itself, re-run the git-annex command, in a new process group and session. This commit was sponsored by Luke Shumaker on Patreon. --- Annex/Path.hs | 31 +++++++-- Assistant.hs | 10 +-- CHANGELOG | 1 + Command/RemoteDaemon.hs | 7 +- Utility/Daemon.hs | 65 ++++++++++--------- ...__evacuate__58___strange_closure_type.mdwn | 3 + ..._a5a7d09ab1bb5bb7e2d37f906b07552d._comment | 8 +++ 7 files changed, 84 insertions(+), 41 deletions(-) create mode 100644 doc/bugs/internal_error__58___evacuate__58___strange_closure_type/comment_2_a5a7d09ab1bb5bb7e2d37f906b07552d._comment diff --git a/Annex/Path.hs b/Annex/Path.hs index 636903c468..11400d32a5 100644 --- a/Annex/Path.hs +++ b/Annex/Path.hs @@ -1,11 +1,17 @@ {- git-annex program path - - - Copyright 2013-2020 Joey Hess + - Copyright 2013-2021 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} -module Annex.Path where +module Annex.Path ( + programPath, + readProgramFile, + gitAnnexChildProcess, + gitAnnexChildProcessParams, + gitAnnexDaemonizeParams, +) where import Annex.Common import Config.Files @@ -13,7 +19,7 @@ import Utility.Env import Annex.PidLock import qualified Annex -import System.Environment (getExecutablePath) +import System.Environment (getExecutablePath, getArgs) {- A fully qualified path to the currently running git-annex program. - @@ -70,9 +76,24 @@ gitAnnexChildProcess subcmd ps f a = do - with some parameters. - - Includes -c values that were passed on the git-annex command line - - or due to --debug being enabled. + - or due to options like --debug being enabled. -} gitAnnexChildProcessParams :: String -> [CommandParam] -> Annex [CommandParam] gitAnnexChildProcessParams subcmd ps = do - cps <- concatMap (\c -> [Param "-c", Param c]) <$> Annex.getGitConfigOverrides + cps <- gitAnnexGitConfigOverrides return (Param subcmd : cps ++ ps) + +gitAnnexGitConfigOverrides :: Annex [CommandParam] +gitAnnexGitConfigOverrides = concatMap (\c -> [Param "-c", Param c]) + <$> Annex.getGitConfigOverrides + +{- Parameters to pass to git-annex when re-running the current command + - to daemonize it. Used with Utility.Daemon.daemonize. -} +gitAnnexDaemonizeParams :: Annex [CommandParam] +gitAnnexDaemonizeParams = do + -- This inclues -c parameters passed to git, as well as ones + -- passed to git-annex. + cps <- gitAnnexGitConfigOverrides + -- Get every parameter git-annex was run with. + ps <- liftIO getArgs + return (map Param ps ++ cps) diff --git a/Assistant.hs b/Assistant.hs index ce9ef930f9..3bfaaaa7f9 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -52,9 +52,9 @@ import Utility.HumanTime import Annex.Perms import Annex.BranchState import Utility.LogFile +import Annex.Path #ifdef mingw32_HOST_OS import Utility.Env -import Annex.Path import System.Environment (getArgs) #endif import qualified Utility.Debug as Debug @@ -80,7 +80,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = createAnnexDirectory (parentDir pidfile) #ifndef mingw32_HOST_OS createAnnexDirectory (parentDir logfile) - logfd <- liftIO $ handleToFd =<< openLog (fromRawFilePath logfile) + let logfd = handleToFd =<< openLog (fromRawFilePath logfile) if foreground then do origout <- liftIO $ catchMaybeIO $ @@ -92,8 +92,10 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser = case startbrowser of Nothing -> Nothing Just a -> Just $ a origout origerr - else - start (Utility.Daemon.daemonize logfd (Just (fromRawFilePath pidfile)) False) Nothing + else do + git_annex <- liftIO programPath + ps <- gitAnnexDaemonizeParams + start (Utility.Daemon.daemonize git_annex ps logfd (Just (fromRawFilePath pidfile)) False) Nothing #else -- Windows doesn't daemonize, but does redirect output to the -- log file. The only way to do so is to restart the program. diff --git a/CHANGELOG b/CHANGELOG index 9173616e12..bb71154ab7 100644 --- a/CHANGELOG +++ b/CHANGELOG @@ -10,6 +10,7 @@ git-annex (8.20210429) UNRELEASED; urgency=medium due to git running the smudge filter unecessarily. * reinject: Error out when run on a file that is not annexed, rather than silently skipping it. + * assistant: Fix a crash on startup by avoiding using forkProcess. -- Joey Hess Mon, 03 May 2021 10:33:10 -0400 diff --git a/Command/RemoteDaemon.hs b/Command/RemoteDaemon.hs index 9f3901b12e..72502d9a6a 100644 --- a/Command/RemoteDaemon.hs +++ b/Command/RemoteDaemon.hs @@ -12,6 +12,7 @@ module Command.RemoteDaemon where import Command import RemoteDaemon.Core import Utility.Daemon +import Annex.Path cmd :: Command cmd = noCommit $ @@ -25,8 +26,10 @@ run o | foregroundDaemonOption o = liftIO runInteractive | otherwise = do #ifndef mingw32_HOST_OS - nullfd <- liftIO $ openFd "/dev/null" ReadOnly Nothing defaultFileFlags - liftIO $ daemonize nullfd Nothing False runNonInteractive + git_annex <- liftIO programPath + ps <- gitAnnexDaemonizeParams + let logfd = openFd "/dev/null" ReadOnly Nothing defaultFileFlags + liftIO $ daemonize git_annex ps logfd Nothing False runNonInteractive #else liftIO $ foreground Nothing runNonInteractive #endif diff --git a/Utility/Daemon.hs b/Utility/Daemon.hs index 9a34255897..60dc2cafa7 100644 --- a/Utility/Daemon.hs +++ b/Utility/Daemon.hs @@ -1,6 +1,6 @@ {- daemon support - - - Copyright 2012-2014 Joey Hess + - Copyright 2012-2021 Joey Hess - - License: BSD-2-clause -} @@ -20,53 +20,58 @@ import Common import Utility.PID #ifndef mingw32_HOST_OS import Utility.LogFile +import Utility.Env #else import System.Win32.Process (terminateProcessById) import Utility.LockFile #endif #ifndef mingw32_HOST_OS -import System.Posix -import Control.Concurrent.Async +import System.Posix hiding (getEnv, getEnvironment) #endif #ifndef mingw32_HOST_OS -{- Run an action as a daemon, with all output sent to a file descriptor. +{- Run an action as a daemon, with all output sent to a file descriptor, + - and in a new session. - - - Can write its pid to a file, to guard against multiple instances - - running and allow easy termination. + - Can write its pid to a file. - - - When successful, does not return. -} -daemonize :: Fd -> Maybe FilePath -> Bool -> IO () -> IO () -daemonize logfd pidfile changedirectory a = do + - This does not double-fork to background, because forkProcess is + - rather fragile and highly unused in haskell programs, so likely to break. + - Instead, it runs the cmd with provided params, in the background, + - which the caller should arrange to run this again. + -} +daemonize :: String -> [CommandParam] -> IO Fd -> Maybe FilePath -> Bool -> IO () -> IO () +daemonize cmd params openlogfd pidfile changedirectory a = do maybe noop checkalreadyrunning pidfile - _ <- forkProcess child1 - out + getEnv envvar >>= \case + Just s | s == cmd -> do + maybe noop lockPidFile pidfile + a + _ -> do + nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags + redir nullfd stdInput + redirLog =<< openlogfd + when changedirectory $ + setCurrentDirectory "/" + environ <- getEnvironment + _ <- createProcess $ + (proc cmd (toCommand params)) + { env = Just (addEntry envvar cmd environ) + , create_group = True + , new_session = True + } + return () where checkalreadyrunning f = maybe noop (const alreadyRunning) =<< checkDaemon f - child1 = do - _ <- tryIO createSession - _ <- forkProcess child2 - out - child2 = do - maybe noop lockPidFile pidfile - when changedirectory $ - setCurrentDirectory "/" - nullfd <- openFd "/dev/null" ReadOnly Nothing defaultFileFlags - redir nullfd stdInput - redirLog logfd - {- In old versions of ghc, forkProcess masks async exceptions; - - unmask them inside the action. -} - wait =<< asyncWithUnmask (\unmask -> unmask a) - out - out = exitImmediately ExitSuccess + envvar = "DAEMONIZED" #endif {- To run an action that is normally daemonized in the forground. -} #ifndef mingw32_HOST_OS -foreground :: Fd -> Maybe FilePath -> IO () -> IO () -foreground logfd pidfile a = do +foreground :: IO Fd -> Maybe FilePath -> IO () -> IO () +foreground openlogfd pidfile a = do #else foreground :: Maybe FilePath -> IO () -> IO () foreground pidfile a = do @@ -74,7 +79,7 @@ foreground pidfile a = do maybe noop lockPidFile pidfile #ifndef mingw32_HOST_OS _ <- tryIO createSession - redirLog logfd + redirLog =<< openlogfd #endif a #ifndef mingw32_HOST_OS diff --git a/doc/bugs/internal_error__58___evacuate__58___strange_closure_type.mdwn b/doc/bugs/internal_error__58___evacuate__58___strange_closure_type.mdwn index 570b356849..ae51630c0a 100644 --- a/doc/bugs/internal_error__58___evacuate__58___strange_closure_type.mdwn +++ b/doc/bugs/internal_error__58___evacuate__58___strange_closure_type.mdwn @@ -39,3 +39,6 @@ local repository version: 8 ### Have you had any luck using git-annex before? (Sometimes we get tired of reading bug reports all day and a lil' positive end note does wonders) +> [[fixed|done]] in git-annex by avoiding using forkProcess. +> If the root cause is a ghc bug it's still unfixed there, but it won't +> affect git-annex. --[[Joey]] diff --git a/doc/bugs/internal_error__58___evacuate__58___strange_closure_type/comment_2_a5a7d09ab1bb5bb7e2d37f906b07552d._comment b/doc/bugs/internal_error__58___evacuate__58___strange_closure_type/comment_2_a5a7d09ab1bb5bb7e2d37f906b07552d._comment new file mode 100644 index 0000000000..1195203a3b --- /dev/null +++ b/doc/bugs/internal_error__58___evacuate__58___strange_closure_type/comment_2_a5a7d09ab1bb5bb7e2d37f906b07552d._comment @@ -0,0 +1,8 @@ +[[!comment format=mdwn + username="joey" + subject="""comment 2""" + date="2021-05-12T17:53:04Z" + content=""" +This might also affect git-annex remotedaemon, although it's running ok in +my tests. However, that could only be due to luck. +"""]] -- 2.30.2