diff options
| -rw-r--r-- | Assistant/Alert.hs | 9 | ||||
| -rw-r--r-- | Assistant/Threads/Cronner.hs | 77 | ||||
| -rw-r--r-- | Remote.hs | 1 | ||||
| -rw-r--r-- | Remote/Bup.hs | 1 | ||||
| -rw-r--r-- | Remote/Directory.hs | 1 | ||||
| -rw-r--r-- | Remote/GCrypt.hs | 1 | ||||
| -rw-r--r-- | Remote/Git.hs | 16 | ||||
| -rw-r--r-- | Remote/Glacier.hs | 1 | ||||
| -rw-r--r-- | Remote/Hook.hs | 1 | ||||
| -rw-r--r-- | Remote/Rsync.hs | 1 | ||||
| -rw-r--r-- | Remote/S3.hs | 1 | ||||
| -rw-r--r-- | Remote/Web.hs | 1 | ||||
| -rw-r--r-- | Remote/WebDAV.hs | 1 | ||||
| -rw-r--r-- | Types/Remote.hs | 5 | ||||
| -rw-r--r-- | Utility/Batch.hs | 28 |
15 files changed, 104 insertions, 41 deletions
diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index e7b731a8c..3455d0563 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -15,6 +15,7 @@ import Assistant.Alert.Utility import qualified Remote import Utility.Tense import Logs.Transfer +import Git.Remote (RemoteName) import Data.String import qualified Data.Text as T @@ -149,9 +150,11 @@ sanityCheckFixAlert msg = Alert alerthead = "The daily sanity check found and fixed a problem:" alertfoot = "If these problems persist, consider filing a bug report." -fsckAlert :: AlertButton -> Alert -fsckAlert button = baseActivityAlert - { alertData = [ UnTensed "Consistency check in progress" ] +fsckAlert :: AlertButton -> Maybe RemoteName -> Alert +fsckAlert button n = baseActivityAlert + { alertData = case n of + Nothing -> [ UnTensed $ T.pack $ "Consistency check in progress" ] + Just remotename -> [ UnTensed $ T.pack $ "Consistency check of " ++ remotename ++ " in progress"] , alertButton = Just button } diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index baec094fc..a1f716882 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -21,15 +21,17 @@ import Utility.Scheduled import Types.ScheduledActivity import Utility.ThreadScheduler import Utility.HumanTime -import qualified Build.SysConfig +import Utility.Batch import Assistant.TransferQueue import Annex.Content import Logs.Transfer import Assistant.Types.UrlRenderer import Assistant.Alert +import Remote #ifdef WITH_WEBAPP import Assistant.WebApp.Types #endif +import Git.Remote (RemoteName) import Control.Concurrent.Async import Data.Time.LocalTime @@ -134,45 +136,44 @@ secondsUntilLocalTime t = do runActivity :: UrlRenderer -> ScheduledActivity -> Assistant () runActivity urlrenderer (ScheduledSelfFsck _ d) = do program <- liftIO $ readProgramFile + void $ runFsck urlrenderer Nothing $ + batchCommand program (Param "fsck" : fsckParams d) + mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir) + where + reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download +runActivity urlrenderer (ScheduledRemoteFsck u s d) = go =<< liftAnnex (remoteFromUUID u) + where + go (Just r) = void $ case Remote.remoteFsck r of + Nothing -> void $ runFsck urlrenderer (Just $ Remote.name r) $ do + program <- readProgramFile + batchCommand program $ + [ Param "fsck" + -- avoid downloading files + , Param "--fast" + , Param "--from" + , Param $ Remote.name r + ] ++ fsckParams d + Just mkfscker -> + {- Note that having mkfsker return an IO action + - avoids running a long duration fsck in the + - Annex monad. -} + void . runFsck urlrenderer (Just $ Remote.name r) + =<< liftAnnex (mkfscker (fsckParams d)) + go Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s] + +runFsck :: UrlRenderer -> Maybe RemoteName -> IO Bool -> Assistant Bool +runFsck urlrenderer remotename a = do #ifdef WITH_WEBAPP button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR - r <- alertDuring (fsckAlert button) $ liftIO $ do - E.try (runfsck program) :: IO (Either E.SomeException ExitCode) - either (liftIO . E.throwIO) (const noop) r + r <- alertDuring (fsckAlert button remotename) $ liftIO $ do + E.try a :: IO (Either E.SomeException Bool) + either (liftIO . E.throwIO) return r #else - runfsck program + a #endif - queueBad - where - runfsck program = niceShell $ - program ++ " fsck --incremental-schedule=1d --time-limit=" ++ fromDuration d - -runActivity _ (ScheduledRemoteFsck _ _ _) = - debug ["remote fsck not implemented yet"] -queueBad :: Assistant () -queueBad = mapM_ queue =<< liftAnnex (dirKeys gitAnnexBadDir) - where - queue k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download - -{- 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 - | otherwise = command +fsckParams :: Duration -> [CommandParam] +fsckParams d = + [ Param "--incremental-schedule=1d" + , Param $ "--time-limit=" ++ fromDuration d + ] @@ -16,6 +16,7 @@ module Remote ( hasKey, hasKeyCheap, whereisKey, + remoteFsck, remoteTypes, remoteList, diff --git a/Remote/Bup.hs b/Remote/Bup.hs index 1acb35c82..d2c3038af 100644 --- a/Remote/Bup.hs +++ b/Remote/Bup.hs @@ -63,6 +63,7 @@ gen r u c gc = do , hasKey = checkPresent r bupr' , hasKeyCheap = bupLocal buprepo , whereisKey = Nothing + , remoteFsck = Nothing , config = c , repo = r , gitconfig = gc diff --git a/Remote/Directory.hs b/Remote/Directory.hs index a4bd22829..1a4dbf45c 100644 --- a/Remote/Directory.hs +++ b/Remote/Directory.hs @@ -54,6 +54,7 @@ gen r u c gc = do hasKey = checkPresent dir chunksize, hasKeyCheap = True, whereisKey = Nothing, + remoteFsck = Nothing, config = M.empty, repo = r, gitconfig = gc, diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs index 8ba640bac..89d2c431f 100644 --- a/Remote/GCrypt.hs +++ b/Remote/GCrypt.hs @@ -107,6 +107,7 @@ gen' r u c gc = do , hasKey = checkPresent this rsyncopts , hasKeyCheap = repoCheap r , whereisKey = Nothing + , remoteFsck = Nothing , config = M.empty , localpath = localpathCalc r , repo = r diff --git a/Remote/Git.hs b/Remote/Git.hs index 4cdedd064..be63de804 100644 --- a/Remote/Git.hs +++ b/Remote/Git.hs @@ -42,10 +42,12 @@ import Utility.Metered #ifndef mingw32_HOST_OS import Utility.CopyFile #endif +import Utility.Batch import Remote.Helper.Git import Remote.Helper.Messages import qualified Remote.Helper.Ssh as Ssh import qualified Remote.GCrypt +import Config.Files import Control.Concurrent import Control.Concurrent.MSampleVar @@ -111,6 +113,9 @@ gen r u c gc , hasKey = inAnnex r , hasKeyCheap = repoCheap r , whereisKey = Nothing + , remoteFsck = if Git.repoIsUrl r + then Nothing + else Just $ fsckOnRemote r , config = M.empty , localpath = localpathCalc r , repo = r @@ -396,6 +401,17 @@ copyToRemote r key file p (\d -> rsyncOrCopyFile params object d p) ) +fsckOnRemote :: Git.Repo -> [CommandParam] -> Annex (IO Bool) +fsckOnRemote r params + | Git.repoIsUrl r = return $ do + program <- readProgramFile + batchCommand program $ Param "fsck" : params + | otherwise = do + s <- Ssh.git_annex_shell r "fsck" params [] + return $ case s of + Nothing -> return False + Just (c, ps) -> batchCommand c ps + {- Runs an action on a local repository inexpensively, by making an annex - monad using that repository. -} onLocal :: Git.Repo -> Annex a -> IO a diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs index 3726c7083..5cd224d19 100644 --- a/Remote/Glacier.hs +++ b/Remote/Glacier.hs @@ -59,6 +59,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost hasKey = checkPresent this, hasKeyCheap = False, whereisKey = Nothing, + remoteFsck = Nothing, config = c, repo = r, gitconfig = gc, diff --git a/Remote/Hook.hs b/Remote/Hook.hs index 21d02c19d..88c70e0cf 100644 --- a/Remote/Hook.hs +++ b/Remote/Hook.hs @@ -52,6 +52,7 @@ gen r u c gc = do hasKey = checkPresent r hooktype, hasKeyCheap = False, whereisKey = Nothing, + remoteFsck = Nothing, config = M.empty, localpath = Nothing, repo = r, diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs index 673f7661f..b0ef318d3 100644 --- a/Remote/Rsync.hs +++ b/Remote/Rsync.hs @@ -79,6 +79,7 @@ gen r u c gc = do , hasKey = checkPresent r o , hasKeyCheap = False , whereisKey = Nothing + , remoteFsck = Nothing , config = M.empty , repo = r , gitconfig = gc diff --git a/Remote/S3.hs b/Remote/S3.hs index 67d87df50..e9c62eb25 100644 --- a/Remote/S3.hs +++ b/Remote/S3.hs @@ -62,6 +62,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost hasKey = checkPresent this, hasKeyCheap = False, whereisKey = Nothing, + remoteFsck = Nothing, config = c, repo = r, gitconfig = gc, diff --git a/Remote/Web.hs b/Remote/Web.hs index ce420b24d..23de73c27 100644 --- a/Remote/Web.hs +++ b/Remote/Web.hs @@ -56,6 +56,7 @@ gen r _ _ gc = hasKey = checkKey, hasKeyCheap = False, whereisKey = Just getUrls, + remoteFsck = Nothing, config = M.empty, gitconfig = gc, localpath = Nothing, diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs index ef4a5ed58..c65118efb 100644 --- a/Remote/WebDAV.hs +++ b/Remote/WebDAV.hs @@ -65,6 +65,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost hasKey = checkPresent this, hasKeyCheap = False, whereisKey = Nothing, + remoteFsck = Nothing, config = c, repo = r, gitconfig = gc, diff --git a/Types/Remote.hs b/Types/Remote.hs index 918566e8d..fedfb366a 100644 --- a/Types/Remote.hs +++ b/Types/Remote.hs @@ -19,6 +19,7 @@ import Types.GitConfig import Config.Cost import Utility.Metered import Git.Remote +import Utility.SafeCommand type RemoteConfigKey = String type RemoteConfig = M.Map RemoteConfigKey String @@ -64,6 +65,10 @@ data RemoteA a = Remote { hasKeyCheap :: Bool, -- Some remotes can provide additional details for whereis. whereisKey :: Maybe (Key -> a [String]), + -- Some remotes can run a fsck operation on the remote, + -- without transferring all the data to the local repo + -- The parameters are passed to the fsck command on the remote. + remoteFsck :: Maybe ([CommandParam] -> a (IO Bool)), -- a Remote has a persistent configuration store config :: RemoteConfig, -- git repo for the Remote diff --git a/Utility/Batch.hs b/Utility/Batch.hs index c3c34bf27..561a406b2 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -9,10 +9,14 @@ module Utility.Batch where +import Common +import qualified Build.SysConfig + #if defined(linux_HOST_OS) || defined(__ANDROID__) import Control.Concurrent.Async import System.Posix.Process #endif +import qualified Control.Exception as E {- Runs an operation, at batch priority. - @@ -38,3 +42,27 @@ batch a = a maxNice :: Int maxNice = 19 + +{- Runs a command in a way that's suitable for batch jobs. + - 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 = do + (_, _, _, pid) <- createProcess $ proc "sh" + [ "-c" + , "exec " ++ nicedcommand + ] + 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 + commandline = unwords $ map shellEscape $ command : toCommand params + nicedcommand + | Build.SysConfig.nice = "nice " ++ commandline + | otherwise = commandline |