git-annex/Command/Assistant.hs

136 lines
3.6 KiB
Haskell
Raw Normal View History

{- git-annex assistant
-
- Copyright 2012-2017 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
module Command.Assistant where
import Command
import qualified Command.Watch
2014-01-26 20:36:31 +00:00
import Annex.Init
import Annex.Path
2013-04-23 15:38:52 +00:00
import Config.Files
import qualified BuildInfo
import Utility.HumanTime
import Assistant.Install
import Control.Concurrent.Async
cmd :: Command
cmd = dontCheck repoExists $ notBareRepo $
noRepo (startNoRepo <$$> optParser) $
command "assistant" SectionCommon
"automatically sync changes"
paramNothing (seek <$$> optParser)
data AssistantOptions = AssistantOptions
{ daemonOptions :: DaemonOptions
, autoStartOption :: Bool
, startDelayOption :: Maybe Duration
, autoStopOption :: Bool
}
optParser :: CmdParamsDesc -> Parser AssistantOptions
optParser _ = AssistantOptions
<$> parseDaemonOptions True
<*> switch
( long "autostart"
<> help "start in known repositories"
)
<*> optional (option (eitherReader parseDuration)
( long "startdelay" <> metavar paramNumber
<> help "delay before running startup scan"
))
<*> switch
( long "autostop"
<> help "stop in known repositories"
)
seek :: AssistantOptions -> CommandSeek
seek = commandAction . start
start :: AssistantOptions -> CommandStart
start o
| autoStartOption o = do
liftIO $ autoStart o
stop
| autoStopOption o = do
liftIO autoStop
stop
| otherwise = do
liftIO ensureInstalled
ensureInitialized
Command.Watch.start True (daemonOptions o) (startDelayOption o)
startNoRepo :: AssistantOptions -> IO ()
startNoRepo o
| autoStartOption o = autoStart o
| autoStopOption o = autoStop
| otherwise = giveup "Not in a git repository."
-- Does not return
autoStart :: AssistantOptions -> IO ()
autoStart o = do
dirs <- liftIO readAutoStartFile
when (null dirs) $ do
f <- autoStartFile
giveup $ "Nothing listed in " ++ f
program <- programPath
haveionice <- pure BuildInfo.ionice <&&> inPath "ionice"
pids <- forM dirs $ \d -> do
putStrLn $ "git-annex autostart in " ++ d
mpid <- catchMaybeIO $ go haveionice program d
if foregroundDaemonOption (daemonOptions o)
then return mpid
else do
case mpid of
Nothing -> putStrLn "failed"
Just pid -> ifM (checkSuccessProcess pid)
( putStrLn "ok"
, putStrLn "failed"
)
return Nothing
-- Wait for any foreground jobs to finish and propigate exit status.
ifM (all (== True) <$> mapConcurrently checkSuccessProcess (catMaybes pids))
( exitSuccess
, exitFailure
)
2012-11-12 05:05:04 +00:00
where
go haveionice program dir = do
setCurrentDirectory dir
-- First stop any old daemon running in this directory, which
-- might be a leftover from an old login session. Such a
-- leftover might be left in an environment where it is
-- unable to use the ssh agent or other login session
-- resources.
void $ boolSystem program [Param "assistant", Param "--stop"]
(Nothing, Nothing, Nothing, pid) <- createProcess p
return pid
where
p
| haveionice = proc "ionice"
(toCommand $ Param "-c3" : Param program : baseparams)
| otherwise = proc program
(toCommand baseparams)
baseparams = catMaybes
[ Just $ Param "assistant"
, Just $ Param $ "--startdelay=" ++ fromDuration (fromMaybe (Duration 5) (startDelayOption o))
, if foregroundDaemonOption (daemonOptions o)
then Just $ Param "--foreground"
else Nothing
]
autoStop :: IO ()
autoStop = do
dirs <- liftIO readAutoStartFile
program <- programPath
forM_ dirs $ \d -> do
putStrLn $ "git-annex autostop in " ++ d
setCurrentDirectory d
ifM (boolSystem program [Param "assistant", Param "--stop"])
( putStrLn "ok"
, putStrLn "failed"
)