webapp: Now allows restarting any threads that crash.

17 files changed, 19 insertions, 34 deletions

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. -}