From dc60216eb8fe919acf7ab3984a5f0bf0e0193f6b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Jan 2013 17:09:33 +1100 Subject: webapp: Now allows restarting any threads that crash. --- Assistant/Threads/Committer.hs | 2 +- Assistant/Threads/ConfigMonitor.hs | 2 +- Assistant/Threads/DaemonStatus.hs | 2 +- Assistant/Threads/Glacier.hs | 2 +- Assistant/Threads/Merger.hs | 5 +---- Assistant/Threads/MountWatcher.hs | 5 +---- Assistant/Threads/NetWatcher.hs | 4 ++-- Assistant/Threads/PairListener.hs | 5 +---- Assistant/Threads/Pusher.hs | 7 ++----- Assistant/Threads/SanityChecker.hs | 2 +- Assistant/Threads/TransferPoller.hs | 2 +- Assistant/Threads/TransferScanner.hs | 2 +- Assistant/Threads/TransferWatcher.hs | 2 +- Assistant/Threads/Transferrer.hs | 2 +- Assistant/Threads/Watcher.hs | 2 +- Assistant/Threads/WebApp.hs | 5 +---- Assistant/Threads/XMPPClient.hs | 2 +- 17 files changed, 19 insertions(+), 34 deletions(-) (limited to 'Assistant/Threads') diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 46ad83663..c11c6667e 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -41,7 +41,7 @@ import Data.Either {- This thread makes git commits at appropriate times. -} commitThread :: NamedThread -commitThread = NamedThread "Committer" $ do +commitThread = namedThread "Committer" $ do delayadd <- liftAnnex $ maybe delayaddDefault (return . Just . Seconds) =<< annexDelayAdd <$> Annex.getGitConfig diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index afa94f97f..6a01ff35e 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -32,7 +32,7 @@ import qualified Data.Set as S - be detected immediately. -} configMonitorThread :: NamedThread -configMonitorThread = NamedThread "ConfigMonitor" $ loop =<< getConfigs +configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs where loop old = do waitBranchChange diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs index 07f0986a6..fffc6ed37 100644 --- a/Assistant/Threads/DaemonStatus.hs +++ b/Assistant/Threads/DaemonStatus.hs @@ -16,7 +16,7 @@ import Utility.NotificationBroadcaster - frequently than once every ten minutes. -} daemonStatusThread :: NamedThread -daemonStatusThread = NamedThread "DaemonStatus" $ do +daemonStatusThread = namedThread "DaemonStatus" $ do notifier <- liftIO . newNotificationHandle =<< changeNotifier <$> getDaemonStatus checkpoint diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs index 3ccb57cbe..2f3b03b16 100644 --- a/Assistant/Threads/Glacier.hs +++ b/Assistant/Threads/Glacier.hs @@ -24,7 +24,7 @@ import qualified Data.Set as S - downloads. If so, runs glacier-cli to check if the files are now - available, and queues the downloads. -} glacierThread :: NamedThread -glacierThread = NamedThread "Glacier" $ runEvery (Seconds 3600) <~> go +glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go where isglacier r = Remote.remotetype r == Glacier.remote go = do diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index c581f8087..d8eea8c84 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -17,13 +17,10 @@ import qualified Git import qualified Git.Branch import qualified Command.Sync -thisThread :: ThreadName -thisThread = "Merger" - {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} mergeThread :: NamedThread -mergeThread = NamedThread "Merger" $ do +mergeThread = namedThread "Merger" $ do g <- liftAnnex gitRepo let dir = Git.localGitDir g "refs" liftIO $ createDirectoryIfMissing True dir diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 594035c52..143ae9cee 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -33,11 +33,8 @@ import qualified Control.Exception as E #warning Building without dbus support; will use mtab polling #endif -thisThread :: ThreadName -thisThread = "MountWatcher" - mountWatcherThread :: NamedThread -mountWatcherThread = NamedThread "MountWatcher" $ +mountWatcherThread = namedThread "MountWatcher" $ #if WITH_DBUS dbusThread #else diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index c5a48ad25..6ac7203b0 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -33,7 +33,7 @@ netWatcherThread = thread dbusThread netWatcherThread = thread noop #endif where - thread = NamedThread "NetWatcher" + thread = namedThread "NetWatcher" {- This is a fallback for when dbus cannot be used to detect - network connection changes, but it also ensures that @@ -41,7 +41,7 @@ netWatcherThread = thread noop - while (despite the local network staying up), are synced with - periodically. -} netWatcherFallbackThread :: NamedThread -netWatcherFallbackThread = NamedThread "NetWatcherFallback" $ +netWatcherFallbackThread = namedThread "NetWatcherFallback" $ runEvery (Seconds 3600) <~> handleConnection #if WITH_DBUS diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 1f9de09ac..b7e3ce66d 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -23,11 +23,8 @@ import Network.Socket import qualified Data.Text as T import Data.Char -thisThread :: ThreadName -thisThread = "PairListener" - pairListenerThread :: UrlRenderer -> NamedThread -pairListenerThread urlrenderer = NamedThread "PairListener" $ do +pairListenerThread urlrenderer = namedThread "PairListener" $ do listener <- asIO1 $ go [] [] liftIO $ withSocketsDo $ runEvery (Seconds 1) $ void $ tryIO $ diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 035a454a1..a444a8530 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -19,12 +19,9 @@ import qualified Types.Remote as Remote import Data.Time.Clock -thisThread :: ThreadName -thisThread = "Pusher" - {- This thread retries pushes that failed before. -} pushRetryThread :: NamedThread -pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do +pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do -- We already waited half an hour, now wait until there are failed -- pushes to retry. topush <- getFailedPushesBefore (fromIntegral halfhour) @@ -38,7 +35,7 @@ pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do {- This thread pushes git commits out to remotes soon after they are made. -} pushThread :: NamedThread -pushThread = NamedThread "Pusher" $ runEvery (Seconds 2) <~> do +pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do -- We already waited two seconds as a simple rate limiter. -- Next, wait until at least one commit has been made commits <- getCommits diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 1871b680e..24f4f6b29 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -20,7 +20,7 @@ import Data.Time.Clock.POSIX {- This thread wakes up occasionally to make sure the tree is in good shape. -} sanityCheckerThread :: NamedThread -sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do +sanityCheckerThread = namedThread "SanityChecker" $ forever $ do waitForNextCheck debug ["starting sanity check"] diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs index 9118e9be3..20b832652 100644 --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -19,7 +19,7 @@ import qualified Data.Map as M {- This thread polls the status of ongoing transfers, determining how much - of each transfer is complete. -} transferPollerThread :: NamedThread -transferPollerThread = NamedThread "TransferPoller" $ do +transferPollerThread = namedThread "TransferPoller" $ do g <- liftAnnex gitRepo tn <- liftIO . newNotificationHandle =<< transferNotifier <$> getDaemonStatus diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 9b863d306..929fb53e7 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -31,7 +31,7 @@ import qualified Data.Set as S - that need to be made, to keep data in sync. -} transferScannerThread :: NamedThread -transferScannerThread = NamedThread "TransferScanner" $ do +transferScannerThread = namedThread "TransferScanner" $ do startupScan go S.empty where diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index d2f7ebe14..d2ca0e535 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -22,7 +22,7 @@ import Control.Concurrent {- This thread watches for changes to the gitAnnexTransferDir, - and updates the DaemonStatus's map of ongoing transfers. -} transferWatcherThread :: NamedThread -transferWatcherThread = NamedThread "TransferWatcher" $ do +transferWatcherThread = namedThread "TransferWatcher" $ do dir <- liftAnnex $ gitAnnexTransferDir <$> gitRepo liftIO $ createDirectoryIfMissing True dir let hook a = Just <$> asIO2 (runHandler a) diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 399e732be..0acadec4b 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -25,7 +25,7 @@ import System.Process (create_group) {- Dispatches transfers from the queue. -} transfererThread :: NamedThread -transfererThread = NamedThread "Transferr" $ do +transfererThread = namedThread "Transferrer" $ do program <- liftIO readProgramFile forever $ inTransferSlot $ maybe (return Nothing) (uncurry $ startTransfer program) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index f2702ec35..2c61b50f5 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -59,7 +59,7 @@ needLsof = error $ unlines ] watchThread :: NamedThread -watchThread = NamedThread "Watcher" $ do +watchThread = namedThread "Watcher" $ do startup <- asIO1 startupScan direct <- liftAnnex isDirect addhook <- hook $ if direct then onAddDirect else onAdd diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index c4c9fa87a..e2eed4588 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -38,9 +38,6 @@ import Yesod.Static import Network.Socket (SockAddr) import Data.Text (pack, unpack) -thisThread :: String -thisThread = "WebApp" - mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") type Url = String @@ -76,7 +73,7 @@ webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile go addr webapp htmlshim (Just urlfile) where - thread = NamedThread thisThread + thread = namedThread "WebApp" getreldir | noannex = return Nothing | otherwise = Just <$> diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 99b46dabb..ebface796 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -34,7 +34,7 @@ import qualified Git.Branch import Data.Time.Clock xmppClientThread :: UrlRenderer -> NamedThread -xmppClientThread urlrenderer = NamedThread "XMPPClient" $ +xmppClientThread urlrenderer = namedThread "XMPPClient" $ restartableClient . xmppClient urlrenderer =<< getAssistant id {- Runs the client, handing restart events. -} -- cgit v1.2.3