refactor

Git/CatFile.hs

@@ -13,7 +13,6 @@ module Git.CatFile (
 	catObject
 ) where
 
-import System.Cmd.Utils
 import System.IO
 import qualified Data.ByteString.Char8 as S
 import qualified Data.ByteString.Lazy.Char8 as L
@@ -22,20 +21,18 @@ import Common
 import Git
 import Git.Sha
 import Git.Command
+import qualified Utility.CoProcess as CoProcess
 
-type CatFileHandle = (PipeHandle, Handle, Handle)
+type CatFileHandle = CoProcess.CoProcessHandle
 
 {- Starts git cat-file running in batch mode in a repo and returns a handle. -}
 catFileStart :: Repo -> IO CatFileHandle
-catFileStart repo = hPipeBoth "git" $ toCommand $
+catFileStart repo = CoProcess.start "git" $ toCommand $
 	gitCommandLine [Param "cat-file", Param "--batch"] repo
 
 {- Stops git cat-file. -}
 catFileStop :: CatFileHandle -> IO ()
-catFileStop (pid, from, to) = do
-	hClose to
-	hClose from
-	forceSuccess pid
+catFileStop = CoProcess.stop
 
 {- Reads a file from a specified branch. -}
 catFile :: CatFileHandle -> Branch -> FilePath -> IO L.ByteString
@@ -44,23 +41,23 @@ catFile h branch file = catObject h $ Ref $ show branch ++ ":" ++ file
 {- Uses a running git cat-file read the content of an object.
  - Objects that do not exist will have "" returned. -}
 catObject :: CatFileHandle -> Ref -> IO L.ByteString
-catObject (_, from, to) object = do
-	hPutStrLn to $ show object
-	hFlush to
-	header <- hGetLine from
-	case words header of
-		[sha, objtype, size]
-			| length sha == shaSize &&
-			  validobjtype objtype -> handle size
-			| otherwise -> dne
-		_
-			| header == show object ++ " missing" -> dne
-			| otherwise -> error $ "unknown response from git cat-file " ++ header
+catObject h object = CoProcess.query h send receive
 	where
-		handle size = case reads size of
-			[(bytes, "")] -> readcontent bytes
-			_ -> dne
-		readcontent bytes = do
+		send to = hPutStrLn to $ show object
+		receive from = do
+			header <- hGetLine from
+			case words header of
+				[sha, objtype, size]
+					| length sha == shaSize &&
+					  validobjtype objtype -> 
+						case reads size of
+							[(bytes, "")] -> readcontent bytes from
+							_ -> dne
+					| otherwise -> dne
+				_
+					| header == show object ++ " missing" -> dne
+					| otherwise -> error $ "unknown response from git cat-file " ++ header
+		readcontent bytes from = do
 			content <- S.hGet from bytes
 			c <- hGetChar from
 			when (c /= '\n') $

Git/CheckAttr.hs

@@ -11,8 +11,9 @@ import Common
 import Git
 import Git.Command
 import qualified Git.Version
+import qualified Utility.CoProcess as CoProcess
 
-type CheckAttrHandle = (PipeHandle, Handle, Handle, [Attr], String)
+type CheckAttrHandle = (CoProcess.CoProcessHandle, [Attr], String)
 
 type Attr = String
 
@@ -21,11 +22,10 @@ type Attr = String
 checkAttrStart :: [Attr] -> Repo -> IO CheckAttrHandle
 checkAttrStart attrs repo = do
 	cwd <- getCurrentDirectory
-	(pid, from, to) <- hPipeBoth "git" $ toCommand $
+	h <- CoProcess.start "git" $ toCommand $
 		gitCommandLine params repo
-	fileEncoding from
-	fileEncoding to
-	return (pid, from, to, attrs, cwd)
+	CoProcess.query h fileEncoding fileEncoding
+	return (h, attrs, cwd)
 	where
 		params =
 			[ Param "check-attr" 
@@ -35,24 +35,21 @@ checkAttrStart attrs repo = do
 
 {- Stops git check-attr. -}
 checkAttrStop :: CheckAttrHandle -> IO ()
-checkAttrStop (pid, from, to, _, _) = do
-	hClose to
-	hClose from
-	forceSuccess pid
+checkAttrStop (h, _, _) = CoProcess.stop h
 
 {- Gets an attribute of a file. -}
 checkAttr :: CheckAttrHandle -> Attr -> FilePath -> IO String
-checkAttr (_, from, to, attrs, cwd) want file = do
-	hPutStr to $ file' ++ "\0"
-	hFlush to
-	pairs <- forM attrs $ \attr -> do
-		l <- hGetLine from
-		return (attr, attrvalue attr l)
+checkAttr (h, attrs, cwd) want file = do
+	pairs <- CoProcess.query h send receive
 	let vals = map snd $ filter (\(attr, _) -> attr == want) pairs
 	case vals of
 		[v] -> return v
 		_ -> error $ "unable to determine " ++ want ++ " attribute of " ++ file
 	where
+		send to = hPutStr to $ file' ++ "\0"
+		receive from = forM attrs $ \attr -> do
+			l <- hGetLine from
+			return (attr, attrvalue attr l)
 		{- Before git 1.7.7, git check-attr worked best with
 		 - absolute filenames; using them worked around some bugs
 		 - with relative filenames.

Git/HashObject.hs

@@ -10,16 +10,16 @@ module Git.HashObject where
 import Common
 import Git
 import Git.Command
+import qualified Utility.CoProcess as CoProcess
 
-type HashObjectHandle = (PipeHandle, Handle, Handle)
+type HashObjectHandle = CoProcess.CoProcessHandle
 
 {- Starts git hash-object and returns a handle.  -}
 hashObjectStart :: Repo -> IO HashObjectHandle
 hashObjectStart repo = do
-	r@(_, _, toh) <- hPipeBoth "git" $
-		toCommand $ gitCommandLine params repo
-	fileEncoding toh
-	return r
+	h <- CoProcess.start "git" $ toCommand $ gitCommandLine params repo
+	CoProcess.query h fileEncoding (const $ return ())
+	return h
 	where
 		params =
 			[ Param "hash-object"
@@ -29,14 +29,11 @@ hashObjectStart repo = do
 
 {- Stops git hash-object. -}
 hashObjectStop :: HashObjectHandle -> IO ()
-hashObjectStop (pid, from, to) = do
-	hClose to
-	hClose from
-	forceSuccess pid
+hashObjectStop = CoProcess.stop
 
 {- Injects a file into git, returning the shas of the objects. -}
 hashFile :: HashObjectHandle -> FilePath -> IO Sha
-hashFile (_, from, to) file = do
-	hPutStrLn to file
-	hFlush to
-	Ref <$> hGetLine from
+hashFile h file = CoProcess.query h send receive
+	where
+		send to = hPutStrLn to file
+		receive from = Ref <$> hGetLine from

Utility/CoProcess.hs

@@ -0,0 +1,35 @@
+{- Interface for running a shell command as a coprocess,
+ - sending it queries and getting back results.
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Utility.CoProcess (
+	CoProcessHandle,
+	start,
+	stop,
+	query
+) where
+
+import System.Cmd.Utils
+
+import Common
+
+type CoProcessHandle = (PipeHandle, Handle, Handle)
+
+start :: FilePath -> [String] -> IO CoProcessHandle
+start command params = hPipeBoth command params
+
+stop :: CoProcessHandle -> IO ()
+stop (pid, from, to) = do
+	hClose to
+	hClose from
+	forceSuccess pid
+
+query :: CoProcessHandle -> (Handle -> IO a) -> (Handle -> IO b) -> IO b
+query (_, from, to) send receive = do
+	_ <- send to
+	hFlush to
+	receive from