webapp: Now allows restarting any threads that crash.

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

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

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

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

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

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

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

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 $ 

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

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"]

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

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

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)

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)

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

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 <$>

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