fix process and FD leak

Fix process and file descriptor leak that was exposed when git-annex was
built with ghc 8.2.1. Apparently ghc has changed its behavior of GC
of open file handles that are pipes to running processes. That
broke git-annex test on OSX due to running out of FDs.

Audited for all uses of Annex.new and made stopCoProcesses be called
once it's done with the state. Fixed several places that might have
leaked in other situations than running the test suite.

This commit was sponsored by Ewen McNeill.

7 files changed, 32 insertions, 21 deletions

diff --git a/Annex/Action.hs b/Annex/Action.hs
index a18ebaf78..fc8be6c91 100644
--- a/Annex/Action.hs
+++ b/Annex/Action.hs
@@ -17,6 +17,10 @@ import System.Posix.Signals
 import Annex.Common
 import qualified Annex
 import Annex.Content
+import Annex.CatFile
+import Annex.CheckAttr
+import Annex.HashObject
+import Annex.CheckIgnore
 
 {- Actions to perform each time ran. -}
 startup :: Annex ()
@@ -32,4 +36,13 @@ shutdown :: Bool -> Annex ()
 shutdown nocommit = do
 	saveState nocommit
 	sequence_ =<< M.elems <$> Annex.getState Annex.cleanup
+	stopCoProcesses
 	liftIO reapZombies -- zombies from long-running git processes
+
+{- Stops all long-running git query processes. -}
+stopCoProcesses :: Annex ()
+stopCoProcesses = do
+	catFileStop
+	checkAttrStop
+	hashObjectStop
+	checkIgnoreStop
diff --git a/Annex/Concurrent.hs b/Annex/Concurrent.hs
index 71a70fa5b..65acb0450 100644
--- a/Annex/Concurrent.hs
+++ b/Annex/Concurrent.hs
@@ -7,12 +7,9 @@
 
 module Annex.Concurrent where
 
-import Annex.Common
 import Annex
-import Annex.CatFile
-import Annex.CheckAttr
-import Annex.HashObject
-import Annex.CheckIgnore
+import Annex.Common
+import Annex.Action
 import qualified Annex.Queue
 
 import qualified Data.Map as M
@@ -61,11 +58,3 @@ mergeState st = do
 		uncurry addCleanup
 	Annex.Queue.mergeFrom st'
 	changeState $ \s -> s { errcounter = errcounter s + errcounter st' }
-
-{- Stops all long-running git query processes. -}
-stopCoProcesses :: Annex ()
-stopCoProcesses = do
-	catFileStop
-	checkAttrStop
-	hashObjectStop
-	checkIgnoreStop
diff --git a/Annex/MakeRepo.hs b/Annex/MakeRepo.hs
index adf49ed2c..e03196664 100644
--- a/Annex/MakeRepo.hs
+++ b/Annex/MakeRepo.hs
@@ -16,6 +16,7 @@ import qualified Git.Branch
 import qualified Annex
 import Annex.UUID
 import Annex.Direct
+import Annex.Action
 import Types.StandardGroups
 import Logs.PreferredContent
 import qualified Annex.Branch
@@ -42,7 +43,7 @@ makeRepo path bare = ifM (probeRepoExists path)
 inDir :: FilePath -> Annex a -> IO a
 inDir dir a = do
 	state <- Annex.new =<< Git.Config.read =<< Git.Construct.fromPath dir
-	Annex.eval state a
+	Annex.eval state $ a `finally` stopCoProcesses
 
 {- Creates a new repository, and returns its UUID. -}
 initRepo :: Bool -> Bool -> FilePath -> Maybe String -> Maybe StandardGroup -> IO UUID
diff --git a/CHANGELOG b/CHANGELOG
index a84187e63..91a4ac53a 100644
--- a/CHANGELOG
+++ b/CHANGELOG
@@ -14,6 +14,9 @@ git-annex (6.20170926) UNRELEASED; urgency=medium
   * test: Fix reversion that made it only run inside a git repository.
   * copy, move: Behave same with --fast when sending to remotes located
     on a local disk as when sending to other remotes.
+  * Fix process and file descriptor leak that was exposed when
+    git-annex was built with ghc 8.2.1. Broke git-annex test on OSX
+    due to running out of FDs, and may have also leaked in other situations.
 
  -- Joey Hess <id@joeyh.name>  Thu, 28 Sep 2017 12:01:39 -0400
 
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 02957fda2..30307d037 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -59,7 +59,7 @@ import Annex.Path
 import Creds
 import Messages.Progress
 import Types.NumCopies
-import Annex.Concurrent
+import Annex.Action
 
 import Control.Concurrent
 import Control.Concurrent.MSampleVar
@@ -311,11 +311,12 @@ tryGitConfigRead autoinit r
 	 - it if allowed. However, if that fails, still return the read
 	 - git config. -}
 	readlocalannexconfig = do
-		s <- Annex.new r
-		Annex.eval s $ do
+		let check = do
 			Annex.BranchState.disableUpdate
 			void $ tryNonAsync $ ensureInitialized
 			Annex.getState Annex.repo
+		s <- Annex.new r
+		Annex.eval s $ check `finally` stopCoProcesses
 		
 	configlistfields = if autoinit
 		then [(Fields.autoInit, "1")]
@@ -611,7 +612,7 @@ repairRemote r a = return $ do
 	Annex.eval s $ do
 		Annex.BranchState.disableUpdate
 		ensureInitialized
-		a
+		a `finally` stopCoProcesses
 
 {- Runs an action from the perspective of a local remote.
  -
@@ -632,7 +633,7 @@ onLocal r a = do
 	go st = do
 		curro <- Annex.getState Annex.output
 		(ret, st') <- liftIO $ Annex.run (st { Annex.output = curro }) $
-			stopCoProcesses `after` a
+			a `finally` stopCoProcesses
 		cache st'
 		return ret
 
diff --git a/Test.hs b/Test.hs
index 5c3f362b5..1fe52ea4a 100644
--- a/Test.hs
+++ b/Test.hs
@@ -82,6 +82,7 @@ import qualified Annex.AdjustedBranch
 import qualified Annex.VectorClock
 import qualified Annex.View
 import qualified Annex.View.ViewedFile
+import qualified Annex.Action
 import qualified Logs.View
 import qualified Utility.Path
 import qualified Utility.FileMode
@@ -1778,7 +1779,7 @@ annexeval a = do
 	s <- Annex.new =<< Git.CurrentRepo.get
 	Annex.eval s $ do
 		Annex.setOutput Types.Messages.QuietOutput
-		a
+		a `finally` Annex.Action.stopCoProcesses
 
 innewrepo :: Assertion -> Assertion
 innewrepo a = withgitrepo $ \r -> indir r a
@@ -1813,7 +1814,8 @@ intmpclonerepoInDirect a = intmpclonerepo $
 checkRepo :: Types.Annex a -> FilePath -> IO a
 checkRepo getval d = do
 	s <- Annex.new =<< Git.Construct.fromPath d
-	Annex.eval s getval
+	Annex.eval s $
+		getval `finally` Annex.Action.stopCoProcesses
 
 isInDirect :: FilePath -> IO Bool
 isInDirect = checkRepo (not <$> Config.isDirect)
diff --git a/doc/bugs/git_annex_test_fails.mdwn b/doc/bugs/git_annex_test_fails.mdwn
index 7e0935095..39668b60f 100644
--- a/doc/bugs/git_annex_test_fails.mdwn
+++ b/doc/bugs/git_annex_test_fails.mdwn
@@ -28,3 +28,5 @@ Full log is here: https://gist.github.com/ilovezfs/1ed886b43d534b239be25f4aa8b73
 Yes!
 
 [[!meta title="OSX git-annex test fails: Too many open files"]]
+
+> [[fixed|done]] --[[Joey]]