assistant: Batch jobs are now run with ionice and nocache, when those commands are available.
This commit is contained in:
parent
3c6be8cd6e
commit
4882a611e5
6 changed files with 42 additions and 31 deletions
|
@ -50,8 +50,9 @@ bundledPrograms = catMaybes
|
||||||
, Just "gunzip"
|
, Just "gunzip"
|
||||||
, Just "tar"
|
, Just "tar"
|
||||||
#endif
|
#endif
|
||||||
-- nice and ionice are not included in the bundle; we rely on the
|
-- nice, ionice, and nocache are not included in the bundle;
|
||||||
-- system's own version, which may better match its kernel
|
-- we rely on the system's own version, which may better match
|
||||||
|
-- its kernel, and avoid using them if not available.
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
ifset True s = Just s
|
ifset True s = Just s
|
||||||
|
|
|
@ -37,17 +37,16 @@ data FsckResults = FsckFoundMissing MissingObjects | FsckFailed
|
||||||
-}
|
-}
|
||||||
findBroken :: Bool -> Repo -> IO FsckResults
|
findBroken :: Bool -> Repo -> IO FsckResults
|
||||||
findBroken batchmode r = do
|
findBroken batchmode r = do
|
||||||
|
let (command, params) = ("git", fsckParams r)
|
||||||
|
(command', params') <- if batchmode
|
||||||
|
then toBatchCommand (command, params)
|
||||||
|
else return (command, params)
|
||||||
(output, fsckok) <- processTranscript command' (toCommand params') Nothing
|
(output, fsckok) <- processTranscript command' (toCommand params') Nothing
|
||||||
let objs = findShas output
|
let objs = findShas output
|
||||||
badobjs <- findMissing objs r
|
badobjs <- findMissing objs r
|
||||||
if S.null badobjs && not fsckok
|
if S.null badobjs && not fsckok
|
||||||
then return FsckFailed
|
then return FsckFailed
|
||||||
else return $ FsckFoundMissing badobjs
|
else return $ FsckFoundMissing badobjs
|
||||||
where
|
|
||||||
(command, params) = ("git", fsckParams r)
|
|
||||||
(command', params')
|
|
||||||
| batchmode = toBatchCommand (command, params)
|
|
||||||
| otherwise = (command, params)
|
|
||||||
|
|
||||||
foundBroken :: FsckResults -> Bool
|
foundBroken :: FsckResults -> Bool
|
||||||
foundBroken FsckFailed = True
|
foundBroken FsckFailed = True
|
||||||
|
|
|
@ -10,9 +10,6 @@
|
||||||
module Utility.Batch where
|
module Utility.Batch where
|
||||||
|
|
||||||
import Common
|
import Common
|
||||||
#ifndef mingw32_HOST_OS
|
|
||||||
import qualified Build.SysConfig
|
|
||||||
#endif
|
|
||||||
|
|
||||||
#if defined(linux_HOST_OS) || defined(__ANDROID__)
|
#if defined(linux_HOST_OS) || defined(__ANDROID__)
|
||||||
import Control.Concurrent.Async
|
import Control.Concurrent.Async
|
||||||
|
@ -46,36 +43,43 @@ batch a = a
|
||||||
maxNice :: Int
|
maxNice :: Int
|
||||||
maxNice = 19
|
maxNice = 19
|
||||||
|
|
||||||
{- Converts a command to run niced. -}
|
{- Makes a command be run by whichever of nice, ionice, and nocache
|
||||||
toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam])
|
- are available in the path. -}
|
||||||
toBatchCommand (command, params) = (command', params')
|
toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam])
|
||||||
where
|
toBatchCommand (command, params) = do
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
commandline = unwords $ map shellEscape $ command : toCommand params
|
nicers <- filterM (inPath . fst)
|
||||||
nicedcommand
|
[ ("nice", [])
|
||||||
| Build.SysConfig.nice = "nice " ++ commandline
|
, ("ionice", ["-c3"])
|
||||||
| otherwise = commandline
|
, ("nocache", [])
|
||||||
command' = "sh"
|
]
|
||||||
params' =
|
let command' = "sh"
|
||||||
|
let params' =
|
||||||
[ Param "-c"
|
[ Param "-c"
|
||||||
, Param $ "exec " ++ nicedcommand
|
, Param $ unwords $
|
||||||
|
"exec"
|
||||||
|
: concatMap (\p -> fst p : snd p) nicers
|
||||||
|
++ map shellEscape (command : toCommand params)
|
||||||
]
|
]
|
||||||
#else
|
#else
|
||||||
command' = command
|
let command' = command
|
||||||
params' = params
|
let params' = params
|
||||||
#endif
|
#endif
|
||||||
|
return (command', params')
|
||||||
|
|
||||||
{- Runs a command in a way that's suitable for batch jobs that can be
|
{- Runs a command in a way that's suitable for batch jobs that can be
|
||||||
- interrupted.
|
- interrupted.
|
||||||
-
|
-
|
||||||
- The command is run niced. If the calling thread receives an async
|
- If the calling thread receives an async exception, it sends the
|
||||||
- exception, it sends the command a SIGTERM, and after the command
|
- command a SIGTERM, and after the command finishes shuttting down,
|
||||||
- finishes shuttting down, it re-raises the async exception. -}
|
- it re-raises the async exception. -}
|
||||||
batchCommand :: String -> [CommandParam] -> IO Bool
|
batchCommand :: String -> [CommandParam] -> IO Bool
|
||||||
batchCommand command params = batchCommandEnv command params Nothing
|
batchCommand command params = batchCommandEnv command params Nothing
|
||||||
|
|
||||||
batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
|
batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool
|
||||||
batchCommandEnv command params environ = do
|
batchCommandEnv command params environ = do
|
||||||
|
(command', params') <- toBatchCommand (command, params)
|
||||||
|
let p = proc command' $ toCommand params'
|
||||||
(_, _, _, pid) <- createProcess $ p { env = environ }
|
(_, _, _, pid) <- createProcess $ p { env = environ }
|
||||||
r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)
|
r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode)
|
||||||
case r of
|
case r of
|
||||||
|
@ -85,7 +89,3 @@ batchCommandEnv command params environ = do
|
||||||
terminateProcess pid
|
terminateProcess pid
|
||||||
void $ waitForProcess pid
|
void $ waitForProcess pid
|
||||||
E.throwIO asyncexception
|
E.throwIO asyncexception
|
||||||
where
|
|
||||||
(command', params') = toBatchCommand (command, params)
|
|
||||||
p = proc command' $ toCommand params'
|
|
||||||
|
|
||||||
|
|
2
debian/changelog
vendored
2
debian/changelog
vendored
|
@ -2,6 +2,8 @@ git-annex (5.20131131) UNRELEASED; urgency=low
|
||||||
|
|
||||||
* Avoid using git commit in direct mode, since in some situations
|
* Avoid using git commit in direct mode, since in some situations
|
||||||
it will read the full contents of files in the tree.
|
it will read the full contents of files in the tree.
|
||||||
|
* assistant: Batch jobs are now run with ionice and nocache, when
|
||||||
|
those commands are available.
|
||||||
|
|
||||||
-- Joey Hess <joeyh@debian.org> Sun, 01 Dec 2013 13:57:58 -0400
|
-- Joey Hess <joeyh@debian.org> Sun, 01 Dec 2013 13:57:58 -0400
|
||||||
|
|
||||||
|
|
9
debian/control
vendored
9
debian/control
vendored
|
@ -73,7 +73,14 @@ Depends: ${misc:Depends}, ${shlibs:Depends},
|
||||||
wget,
|
wget,
|
||||||
curl,
|
curl,
|
||||||
openssh-client (>= 1:5.6p1)
|
openssh-client (>= 1:5.6p1)
|
||||||
Recommends: lsof, gnupg, bind9-host, ssh-askpass, quvi, git-remote-gcrypt (>= 0.20130908-4)
|
Recommends:
|
||||||
|
lsof,
|
||||||
|
gnupg,
|
||||||
|
bind9-host,
|
||||||
|
ssh-askpass,
|
||||||
|
quvi,
|
||||||
|
git-remote-gcrypt (>= 0.20130908-4),
|
||||||
|
nocache
|
||||||
Suggests: graphviz, bup, libnss-mdns
|
Suggests: graphviz, bup, libnss-mdns
|
||||||
Description: manage files with git, without checking their contents into git
|
Description: manage files with git, without checking their contents into git
|
||||||
git-annex allows managing files with git, without checking the file
|
git-annex allows managing files with git, without checking the file
|
||||||
|
|
|
@ -65,6 +65,8 @@ quite a lot.
|
||||||
(optional; recommended for watch mode)
|
(optional; recommended for watch mode)
|
||||||
* [gcrypt](https://github.com/joeyh/git-remote-gcrypt)
|
* [gcrypt](https://github.com/joeyh/git-remote-gcrypt)
|
||||||
(optional)
|
(optional)
|
||||||
|
* [nocache](https://github.com/Feh/nocache)
|
||||||
|
(optional)
|
||||||
* multicast DNS support, provided on linux by [nss-mdns](http://www.0pointer.de/lennart/projects/nss-mdns/)
|
* multicast DNS support, provided on linux by [nss-mdns](http://www.0pointer.de/lennart/projects/nss-mdns/)
|
||||||
(optional; recommended for the assistant to support pairing well)
|
(optional; recommended for the assistant to support pairing well)
|
||||||
* [ikiwiki](http://ikiwiki.info) (optional; used to build the docs)
|
* [ikiwiki](http://ikiwiki.info) (optional; used to build the docs)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue