diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index a5fb2de7dc..78b6a480c7 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -29,12 +29,6 @@ import Data.Time.Clock import qualified Data.Map as M import qualified Data.Set as S import qualified Control.Exception as E -import Data.Typeable - -data ActivityException = PleaseTerminate - deriving (Typeable, Show) - -instance E.Exception ActivityException {- Loads schedules for this repository, and fires off one thread for each - scheduled event. These threads sleep until the next time the event @@ -43,8 +37,7 @@ instance E.Exception ActivityException - In the meantime the main thread waits for any changes to the - schedules. When there's a change, compare the old and new list of - schedules to find deleted and added ones. Start new threads for added - - ones, and send the threads a PleaseTerminate exception for the deleted - - ones. -} + - ones, and kill the threads for deleted ones. -} cronnerThread :: NamedThread cronnerThread = namedThreadUnchecked "Cronner" $ do dstatus <- getDaemonStatus @@ -57,13 +50,18 @@ cronnerThread = namedThreadUnchecked "Cronner" $ do let addedactivities = activities `S.difference` M.keysSet m let removedactivities = M.keysSet m `S.difference` activities - liftIO $ forM_ (mapMaybe (`M.lookup` m) $ S.toList removedactivities) $ - flip cancelWith PleaseTerminate + forM_ (S.toList removedactivities) $ \activity -> + case M.lookup activity m of + Just a -> do + debug ["stopping removed job for", fromScheduledActivity activity, show (asyncThreadId a)] + liftIO $ cancel a + Nothing -> noop lastruntimes <- liftAnnex getLastRunTimes addedm <- M.fromList <$> startactivities (S.toList addedactivities) lastruntimes liftIO $ waitNotification h + debug ["reloading changed activities"] let m' = M.difference (M.union addedm m) (M.filterWithKey (\k _ -> S.member k removedactivities) m) @@ -77,9 +75,6 @@ cronnerThread = namedThreadUnchecked "Cronner" $ do {- Calculate the next time the activity is scheduled to run, then - sleep until that time, and run it. Then call setLastRunTime, and - loop. - - - - At any point, a PleaseTerminate could be received. This should result in - - the thread and any processes it has run shutting down. -} activityThread :: ScheduledActivity -> Maybe LocalTime -> Assistant () activityThread activity lasttime = go lasttime =<< getnexttime lasttime @@ -128,18 +123,30 @@ secondsUntilLocalTime t = do else Seconds 0 runActivity :: ScheduledActivity -> Assistant () -runActivity (ScheduledSelfFsck _ d) = do - program <- liftIO $ readProgramFile - void $ liftIO $ niceShell $ +runActivity (ScheduledSelfFsck _ d) = liftIO $ do + program <- readProgramFile + void $ niceShell $ program ++ " fsck --incremental-schedule=1d --time-limit=" ++ fromDuration d runActivity (ScheduledRemoteFsck _ _ _) = debug ["remote fsck not implemented yet"] -niceShell :: String -> IO Bool -niceShell command = boolSystem "sh" - [ Param "-c" - , Param nicedcommand - ] +{- Runs a shell command niced, until it terminates. + - + - When an async exception is received, the command is sent a SIGTERM, + - and after it finishes shutting down the exception is re-raised. -} +niceShell :: String -> IO ExitCode +niceShell command = do + (_, _, _, pid) <- createProcess $ proc "sh" + [ "-c" + , "exec " ++ nicedcommand + ] + r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode) + case r of + Right exitcode -> return exitcode + Left asyncexception -> do + terminateProcess pid + void $ waitForProcess pid + E.throwIO asyncexception where nicedcommand | Build.SysConfig.nice = "nice " ++ command