diff options
| -rw-r--r-- | Assistant.hs | 2 | ||||
| -rw-r--r-- | Assistant/Alert.hs | 12 | ||||
| -rw-r--r-- | Assistant/Monad.hs | 3 | ||||
| -rw-r--r-- | Assistant/RemoteProblem.hs | 23 | ||||
| -rw-r--r-- | Assistant/Sync.hs | 10 | ||||
| -rw-r--r-- | Assistant/Threads/Cronner.hs | 23 | ||||
| -rw-r--r-- | Assistant/Threads/Pusher.hs | 5 | ||||
| -rw-r--r-- | Assistant/Threads/RemoteChecker.hs | 46 | ||||
| -rw-r--r-- | Assistant/Types/RemoteProblem.hs | 18 | ||||
| -rw-r--r-- | Remote.hs | 7 |
10 files changed, 121 insertions, 28 deletions
diff --git a/Assistant.hs b/Assistant.hs index 5eeba818e..8ae779714 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -23,6 +23,7 @@ import Assistant.Threads.TransferWatcher import Assistant.Threads.Transferrer import Assistant.Threads.SanityChecker import Assistant.Threads.Cronner +import Assistant.Threads.RemoteChecker #ifdef WITH_CLIBS import Assistant.Threads.MountWatcher #endif @@ -129,6 +130,7 @@ startDaemon assistant foreground startdelay listenhost startbrowser = do , assist $ daemonStatusThread , assist $ sanityCheckerDailyThread , assist $ sanityCheckerHourlyThread + , assist $ remoteCheckerThread urlrenderer #ifdef WITH_CLIBS , assist $ mountWatcherThread #endif diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs index 9e248571d..108bbdf26 100644 --- a/Assistant/Alert.hs +++ b/Assistant/Alert.hs @@ -19,6 +19,7 @@ import Git.Remote (RemoteName) import Data.String import qualified Data.Text as T +import qualified Control.Exception as E #ifdef WITH_WEBAPP import Assistant.Monad @@ -174,6 +175,17 @@ fsckAlert button n = baseActivityAlert , alertButton = Just button } +showFscking :: UrlRenderer -> Maybe RemoteName -> IO (Either E.SomeException a) -> Assistant a +showFscking urlrenderer remotename a = do +#ifdef WITH_WEBAPP + button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR + r <- alertDuring (fsckAlert button remotename) $ + liftIO a + either (liftIO . E.throwIO) return r +#else + a +#endif + brokenRepositoryAlert :: AlertButton -> Alert brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!" diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 4b73061f9..154813785 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -39,6 +39,7 @@ import Assistant.Types.Pushes import Assistant.Types.BranchChange import Assistant.Types.Commits import Assistant.Types.Changes +import Assistant.Types.RemoteProblem import Assistant.Types.Buddies import Assistant.Types.NetMessager import Assistant.Types.ThreadName @@ -63,6 +64,7 @@ data AssistantData = AssistantData , failedPushMap :: FailedPushMap , commitChan :: CommitChan , changePool :: ChangePool + , remoteProblemChan :: RemoteProblemChan , branchChangeHandle :: BranchChangeHandle , buddyList :: BuddyList , netMessager :: NetMessager @@ -80,6 +82,7 @@ newAssistantData st dstatus = AssistantData <*> newFailedPushMap <*> newCommitChan <*> newChangePool + <*> newRemoteProblemChan <*> newBranchChangeHandle <*> newBuddyList <*> newNetMessager diff --git a/Assistant/RemoteProblem.hs b/Assistant/RemoteProblem.hs new file mode 100644 index 000000000..c064a9475 --- /dev/null +++ b/Assistant/RemoteProblem.hs @@ -0,0 +1,23 @@ +{- git-annex assistant remote problem handling + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.RemoteProblem where + +import Assistant.Common +import Utility.TList + +import Control.Concurrent.STM + +{- Gets all remotes that have problems. + - Blocks until there is at least one. -} +getRemoteProblems :: Assistant [Remote] +getRemoteProblems = (atomically . getTList) <<~ remoteProblemChan + +{- Indicates that there was a problem accessing a remote, and the problem + - appears to not be a transient (eg network connection) problem. -} +remoteHasProblem :: Remote -> Assistant () +remoteHasProblem r = (atomically . flip consTList r) <<~ remoteProblemChan diff --git a/Assistant/Sync.hs b/Assistant/Sync.hs index 6a66802d5..5715901d6 100644 --- a/Assistant/Sync.hs +++ b/Assistant/Sync.hs @@ -33,6 +33,7 @@ import Assistant.NamedThread import Assistant.Threads.Watcher (watchThread, WatcherControl(..)) import Assistant.TransferSlots import Assistant.TransferQueue +import Assistant.RemoteProblem import Logs.Transfer import Data.Time.Clock @@ -59,11 +60,14 @@ import Control.Concurrent reconnectRemotes :: Bool -> [Remote] -> Assistant () reconnectRemotes _ [] = noop reconnectRemotes notifypushes rs = void $ do - rs' <- filterM (checkavailable . Remote.repo) rs + rs' <- liftIO $ filterM (Remote.checkAvailable True) rs unless (null rs') $ do modifyDaemonStatus_ $ \s -> s { desynced = S.union (S.fromList $ map Remote.uuid xmppremotes) (desynced s) } failedrs <- syncAction rs' (const go) + forM_ failedrs $ \r -> + whenM (liftIO $ Remote.checkAvailable False r) $ + remoteHasProblem r mapM_ signal $ filter (`notElem` failedrs) rs' where gitremotes = filter (notspecialremote . Remote.repo) rs @@ -90,10 +94,6 @@ reconnectRemotes notifypushes rs = void $ do signal r = liftIO . mapM_ (flip tryPutMVar ()) =<< fromMaybe [] . M.lookup (Remote.uuid r) . connectRemoteNotifiers <$> getDaemonStatus - checkavailable r - | Git.repoIsLocal r || Git.repoIsLocalUnknown r = - liftIO $ doesDirectoryExist $ Git.repoPath r - | otherwise = return True {- Updates the local sync branch, then pushes it to all remotes, in - parallel, along with the git-annex branch. This is the same diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs index 6399de514..df5264d7f 100644 --- a/Assistant/Threads/Cronner.hs +++ b/Assistant/Threads/Cronner.hs @@ -5,7 +5,7 @@ - Licensed under the GNU GPL version 3 or higher. -} -{-# LANGUAGE DeriveDataTypeable, CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} module Assistant.Threads.Cronner ( cronnerThread @@ -29,10 +29,6 @@ import Assistant.Types.UrlRenderer import Assistant.Alert import Remote import qualified Types.Remote as Remote -#ifdef WITH_WEBAPP -import Assistant.WebApp.Types -#endif -import Git.Remote (RemoteName) import qualified Git.Fsck import Assistant.Repair import qualified Git @@ -43,8 +39,6 @@ import Data.Time.LocalTime import Data.Time.Clock import qualified Data.Map as M import qualified Data.Set as S -import qualified Control.Exception as E -import qualified Data.Text as T {- Loads schedules for this repository, and fires off one thread for each - scheduled event that runs on this repository. Each thread sleeps until @@ -191,7 +185,7 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do void $ batchCommand program (Param "fsck" : annexFsckParams d) Git.Fsck.findBroken True g u <- liftAnnex getUUID - repairWhenNecessary urlrenderer u Nothing fsckresults + void $ repairWhenNecessary urlrenderer u Nothing fsckresults mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir) where reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download @@ -220,18 +214,7 @@ runActivity' urlrenderer (ScheduledRemoteFsck u s d) = handle =<< liftAnnex (rem if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) then Just <$> Git.Fsck.findBroken True r else pure Nothing - maybe noop (repairWhenNecessary urlrenderer u (Just rmt)) fsckresults - -showFscking :: UrlRenderer -> Maybe RemoteName -> IO (Either E.SomeException a) -> Assistant a -showFscking urlrenderer remotename a = do -#ifdef WITH_WEBAPP - button <- mkAlertButton False (T.pack "Configure") urlrenderer ConfigFsckR - r <- alertDuring (fsckAlert button remotename) $ - liftIO a - either (liftIO . E.throwIO) return r -#else - a -#endif + maybe noop (void . repairWhenNecessary urlrenderer u (Just rmt)) fsckresults annexFsckParams :: Duration -> [CommandParam] annexFsckParams d = diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 060f26cf5..3ec922fe4 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -13,6 +13,7 @@ import Assistant.Pushes import Assistant.DaemonStatus import Assistant.Sync import Utility.ThreadScheduler +import qualified Remote import qualified Types.Remote as Remote {- This thread retries pushes that failed before. -} @@ -42,7 +43,7 @@ pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do - to avoid ugly messages when a removable drive is not attached. -} pushTargets :: Assistant [Remote] -pushTargets = liftIO . filterM available =<< candidates <$> getDaemonStatus +pushTargets = liftIO . filterM (Remote.checkAvailable True) + =<< candidates <$> getDaemonStatus where candidates = filter (not . Remote.readonly) . syncGitRemotes - available = maybe (return True) doesDirectoryExist . Remote.localpath diff --git a/Assistant/Threads/RemoteChecker.hs b/Assistant/Threads/RemoteChecker.hs new file mode 100644 index 000000000..ea0b578d2 --- /dev/null +++ b/Assistant/Threads/RemoteChecker.hs @@ -0,0 +1,46 @@ +{- git-annex assistant remote checker thread + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Threads.RemoteChecker ( + remoteCheckerThread +) where + +import Assistant.Common +import Utility.ThreadScheduler +import Assistant.Types.UrlRenderer +import Assistant.Alert +import Remote +import qualified Types.Remote as Remote +import qualified Git.Fsck +import Assistant.Repair +import qualified Git +import Assistant.RemoteProblem +import Assistant.Sync + +import Data.Function + +{- Waits for problems with remotes, and tries to fsck the remote and repair + - the problem. -} +remoteCheckerThread :: UrlRenderer -> NamedThread +remoteCheckerThread urlrenderer = namedThread "RemoteChecker" $ forever $ do + mapM_ (handleProblem urlrenderer) + =<< liftIO . filterM (checkAvailable True) + =<< nubremotes <$> getRemoteProblems + liftIO $ threadDelaySeconds (Seconds 60) + where + nubremotes = nubBy ((==) `on` Remote.uuid) + +handleProblem :: UrlRenderer -> Remote -> Assistant () +handleProblem urlrenderer rmt + | Git.repoIsLocal r && not (Git.repoIsLocalUnknown r) = do + fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $ + Git.Fsck.findBroken True r + whenM (repairWhenNecessary urlrenderer (Remote.uuid rmt) (Just rmt) fsckresults) $ + syncRemote rmt + | otherwise = noop + where + r = Remote.repo rmt diff --git a/Assistant/Types/RemoteProblem.hs b/Assistant/Types/RemoteProblem.hs new file mode 100644 index 000000000..539da3db9 --- /dev/null +++ b/Assistant/Types/RemoteProblem.hs @@ -0,0 +1,18 @@ +{- git-annex assistant remote problem detection + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.RemoteProblem where + +import Types +import Utility.TList + +import Control.Concurrent.STM + +type RemoteProblemChan = TList Remote + +newRemoteProblemChan :: IO RemoteProblemChan +newRemoteProblemChan = atomically newTList @@ -39,7 +39,8 @@ module Remote ( showTriedRemotes, showLocations, forceTrust, - logStatus + logStatus, + checkAvailable ) where import qualified Data.Map as M @@ -274,3 +275,7 @@ byCost = map snd . sortBy (comparing fst) . M.toList . costmap where costmap = M.fromListWith (++) . map costpair costpair r = (cost r, [r]) + +checkAvailable :: Bool -> Remote -> IO Bool +checkAvailable assumenetworkavailable = + maybe (return assumenetworkavailable) doesDirectoryExist . localpath |