noCreateProcessWhile to fix close-on-exec races

Sponsored-by: the NIH-funded NICEMAN (ReproNim TR&D3) project

Annex/Multicast.hs

@@ -1,18 +1,23 @@
 {- git-annex multicast receive callback
  -
- - Copyright 2017 Joey Hess <id@joeyh.name>
+ - Copyright 2017-2025 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Annex.Multicast where
 
 import Common
 import Annex.Path
 import Utility.Env
 
-import Utility.Process
-import GHC.IO.Handle.FD
+#ifndef mingw32_HOST_OS
+import System.Posix.IO
+#else
+import System.Process (createPipeFd)
+#endif
 
 multicastReceiveEnv :: String
 multicastReceiveEnv = "GIT_ANNEX_MULTICAST_RECEIVE"
@@ -20,8 +25,14 @@ multicastReceiveEnv = "GIT_ANNEX_MULTICAST_RECEIVE"
 multicastCallbackEnv :: IO (OsPath, [(String, String)], Handle)
 multicastCallbackEnv = do
 	gitannex <- programPath
-	-- This will even work on Windows
+#ifndef mingw32_HOST_OS
+	(rfd, wfd) <- noCreateProcessWhile $ do
+		(rfd, wfd) <- createPipe
+		setFdOption rfd CloseOnExec True
+		return (rfd, wfd)
+#else
 	(rfd, wfd) <- createPipeFd
+#endif
 	rh <- fdToHandle rfd
 	environ <- addEntry multicastReceiveEnv (show wfd) <$> getEnvironment
 	return (gitannex, environ, rh)

Remote/Directory.hs

@@ -470,7 +470,7 @@ retrieveExportWithContentIdentifierM ii dir cow loc cids dest gk p =
 
 	docopynoncow iv = do
 #ifndef mingw32_HOST_OS
-		let open = do
+		let open = noCreateProcessWhile $ do
 			fd <- openFdWithMode f' ReadOnly Nothing
 				defaultFileFlags (CloseOnExecFlag True)
 			-- Need a duplicate fd for the post check.

Utility/FileIO/CloseOnExec.hs

@@ -42,6 +42,7 @@ import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy as BSL
 #ifndef mingw32_HOST_OS
 import System.Posix.IO
+import Utility.Process
 #endif
 
 closeOnExec :: Bool
@@ -92,24 +93,22 @@ appendFile'
   :: OsPath -> BS.ByteString -> IO ()
 appendFile' fp contents = withFile fp AppendMode (`BS.hPut` contents)
 
-{- Unlike all other functions in this module, this only sets the
- - close-on-exec flag after opening the file. Thus, it is vulnerable to
- - races.
- -
- - Re-implementing openTempFile is difficult due to the current
+{- Re-implementing openTempFile is difficult due to the current
  - structure of file-io. See this issue for discussion about improving
  - that: https://github.com/haskell/file-io/issues/44
+ - So, instead this uses noCreateProcessWhile.
  - -}
 openTempFile :: OsPath -> OsString -> IO (OsPath, Handle)
-openTempFile tmp_dir template = do
-	(p, h) <- I.openTempFile tmp_dir template
-#ifndef mingw32_HOST_OS
-	fd <- handleToFd h
-	setFdOption fd CloseOnExec True
-	h' <- fdToHandle fd
-	pure (p, h')
+openTempFile tmp_dir template =
+#ifdef mingw32_HOST_OS
+	I.openTempFile tmp_dir template
 #else
-	pure (p, h)
+	noCreateProcessWhile $ do
+		(p, h) <- I.openTempFile tmp_dir template
+		fd <- handleToFd h
+		setFdOption fd CloseOnExec True
+		h' <- fdToHandle fd
+		pure (p, h')
 #endif
 
 #endif

Utility/Gpg.hs

@@ -162,8 +162,10 @@ feedRead cmd params passphrase feeder reader = do
 #ifndef mingw32_HOST_OS
 	let setup = liftIO $ do
 		-- pipe the passphrase into gpg on a fd
-		(frompipe, topipe) <- System.Posix.IO.createPipe
-		setFdOption topipe CloseOnExec True
+		(frompipe, topipe) <- noCreateProcessWhile $ do
+			(frompipe, topipe) <- System.Posix.IO.createPipe
+			setFdOption topipe CloseOnExec True
+			return (frompipe, topipe)
 		toh <- fdToHandle topipe
 		t <- async $ do
 			B.hPutStr toh (passphrase <> "\n")

Utility/Process.hs

@@ -1,5 +1,6 @@
 {- System.Process enhancements, including additional ways of running
- - processes, and logging.
+ - processes, logging, and amelorations for cases where FDs are not able to
+ - be opened with close-on-exec.
  -
  - Copyright 2012-2025 Joey Hess <id@joeyh.name>
  -
@@ -21,6 +22,7 @@ module Utility.Process (
 	forceSuccessProcess',
 	checkSuccessProcess,
 	withNullHandle,
+	noCreateProcessWhile,
 	createProcess,
 	withCreateProcess,
 	waitForProcess,
@@ -46,7 +48,9 @@ import System.Exit
 import System.IO
 import Control.Monad.IO.Class
 import Control.Concurrent.Async
+import Control.Concurrent
 import qualified Data.ByteString as S
+import System.IO.Unsafe (unsafePerformIO)
 
 data StdHandle = StdinHandle | StdoutHandle | StderrHandle
 	deriving (Eq)
@@ -173,9 +177,34 @@ startInteractiveProcess cmd args environ = do
 	(Just from, Just to, _, pid) <- createProcess p
 	return (pid, to, from)
 
--- | Wrapper around 'System.Process.createProcess' that does debug logging.
+-- | Runs an action, preventing any new processes from being started
+-- until it is finished.
+--
+-- Unfortunately, Haskell has a pervasive problem with the close-on-exec
+-- flag not being set when opening files. It's also difficult to portably
+-- dup or pipe a FD with the close-on-exec flag set. So, this can be used
+-- to run an action that opens a FD, and then calls setFdOption to set the
+-- close-on-exec flag, without risking a race with a process being forked
+-- at the same time.
+--
+-- Note that only one of these actions can run at a time, and long-duration
+-- actions are not advisable.
+noCreateProcessWhile :: (MonadIO m, MonadMask m) => (m a) -> m a
+noCreateProcessWhile = bracket setup cleanup . const
+  where
+	setup = liftIO $ takeMVar createProcessSem
+	cleanup () = liftIO $ putMVar createProcessSem ()
+
+-- | A shared global MVar. Processes are not created while it is empty.
+{-# NOINLINE createProcessSem #-}
+createProcessSem :: MVar ()
+createProcessSem = unsafePerformIO $ newMVar ()
+
+-- | Wrapper around 'System.Process.createProcess'. 
+-- This adds debug logging, and avoids starting a process when in a
+-- noCreateProcessWhile block.
 createProcess :: CreateProcess -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
-createProcess p = do
+createProcess p = noCreateProcessWhile $ do
 	r@(_, _, _, h) <- Utility.Process.Shim.createProcess p
 	debugProcess p h
 	return r

Utility/Process/Transcript.hs

@@ -45,7 +45,7 @@ processTranscript'' cp input = do
 #ifndef mingw32_HOST_OS
 {- This implementation interleves stdout and stderr in exactly the order
  - the process writes them. -}
- 	let setup = do
+ 	let setup = noCreateProcessWhile $ do
 		(readf, writef) <- System.Posix.IO.createPipe
 		System.Posix.IO.setFdOption readf System.Posix.IO.CloseOnExec True
 		System.Posix.IO.setFdOption writef System.Posix.IO.CloseOnExec True

Utility/StatelessOpenPGP.hs

@@ -141,8 +141,10 @@ feedRead cmd subcmd params password emptydirectory feeder reader = do
 #ifndef mingw32_HOST_OS
 	let setup = liftIO $ do
 		-- pipe the passphrase in on a fd
-		(frompipe, topipe) <- System.Posix.IO.createPipe
-		setFdOption topipe CloseOnExec True
+		(frompipe, topipe) <- noCreateProcessWhile $ do
+			(frompipe, topipe) <- System.Posix.IO.createPipe
+			setFdOption topipe CloseOnExec True
+			return (frompipe, topipe)
 		toh <- fdToHandle topipe
 		t <- async $ do
 			B.hPutStr toh (password <> "\n")

doc/bugs/35_failed_tests_on_beegfs.mdwn

@@ -81,3 +81,5 @@ upgrade supported from repository versions: 0 1 2 3 4 5 6 7 8 9 10
 
 [[!meta author=yoh]]
 [[!tag projects/repronim]]
+
+> [[fixed|done]] --[[Joey]]

doc/bugs/35_failed_tests_on_beegfs/comment_13_e7346cc5c2946bf0e7bbea8001ebaf2f._comment

@@ -14,8 +14,4 @@ sandboxing untrusted code, it's on you to avoid exposing open Fds to it.
 
 However, since security is involved, it does need to be fixed comprehensively
 in git-annex, including the remaining races.
-
-And, I have decided that this fix can't be tied to the OsPath flag being
-set. It needs to be fixed when git-annex is built without that flag, or the
-flag needs to go away.
 """]]

doc/bugs/35_failed_tests_on_beegfs/comment_14_f32cbccbf7cd0eaded267b074ad573c4._comment

@@ -0,0 +1,7 @@
+[[!comment format=mdwn
+ username="joey"
+ subject="""comment 14"""
+ date="2025-09-10T18:27:50Z"
+ content="""
+Implemented the global MVar fix for remaining races.
+"""]]