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

@@ -1,11 +1,17 @@
 {- git-annex program path
  -
- - Copyright 2013-2020 Joey Hess <id@joeyh.name>
+ - Copyright 2013-2021 Joey Hess <id@joeyh.name>
  -
  - 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)

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
+		else do
-			start (Utility.Daemon.daemonize logfd (Just (fromRawFilePath pidfile)) False) Nothing
+			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.

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 <id@joeyh.name>  Mon, 03 May 2021 10:33:10 -0400
 

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
+		git_annex <- liftIO programPath
-		liftIO $ daemonize nullfd Nothing False runNonInteractive
+		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

Utility/Daemon.hs

@@ -1,6 +1,6 @@
 {- daemon support
  -
- - Copyright 2012-2014 Joey Hess <id@joeyh.name>
+ - Copyright 2012-2021 Joey Hess <id@joeyh.name>
  -
  - 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 System.Posix hiding (getEnv, getEnvironment)
-import Control.Concurrent.Async
 #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
+ - Can write its pid to a file.
- - running and allow easy termination.
  -
- - When successful, does not return. -}
+ - This does not double-fork to background, because forkProcess is
-daemonize :: Fd -> Maybe FilePath -> Bool -> IO () -> IO ()
+ - rather fragile and highly unused in haskell programs, so likely to break.
-daemonize logfd pidfile changedirectory a = do
+ - 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
+	getEnv envvar >>= \case
-	out
+		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
+	envvar = "DAEMONIZED"
-		_ <- 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
 #endif
 
 {- To run an action that is normally daemonized in the forground. -}
 #ifndef mingw32_HOST_OS
-foreground :: Fd -> Maybe FilePath -> IO () -> IO ()
+foreground :: IO Fd -> Maybe FilePath -> IO () -> IO ()
-foreground logfd pidfile a = do
+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

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]]

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.
+"""]]