5594bf0643
I'm down to 9 places in the code that can produce unwaited for zombies. Most of these are pretty innocuous, at least for now, are only used in short-running commands, or commands that run a set of actions and explicitly reap zombies after each one. The one from Annex.Branch.files could be trouble later, since both Command.Fsck and Command.Unused can trigger it, and the assistant will be doing those eventally. Ditto the one in Git.LsTree.lsTree, which Command.Unused uses. The only ones currently affecting the assistant though, are in Git.LsFiles. Several threads use several of those. (And yeah, using pipes or ResourceT would be a less ad-hoc approach, but I don't really feel like ripping my entire code base apart right now to change a foundation monad. Maybe one of these days..)
77 lines
2.1 KiB
Haskell
77 lines
2.1 KiB
Haskell
{- git-update-index library
|
|
-
|
|
- Copyright 2011, 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE BangPatterns #-}
|
|
|
|
module Git.UpdateIndex (
|
|
Streamer,
|
|
pureStreamer,
|
|
streamUpdateIndex,
|
|
lsTree,
|
|
updateIndexLine,
|
|
unstageFile,
|
|
stageSymlink
|
|
) where
|
|
|
|
import Common
|
|
import Git
|
|
import Git.Types
|
|
import Git.Command
|
|
import Git.FilePath
|
|
import Git.Sha
|
|
|
|
{- Streamers are passed a callback and should feed it lines in the form
|
|
- read by update-index, and generated by ls-tree. -}
|
|
type Streamer = (String -> IO ()) -> IO ()
|
|
|
|
{- A streamer with a precalculated value. -}
|
|
pureStreamer :: String -> Streamer
|
|
pureStreamer !s = \streamer -> streamer s
|
|
|
|
{- Streams content into update-index from a list of Streamers. -}
|
|
streamUpdateIndex :: Repo -> [Streamer] -> IO ()
|
|
streamUpdateIndex repo as = pipeWrite params repo $ \h -> do
|
|
fileEncoding h
|
|
forM_ as (stream h)
|
|
hClose h
|
|
where
|
|
params = map Param ["update-index", "-z", "--index-info"]
|
|
stream h a = a (streamer h)
|
|
streamer h s = do
|
|
hPutStr h s
|
|
hPutStr h "\0"
|
|
|
|
{- A streamer that adds the current tree for a ref. Useful for eg, copying
|
|
- and modifying branches. -}
|
|
lsTree :: Ref -> Repo -> Streamer
|
|
lsTree (Ref x) repo streamer = do
|
|
(s, cleanup) <- pipeNullSplit params repo
|
|
mapM_ streamer s
|
|
void $ cleanup
|
|
where
|
|
params = map Param ["ls-tree", "-z", "-r", "--full-tree", x]
|
|
|
|
{- Generates a line suitable to be fed into update-index, to add
|
|
- a given file with a given sha. -}
|
|
updateIndexLine :: Sha -> BlobType -> TopFilePath -> String
|
|
updateIndexLine sha filetype file =
|
|
show filetype ++ " blob " ++ show sha ++ "\t" ++ getTopFilePath file
|
|
|
|
{- A streamer that removes a file from the index. -}
|
|
unstageFile :: FilePath -> Repo -> IO Streamer
|
|
unstageFile file repo = do
|
|
p <- toTopFilePath file repo
|
|
return $ pureStreamer $ "0 " ++ show nullSha ++ "\t" ++ getTopFilePath p
|
|
|
|
{- A streamer that adds a symlink to the index. -}
|
|
stageSymlink :: FilePath -> Sha -> Repo -> IO Streamer
|
|
stageSymlink file sha repo = do
|
|
!line <- updateIndexLine
|
|
<$> pure sha
|
|
<*> pure SymlinkBlob
|
|
<*> toTopFilePath file repo
|
|
return $ pureStreamer line
|