diff options
| -rw-r--r-- | Assistant.hs | 2 | ||||
| -rw-r--r-- | Assistant/Alert.hs | 44 | ||||
| -rw-r--r-- | Assistant/Threads/Cronner.hs | 6 | ||||
| -rw-r--r-- | Assistant/Threads/MountWatcher.hs | 37 | ||||
| -rw-r--r-- | Assistant/Threads/ProblemFixer.hs | 4 | ||||
| -rw-r--r-- | Assistant/Threads/SanityChecker.hs | 2 | ||||
| -rw-r--r-- | Assistant/Types/Alert.hs | 1 | ||||
| -rw-r--r-- | Types/GitConfig.hs | 2 | ||||
| -rw-r--r-- | doc/design/assistant/disaster_recovery.mdwn | 9 | ||||
| -rw-r--r-- | doc/git-annex.mdwn | 5 |
10 files changed, 78 insertions, 34 deletions
diff --git a/Assistant.hs b/Assistant.hs index c7ca98ee9..781089e06 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -132,7 +132,7 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do , assist $ sanityCheckerHourlyThread , assist $ problemFixerThread urlrenderer #ifdef WITH_CLIBS - , assist $ mountWatcherThread + , assist $ mountWatcherThread urlrenderer #endif , assist $ netWatcherThread , assist $ netWatcherFallbackThread diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index ff378a7b0..b10a724ed 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -15,7 +15,6 @@ 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 @@ -168,25 +167,54 @@ 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 -> Maybe RemoteName -> Alert -fsckAlert button n = baseActivityAlert - { alertData = case n of +fsckingAlert :: AlertButton -> Maybe Remote -> Alert +fsckingAlert button mr = baseActivityAlert + { alertData = case mr of Nothing -> [ UnTensed $ T.pack $ "Consistency check in progress" ] - Just remotename -> [ UnTensed $ T.pack $ "Consistency check of " ++ remotename ++ " in progress"] + Just r -> [ UnTensed $ T.pack $ "Consistency check of " ++ Remote.name r ++ " in progress"] , alertButton = Just button } -showFscking :: UrlRenderer -> Maybe RemoteName -> IO (Either E.SomeException a) -> Assistant a -showFscking urlrenderer remotename a = do +showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a +showFscking urlrenderer mr a = do #ifdef WITH_WEBAPP button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR - r <- alertDuring (fsckAlert button remotename) $ + r <- alertDuring (fsckingAlert button mr) $ liftIO a #else r <- liftIO a #endif either (liftIO . E.throwIO) return r +notFsckedNudge :: UrlRenderer -> Maybe Remote -> Assistant () +#ifdef WITH_WEBAPP +notFsckedNudge urlrenderer mr = do + button <- mkAlertButton True (T.pack "Configure") urlrenderer ConfigFsckR + void $ addAlert (notFsckedAlert mr button) +#else +notFsckedNudge _ = noop +#endif + +notFsckedAlert :: Maybe Remote -> AlertButton -> Alert +notFsckedAlert mr button = Alert + { alertHeader = Just $ fromString $ concat + [ "You should enable consistency checking to protect your data" + , maybe "" (\r -> " in " ++ Remote.name r) mr + , "." + ] + , alertIcon = Just InfoIcon + , alertPriority = High + , alertButton = Just button + , alertClosable = True + , alertClass = Message + , alertMessageRender = renderData + , alertCounter = 0 + , alertBlockDisplay = True + , alertName = Just NotFsckedAlert + , alertCombiner = Just $ dataCombiner $ \_old new -> new + , alertData = [] + } + brokenRepositoryAlert :: AlertButton -> Alert brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!" diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index df5264d7f..55b3ca2f1 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -29,9 +29,10 @@ import Assistant.Types.UrlRenderer import Assistant.Alert import Remote import qualified Types.Remote as Remote +import qualified Git import qualified Git.Fsck +import Assistant.Fsck import Assistant.Repair -import qualified Git import Control.Concurrent.Async import Control.Concurrent.MVar @@ -55,6 +56,7 @@ import qualified Data.Set as S - ones, and kill the threads for deleted ones. -} cronnerThread :: UrlRenderer -> NamedThread cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do + fsckNudge urlrenderer Nothing dstatus <- getDaemonStatus h <- liftIO $ newNotificationHandle False (scheduleLogNotifier dstatus) go h M.empty M.empty @@ -208,7 +210,7 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = handle =<< liftAnnex (rem - Annex monad. -} go rmt =<< liftAnnex (mkfscker (annexFsckParams d)) go rmt annexfscker = do - fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $ do + fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ do void annexfscker let r = Remote.repo rmt if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index c18bfb5bd..39ae67537 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -19,6 +19,8 @@ import Utility.ThreadScheduler import Utility.Mounts import Remote.List import qualified Types.Remote as Remote +import Assistant.Types.UrlRenderer +import Assistant.Fsck import qualified Data.Set as S @@ -33,18 +35,18 @@ import qualified Control.Exception as E #warning Building without dbus support; will use mtab polling #endif -mountWatcherThread :: NamedThread -mountWatcherThread = namedThread "MountWatcher" +mountWatcherThread :: UrlRenderer -> NamedThread +mountWatcherThread urlrenderer = namedThread "MountWatcher" $ #if WITH_DBUS - dbusThread + dbusThread urlrenderer #else - pollingThread + pollingThread urlrenderer #endif #if WITH_DBUS -dbusThread :: Assistant () -dbusThread = do +dbusThread :: UrlRenderer -> Assistant () +dbusThread urlrenderer = do runclient <- asIO1 go r <- liftIO $ E.try $ runClient getSessionAddress runclient either onerr (const noop) r @@ -59,13 +61,13 @@ dbusThread = do handleevent <- asIO1 $ \_event -> do nowmounted <- liftIO $ currentMountPoints wasmounted <- liftIO $ swapMVar mvar nowmounted - handleMounts wasmounted nowmounted + handleMounts urlrenderer wasmounted nowmounted liftIO $ forM_ mountChanged $ \matcher -> listen client matcher handleevent , do liftAnnex $ warning "No known volume monitor available through dbus; falling back to mtab polling" - pollingThread + pollingThread urlrenderer ) onerr :: E.SomeException -> Assistant () onerr e = do @@ -76,7 +78,7 @@ dbusThread = do - done in this situation. -} liftAnnex $ warning $ "dbus failed; falling back to mtab polling (" ++ show e ++ ")" - pollingThread + pollingThread urlrenderer {- Examine the list of services connected to dbus, to see if there - are any we can use to monitor mounts. If not, will attempt to start one. -} @@ -139,24 +141,25 @@ mountChanged = [gvfs True, gvfs False, kde, kdefallback] #endif -pollingThread :: Assistant () -pollingThread = go =<< liftIO currentMountPoints +pollingThread :: UrlRenderer -> Assistant () +pollingThread urlrenderer = go =<< liftIO currentMountPoints where go wasmounted = do liftIO $ threadDelaySeconds (Seconds 10) nowmounted <- liftIO currentMountPoints - handleMounts wasmounted nowmounted + handleMounts urlrenderer wasmounted nowmounted go nowmounted -handleMounts :: MountPoints -> MountPoints -> Assistant () -handleMounts wasmounted nowmounted = - mapM_ (handleMount . mnt_dir) $ +handleMounts :: UrlRenderer -> MountPoints -> MountPoints -> Assistant () +handleMounts urlrenderer wasmounted nowmounted = + mapM_ (handleMount urlrenderer . mnt_dir) $ S.toList $ newMountPoints wasmounted nowmounted -handleMount :: FilePath -> Assistant () -handleMount dir = do +handleMount :: UrlRenderer -> FilePath -> Assistant () +handleMount urlrenderer dir = do debug ["detected mount of", dir] rs <- filter (Git.repoIsLocal . Remote.repo) <$> remotesUnder dir + mapM_ (fsckNudge urlrenderer . Just) rs reconnectRemotes True rs {- Finds remotes located underneath the mount point. diff --git a/Assistant/Threads/ProblemFixer.hs b/Assistant/Threads/ProblemFixer.hs index f9774e0f0..8095581a6 100644 --- a/Assistant/Threads/ProblemFixer.hs +++ b/Assistant/Threads/ProblemFixer.hs @@ -54,7 +54,7 @@ handleRemoteProblem urlrenderer rmt ifM (liftIO $ checkAvailable True rmt) ( do fixedlocks <- repairStaleGitLocks r - fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $ + fsckresults <- showFscking urlrenderer (Just rmt) $ tryNonAsync $ Git.Fsck.findBroken True r repaired <- repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults return $ fixedlocks || repaired @@ -66,5 +66,5 @@ handleRemoteProblem urlrenderer rmt {- This is not yet used, and should probably do a fsck. -} handleLocalRepoProblem :: UrlRenderer -> Assistant Bool -handleLocalRepoProblem urlrenderer = do +handleLocalRepoProblem _urlrenderer = do repairStaleGitLocks =<< liftAnnex gitRepo diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 4f5eeda50..b03298510 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -33,8 +33,10 @@ import Data.Time.Clock.POSIX - being nonresponsive.) -} sanityCheckerStartupThread :: Maybe Duration -> NamedThread sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerStartup" $ do + {- Stale git locks can prevent commits from happening, etc. -} void $ repairStaleGitLocks =<< liftAnnex gitRepo + {- If there's a startup delay, it's done here. -} liftIO $ maybe noop (threadDelaySeconds . Seconds . fromIntegral . durationSeconds) startupdelay {- Notify other threads that the startup sanity check is done. -} diff --git a/Assistant/Types/Alert.hs b/Assistant/Types/Alert.hs index 290733b66..2e52ca7ef 100644 --- a/Assistant/Types/Alert.hs +++ b/Assistant/Types/Alert.hs @@ -30,6 +30,7 @@ data AlertName | RemoteRemovalAlert String | CloudRepoNeededAlert | SyncAlert + | NotFsckedAlert deriving (Eq) {- The first alert is the new alert, the second is an old alert. diff --git a/Types/GitConfig.hs b/Types/GitConfig.hs index 5db38e68f..b573a9a25 100644 --- a/Types/GitConfig.hs +++ b/Types/GitConfig.hs @@ -41,6 +41,7 @@ data GitConfig = GitConfig , annexWebDownloadCommand :: Maybe String , annexCrippledFileSystem :: Bool , annexLargeFiles :: Maybe String + , annexFsckNudge :: Bool , coreSymlinks :: Bool , gcryptId :: Maybe String } @@ -68,6 +69,7 @@ extractGitConfig r = GitConfig , annexWebDownloadCommand = getmaybe (annex "web-download-command") , annexCrippledFileSystem = getbool (annex "crippledfilesystem") False , annexLargeFiles = getmaybe (annex "largefiles") + , annexFsckNudge = getbool (annex "fscknudge") True , coreSymlinks = getbool "core.symlinks" True , gcryptId = getmaybe "core.gcrypt-id" } diff --git a/doc/design/assistant/disaster_recovery.mdwn b/doc/design/assistant/disaster_recovery.mdwn index 40e48650e..6fcf95519 100644 --- a/doc/design/assistant/disaster_recovery.mdwn +++ b/doc/design/assistant/disaster_recovery.mdwn @@ -14,8 +14,9 @@ check that nothing else is using it, fix the problem, and redo the commit. * What about local remotes, eg removable drives? git-annex does attempt to commit to the git-annex branch of those. It will use the automatic fix if any are dangling. It does not commit to the master branch; indeed - a removable drive typically has a bare repository. So I think nothing to - do here. + a removable drive typically has a bare repository. + However, it does a scan for broken locks anyway if there's a problem + syncing. **done** * What about git-annex-shell? If the ssh remote has the assistant running, it can take care of it, and if not, it's a server, and perhaps the user should be required to fix up if it crashes during a commit. This should @@ -95,10 +96,10 @@ quite a lot of state. Or: Display a message whenever a removable drive is detected to have been connected. I like this, but what about nudging the main repo? Could do it -every webapp startup, perhaps? +every webapp startup, perhaps? **done** There should be a "No thanks" button that prevents it nudging again for a -repo. +repo. **done** ## git repository repair diff --git a/doc/git-annex.mdwn b/doc/git-annex.mdwn index 8ff0b7962..d88957f9c 100644 --- a/doc/git-annex.mdwn +++ b/doc/git-annex.mdwn @@ -1118,6 +1118,11 @@ Here are all the supported configuration settings. to close it. On Mac OSX, when not using direct mode this defaults to 1 second, to work around a bad interaction with software there. +* `annex.fscknudge` + + When set to false, prevents the webapp from reminding you when using + repositories that lack consistency checks. + * `annex.autocommit` Set to false to prevent the git-annex assistant from automatically |