diff options
| -rw-r--r-- | CmdLine.hs | 1 | ||||
| -rw-r--r-- | Command.hs | 8 | ||||
| -rw-r--r-- | Command/Log.hs | 2 | ||||
| -rw-r--r-- | Git/Command.hs | 12 | ||||
| -rw-r--r-- | Utility/Misc.hs | 14 | ||||
| -rw-r--r-- | Utility/Rsync.hs | 9 |
6 files changed, 25 insertions, 21 deletions
diff --git a/CmdLine.hs b/CmdLine.hs index 331c363e4..66bf5b882 100644 --- a/CmdLine.hs +++ b/CmdLine.hs @@ -117,5 +117,6 @@ shutdown :: Bool -> Annex Bool shutdown nocommit = do saveState nocommit sequence_ =<< M.elems <$> Annex.getState Annex.cleanup + liftIO reapZombies -- zombies from long-running git processes sshCleanup -- ssh connection caching return True diff --git a/Command.hs b/Command.hs index 145ad5003..8e7bf9758 100644 --- a/Command.hs +++ b/Command.hs @@ -39,7 +39,6 @@ import Usage as ReExported import Logs.Trust import Config import Annex.CheckAttr -import qualified Git.Command {- Generates a normal command -} command :: String -> String -> [CommandSeek] -> String -> Command @@ -84,14 +83,11 @@ doCommand = start where start = stage $ maybe skip perform perform = stage $ maybe failure cleanup - cleanup = stage $ end + cleanup = stage $ status stage = (=<<) skip = return True failure = showEndFail >> return False - end r = do - -- zombies from long-running git processes - liftIO Git.Command.reap - showEndResult r >> return r + status r = showEndResult r >> return r {- Modifies an action to only act on files that are already annexed, - and passes the key and backend on to it. -} diff --git a/Command/Log.hs b/Command/Log.hs index c3ce67986..09d22b2ef 100644 --- a/Command/Log.hs +++ b/Command/Log.hs @@ -70,7 +70,7 @@ start :: M.Map UUID String -> TimeZone -> [CommandParam] -> Bool -> start m zone os gource file (key, _) = do showLog output =<< readLog <$> getLog key os -- getLog produces a zombie; reap it - liftIO Git.Command.reap + liftIO reapZombies stop where output diff --git a/Git/Command.hs b/Git/Command.hs index 5f2dd47b0..37df44713 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -7,7 +7,6 @@ module Git.Command where -import System.Posix.Process (getAnyProcessStatus) import System.Process (std_out, env) import Common @@ -97,17 +96,6 @@ pipeNullSplitZombie params repo = leaveZombie <$> pipeNullSplit params repo leaveZombie :: (a, IO Bool) -> a leaveZombie = fst -{- Reaps any zombie git processes. - - - - Warning: Not thread safe. Anything that was expecting to wait - - on a process and get back an exit status is going to be confused - - if this reap gets there first. -} -reap :: IO () -reap = do - -- throws an exception when there are no child processes - catchDefaultIO Nothing (getAnyProcessStatus False True) - >>= maybe noop (const reap) - {- Runs a git command as a coprocess. -} gitCoProcessStart :: [CommandParam] -> Repo -> IO CoProcess.CoProcessHandle gitCoProcessStart params repo = CoProcess.start "git" (toCommand $ gitCommandLine params repo) (gitEnv repo) diff --git a/Utility/Misc.hs b/Utility/Misc.hs index f03504040..7c81f56fd 100644 --- a/Utility/Misc.hs +++ b/Utility/Misc.hs @@ -12,6 +12,9 @@ import Control.Monad import Foreign import Data.Char import Control.Applicative +import System.Posix.Process (getAnyProcessStatus) + +import Utility.Exception {- A version of hgetContents that is not lazy. Ensures file is - all read before it gets closed. -} @@ -96,3 +99,14 @@ hGetSomeString h sz = do where peekbytes :: Int -> Ptr Word8 -> IO [Word8] peekbytes len buf = mapM (peekElemOff buf) [0..pred len] + +{- Reaps any zombie git processes. + - + - Warning: Not thread safe. Anything that was expecting to wait + - on a process and get back an exit status is going to be confused + - if this reap gets there first. -} +reapZombies :: IO () +reapZombies = do + -- throws an exception when there are no child processes + catchDefaultIO Nothing (getAnyProcessStatus False True) + >>= maybe (return ()) (const reapZombies) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index f8e19eb57..68d27550c 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -53,8 +53,13 @@ rsync = boolSystem "rsync" - The params must enable rsync's --progress mode for this to work. -} rsyncProgress :: (Integer -> IO ()) -> [CommandParam] -> IO Bool -rsyncProgress callback params = - withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) +rsyncProgress callback params = do + r <- withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) + {- For an unknown reason, piping rsync's output like this does + - causes it to run a second ssh process, which it neglects to wait + - on. Reap the resulting zombie. -} + reapZombies + return r where p = proc "rsync" (toCommand params) feedprogress prev buf h = do |