From 7e592e1d6ed5e0b25b37215da7558c6324688d6f Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@debian.org>
Date: Fri, 22 Nov 2013 11:16:03 -0400
Subject: git-repair (1.20131122) unstable; urgency=low

  * Added test mode, which can be used to randomly corrupt test
    repositories, in reproducible ways, which allows easy
    corruption-driven-development.
  * Improve repair code in the case where the index file is corrupt,
    and this hides other problems.
  * Write a dummy .git/HEAD if the file is missing or corrupt, as
    git otherwise will not treat the repository as a git repo.
  * Improve fsck code to find badly corrupted objects that crash git fsck
    before it can complain about them.
  * Fixed crashes on bad file encodings.
  * Can now run 10000 tests (git-repair --test -n 10000 --force)
    with 0 failures.

# imported from the archive
---
 Utility/Batch.hs | 91 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 91 insertions(+)
 create mode 100644 Utility/Batch.hs

(limited to 'Utility/Batch.hs')

diff --git a/Utility/Batch.hs b/Utility/Batch.hs
new file mode 100644
index 0000000..035a2eb
--- /dev/null
+++ b/Utility/Batch.hs
@@ -0,0 +1,91 @@
+{- Running a long or expensive batch operation niced.
+ -
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE CPP #-}
+
+module Utility.Batch where
+
+import Common
+#ifndef mingw32_HOST_OS
+import qualified Build.SysConfig
+#endif
+
+#if defined(linux_HOST_OS) || defined(__ANDROID__)
+import Control.Concurrent.Async
+import System.Posix.Process
+#endif
+import qualified Control.Exception as E
+import System.Process (env)
+
+{- Runs an operation, at batch priority.
+ -
+ - This is done by running it in a bound thread, which on Linux can be set
+ - to have a different nice level than the rest of the program. Note that
+ - due to running in a bound thread, some operations may be more expensive
+ - to perform. Also note that if the action calls forkIO or forkOS itself,
+ - that will make a new thread that does not have the batch priority.
+ -
+ - POSIX threads do not support separate nice levels, so on other operating
+ - systems, the action is simply ran.
+ -}
+batch :: IO a -> IO a
+#if defined(linux_HOST_OS) || defined(__ANDROID__)
+batch a = wait =<< batchthread
+  where
+  	batchthread = asyncBound $ do
+		setProcessPriority 0 maxNice
+		a
+#else
+batch a = a
+#endif
+
+maxNice :: Int
+maxNice = 19
+
+{- Converts a command to run niced. -}
+toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam])
+toBatchCommand (command, params) = (command', params')
+  where
+#ifndef mingw32_HOST_OS
+	commandline = unwords $ map shellEscape $ command : toCommand params
+	nicedcommand
+		| Build.SysConfig.nice = "nice " ++ commandline
+		| otherwise = commandline
+	command' = "sh"
+	params' =
+		[ Param "-c"
+		, Param $ "exec " ++ nicedcommand
+		]
+#else
+	command' = command
+	params' = params
+#endif
+
+{- Runs a command in a way that's suitable for batch jobs that can be
+ - interrupted.
+ -
+ - The command is run niced. If the calling thread receives an async
+ - exception, it sends the command a SIGTERM, and after the command
+ - finishes shuttting down, it re-raises the async exception. -}
+batchCommand :: String -> [CommandParam] -> IO Bool
+batchCommand command params = batchCommandEnv command params Nothing
+
+batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
+batchCommandEnv command params environ = do
+	(_, _, _, pid) <- createProcess $ p { env = environ }
+	r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)
+	case r of
+		Right ExitSuccess -> return True
+		Right _ -> return False
+		Left asyncexception -> do
+			terminateProcess pid
+			void $ waitForProcess pid
+			E.throwIO asyncexception
+  where
+  	(command', params') = toBatchCommand (command, params)
+  	p = proc command' $ toCommand params'
+
-- 
cgit v1.2.3