Merge from git-annex.

1 files changed, 37 insertions, 29 deletions

diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index f0331d5..8e406b1 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,
@@ -32,7 +31,9 @@ import Git.FilePath
 import Git.Sha
 import qualified Git.DiffTreeItem as Diff
 
+import qualified Data.ByteString as S
 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 +45,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. -}
@@ -113,12 +118,12 @@ unstageFile' p = pureStreamer $ L.fromStrict $
 	<> indexPath p
 
 {- A streamer that adds a symlink to the index. -}
-stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
+stageSymlink :: RawFilePath -> Sha -> Repo -> IO Streamer
 stageSymlink file sha repo = do
 	!line <- updateIndexLine
 		<$> pure sha
 		<*> pure TreeSymlink
-		<*> toTopFilePath (toRawFilePath file) repo
+		<*> toTopFilePath file repo
 	return $ pureStreamer line
 
 {- A streamer that applies a DiffTreeItem to the index. -}
@@ -131,16 +136,8 @@ indexPath :: TopFilePath -> InternalGitPath
 indexPath = toInternalGitPath . getTopFilePath
 
 {- Refreshes the index, by checking file stat information.  -}
-refreshIndex :: Repo -> ((FilePath -> IO ()) -> IO ()) -> IO Bool
-refreshIndex repo feeder = do
-	(Just h, _, _, p) <- createProcess (gitCreateProcess params repo)
-		{ std_in = CreatePipe }
-	feeder $ \f -> do
-		hPutStr h f
-		hPutStr h "\0"
-	hFlush h
-	hClose h
-	checkSuccessProcess p
+refreshIndex :: Repo -> ((RawFilePath -> IO ()) -> IO ()) -> IO Bool
+refreshIndex repo feeder = withCreateProcess p go
   where
 	params = 
 		[ Param "update-index"
@@ -149,3 +146,14 @@ refreshIndex repo feeder = do
 		, Param "-z"
 		, Param "--stdin"
 		]
+	
+	p = (gitCreateProcess params repo)
+		{ std_in = CreatePipe }
+
+	go (Just h) _ _ pid = do
+		feeder $ \f ->
+			S.hPut h (S.snoc f 0)
+		hFlush h
+		hClose h
+		checkSuccessProcess pid
+	go _ _ _ _ = error "internal"