From 2dc7b5186a586acb768744242083ad48d658a538 Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Thu, 4 Jun 2020 12:05:25 -0400
Subject: [PATCH] convert to withCreateProcess for async exception safety

---
 Annex/View.hs      | 15 +++++++--------
 Git/UpdateIndex.hs | 38 +++++++++++++++++++++-----------------
 2 files changed, 28 insertions(+), 25 deletions(-)

diff --git a/Annex/View.hs b/Annex/View.hs
index 6577fd601e..961319699d 100644
--- a/Annex/View.hs
+++ b/Annex/View.hs
@@ -347,14 +347,13 @@ applyView' mkviewedfile getfilemetadata view = do
 	top <- fromRepo Git.repoPath
 	(l, clean) <- inRepo $ Git.LsFiles.stagedDetails [top]
 	liftIO . nukeFile =<< fromRepo gitAnnexViewIndex
-	uh <- withViewIndex $ inRepo Git.UpdateIndex.startUpdateIndex
-	forM_ l $ \(f, sha, mode) -> do
-		topf <- inRepo (toTopFilePath f)
-		go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f
-	liftIO $ do
-		void $ stopUpdateIndex uh
-		void clean
-	genViewBranch view
+	viewg <- withViewIndex gitRepo
+	withUpdateIndex viewg $ \uh -> do
+		forM_ l $ \(f, sha, mode) -> do
+			topf <- inRepo (toTopFilePath f)
+			go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f
+		liftIO $ void clean
+		genViewBranch view
   where
 	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
 
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index f0331d5c1f..b562bff13e 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -1,6 +1,6 @@
 {- git-update-index library
  -
- - Copyright 2011-2019 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2020 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU AGPL version 3 or higher.
  -}
@@ -12,8 +12,7 @@ module Git.UpdateIndex (
 	pureStreamer,
 	streamUpdateIndex,
 	streamUpdateIndex',
-	startUpdateIndex,
-	stopUpdateIndex,
+	withUpdateIndex,
 	lsTree,
 	lsSubTree,
 	updateIndexLine,
@@ -33,6 +32,7 @@ import Git.Sha
 import qualified Git.DiffTreeItem as Diff
 
 import qualified Data.ByteString.Lazy as L
+import Control.Monad.IO.Class
 
 {- Streamers are passed a callback and should feed it lines in the form
  - read by update-index, and generated by ls-tree. -}
@@ -44,28 +44,32 @@ pureStreamer !s = \streamer -> streamer s
 
 {- Streams content into update-index from a list of Streamers. -}
 streamUpdateIndex :: Repo -> [Streamer] -> IO ()
-streamUpdateIndex repo as = bracket (startUpdateIndex repo) stopUpdateIndex $
-	(\h -> forM_ as $ streamUpdateIndex' h)
+streamUpdateIndex repo as = withUpdateIndex repo $ \h ->
+	forM_ as $ streamUpdateIndex' h
 
-data UpdateIndexHandle = UpdateIndexHandle ProcessHandle Handle
+data UpdateIndexHandle = UpdateIndexHandle Handle
 
 streamUpdateIndex' :: UpdateIndexHandle -> Streamer -> IO ()
-streamUpdateIndex' (UpdateIndexHandle _ h) a = a $ \s -> do
+streamUpdateIndex' (UpdateIndexHandle h) a = a $ \s -> do
 	L.hPutStr h s
 	L.hPutStr h "\0"
 
-startUpdateIndex :: Repo -> IO UpdateIndexHandle
-startUpdateIndex repo = do
-	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
-		{ std_in = CreatePipe }
-	return $ UpdateIndexHandle p h
+withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a
+withUpdateIndex repo a = bracket setup cleanup go
   where
 	params = map Param ["update-index", "-z", "--index-info"]
-
-stopUpdateIndex :: UpdateIndexHandle -> IO Bool
-stopUpdateIndex (UpdateIndexHandle p h) = do
-	hClose h
-	checkSuccessProcess p
+	
+	setup = liftIO $ createProcess $ 
+		(gitCreateProcess params repo)
+			{ std_in = CreatePipe }
+	go p = do
+		r <- a (UpdateIndexHandle (stdinHandle p))
+		liftIO $ do
+			hClose (stdinHandle p)
+			void $ checkSuccessProcess (processHandle p)
+		return r
+	
+	cleanup = liftIO . cleanupProcess
 
 {- A streamer that adds the current tree for a ref. Useful for eg, copying
  - and modifying branches. -}