convert to withCreateProcess for async exception safety

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
+	viewg <- withViewIndex gitRepo
-	forM_ l $ \(f, sha, mode) -> do
+	withUpdateIndex viewg $ \uh -> do
-		topf <- inRepo (toTopFilePath f)
+		forM_ l $ \(f, sha, mode) -> do
-		go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f
+			topf <- inRepo (toTopFilePath f)
-	liftIO $ do
+			go uh topf sha (toTreeItemType =<< mode) =<< lookupFile f
-		void $ stopUpdateIndex uh
+		liftIO $ void clean
-		void clean
+		genViewBranch view
-	genViewBranch view
   where
 	genviewedfiles = viewedFiles view mkviewedfile -- enables memoization
 

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,
+	withUpdateIndex,
-	stopUpdateIndex,
 	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 $
+streamUpdateIndex repo as = withUpdateIndex repo $ \h ->
-	(\h -> forM_ as $ streamUpdateIndex' 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
+withUpdateIndex :: (MonadIO m, MonadMask m) => Repo -> (UpdateIndexHandle -> m a) -> m a
-startUpdateIndex repo = do
+withUpdateIndex repo a = bracket setup cleanup go
-	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
-		{ std_in = CreatePipe }
-	return $ UpdateIndexHandle p h
   where
 	params = map Param ["update-index", "-z", "--index-info"]
 	
-stopUpdateIndex :: UpdateIndexHandle -> IO Bool
+	setup = liftIO $ createProcess $ 
-stopUpdateIndex (UpdateIndexHandle p h) = do
+		(gitCreateProcess params repo)
-	hClose h
+			{ std_in = CreatePipe }
-	checkSuccessProcess p
+	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. -}