display errors when any named thread crashes

Assistant/Threads/Committer.hs

@@ -36,8 +36,8 @@ thisThread :: ThreadName
 thisThread = "Committer"
 
 {- This thread makes git commits at appropriate times. -}
-commitThread :: ThreadState -> ChangeChan -> CommitChan -> TransferQueue -> DaemonStatusHandle -> IO ()
-commitThread st changechan commitchan transferqueue dstatus = runEvery (Seconds 1) $ do
+commitThread :: ThreadState -> ChangeChan -> CommitChan -> TransferQueue -> DaemonStatusHandle -> NamedThread
+commitThread st changechan commitchan transferqueue dstatus = thread $ runEvery (Seconds 1) $ do
 	-- We already waited one second as a simple rate limiter.
 	-- Next, wait until at least one change is available for
 	-- processing.
@@ -61,6 +61,7 @@ commitThread st changechan commitchan transferqueue dstatus = runEvery (Seconds
 				else refill readychanges
 		else refill changes
 	where
+		thread = NamedThread thisThread
 		refill [] = noop
 		refill cs = do
 			debug thisThread

Assistant/Threads/DaemonStatus.hs

@@ -0,0 +1,36 @@
+{- git-annex assistant daemon status thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Threads.DaemonStatus where
+
+import Assistant.Common
+import Assistant.DaemonStatus
+import Assistant.ThreadedMonad
+import Utility.ThreadScheduler
+import Utility.NotificationBroadcaster
+
+thisThread :: ThreadName
+thisThread = "DaemonStatus"
+
+{- This writes the daemon status to disk, when it changes, but no more
+ - frequently than once every ten minutes.
+ -}
+daemonStatusThread :: ThreadState -> DaemonStatusHandle -> NamedThread
+daemonStatusThread st dstatus = thread $ do
+	notifier <- newNotificationHandle
+		=<< changeNotifier <$> getDaemonStatus dstatus
+	checkpoint
+	runEvery (Seconds tenMinutes) $ do
+		waitNotification notifier
+		checkpoint
+	where
+		thread = NamedThread thisThread
+		checkpoint = do
+			status <- getDaemonStatus dstatus
+			file <- runThreadState st $ fromRepo gitAnnexDaemonStatusFile
+			writeDaemonStatusFile file status
+

Assistant/Threads/Merger.hs

@@ -22,8 +22,8 @@ thisThread = "Merger"
 {- This thread watches for changes to .git/refs/heads/synced/,
  - which indicate incoming pushes. It merges those pushes into the
  - currently checked out branch. -}
-mergeThread :: ThreadState -> IO ()
-mergeThread st = do
+mergeThread :: ThreadState -> NamedThread
+mergeThread st = thread $ do
 	g <- runThreadState st $ fromRepo id
 	let dir = Git.localGitDir g </> "refs" </> "heads" </> "synced"
 	createDirectoryIfMissing True dir
@@ -34,6 +34,8 @@ mergeThread st = do
 		}
 	void $ watchDir dir (const False) hooks id
 	debug thisThread ["watching", dir]
+	where
+		thread = NamedThread thisThread
 
 type Handler = Git.Repo -> FilePath -> Maybe FileStatus -> IO ()
 

Assistant/Threads/MountWatcher.hs

@@ -38,13 +38,15 @@ import Data.Word (Word32)
 thisThread :: ThreadName
 thisThread = "MountWatcher"
 
-mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
-mountWatcherThread st handle scanremotes =
+mountWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
+mountWatcherThread st handle scanremotes = thread $
 #if WITH_DBUS
 	dbusThread st handle scanremotes
 #else
 	pollingThread st handle scanremotes
 #endif
+	where
+		thread = NamedThread thisThread
 
 #if WITH_DBUS
 

Assistant/Threads/NetWatcher.hs

@@ -15,13 +15,11 @@ import Assistant.ThreadedMonad
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
 import Assistant.Sync
-import qualified Git
 import Utility.ThreadScheduler
 import Remote.List
 import qualified Types.Remote as Remote
 
 import qualified Control.Exception as E
-import Control.Concurrent
 
 #if WITH_DBUS
 import Utility.DBus
@@ -35,18 +33,27 @@ import Data.Word (Word32)
 thisThread :: ThreadName
 thisThread = "NetWatcher"
 
-netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> IO ()
-netWatcherThread st dstatus scanremotes = do
+netWatcherThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
+netWatcherThread st dstatus scanremotes = thread $ do
 #if WITH_DBUS
-	void $ forkIO $ dbusThread st dstatus scanremotes
+	dbusThread st dstatus scanremotes
+#else
+	noop
 #endif
-	{- This is a fallback for when dbus cannot be used to detect
-	 - network connection changes, but it also ensures that
-	 - any networked remotes that may have not been routable for a
-	 - while (despite the local network staying up), are synced with
-	 - periodically. -}
+	where
+		thread = NamedThread thisThread
+
+{- This is a fallback for when dbus cannot be used to detect
+ - network connection changes, but it also ensures that
+ - any networked remotes that may have not been routable for a
+ - while (despite the local network staying up), are synced with
+ - periodically. -}
+netWatcherFallbackThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> NamedThread
+netWatcherFallbackThread st dstatus scanremotes = thread $ do
 	runEvery (Seconds 3600) $
 		handleConnection st dstatus scanremotes
+	where
+		thread = NamedThread thisThread
 
 #if WITH_DBUS
 

Assistant/Threads/Pusher.hs

@@ -24,8 +24,8 @@ thisThread :: ThreadName
 thisThread = "Pusher"
 
 {- This thread retries pushes that failed before. -}
-pushRetryThread :: ThreadState -> DaemonStatusHandle -> FailedPushMap -> IO ()
-pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do
+pushRetryThread :: ThreadState -> DaemonStatusHandle -> FailedPushMap -> NamedThread
+pushRetryThread st dstatus pushmap = thread $ runEvery (Seconds halfhour) $ do
 	-- We already waited half an hour, now wait until there are failed
 	-- pushes to retry.
 	topush <- getFailedPushesBefore pushmap (fromIntegral halfhour)
@@ -40,10 +40,11 @@ pushRetryThread st dstatus pushmap = runEvery (Seconds halfhour) $ do
 			pushToRemotes thisThread now st (Just pushmap) topush
 	where
 		halfhour = 1800
+		thread = NamedThread thisThread
 
 {- This thread pushes git commits out to remotes soon after they are made. -}
-pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> IO ()
-pushThread st dstatus commitchan pushmap = do
+pushThread :: ThreadState -> DaemonStatusHandle -> CommitChan -> FailedPushMap -> NamedThread
+pushThread st dstatus commitchan pushmap = thread $ do
 	runEvery (Seconds 2) $ do
 		-- We already waited two seconds as a simple rate limiter.
 		-- Next, wait until at least one commit has been made
@@ -64,11 +65,12 @@ pushThread st dstatus commitchan pushmap = do
 					, "commits"
 					]
 				refillCommits commitchan commits
-		where
-			pushable r
-				| Remote.specialRemote r = False
-				| Remote.readonly r = False
-				| otherwise = True
+	where
+		thread = NamedThread thisThread
+		pushable r
+			| Remote.specialRemote r = False
+			| Remote.readonly r = False
+			| otherwise = True
 
 {- Decide if now is a good time to push to remotes.
  -

Assistant/Threads/SanityChecker.hs

@@ -25,8 +25,8 @@ thisThread :: ThreadName
 thisThread = "SanityChecker"
 
 {- This thread wakes up occasionally to make sure the tree is in good shape. -}
-sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
-sanityCheckerThread st dstatus transferqueue changechan = forever $ do
+sanityCheckerThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> NamedThread
+sanityCheckerThread st dstatus transferqueue changechan = thread $ forever $ do
 	waitForNextCheck dstatus
 
 	debug thisThread ["starting sanity check"]
@@ -35,6 +35,7 @@ sanityCheckerThread st dstatus transferqueue changechan = forever $ do
 	
 	debug thisThread ["sanity check complete"]
 	where
+		thread = NamedThread thisThread
 		go = do
 			modifyDaemonStatus_ dstatus $ \s -> s
 				{ sanityCheckRunning = True }

Assistant/Threads/TransferPoller.hs

@@ -21,8 +21,8 @@ thisThread = "TransferPoller"
 
 {- This thread polls the status of ongoing transfers, determining how much
  - of each transfer is complete. -}
-transferPollerThread :: ThreadState -> DaemonStatusHandle -> IO ()
-transferPollerThread st dstatus = do
+transferPollerThread :: ThreadState -> DaemonStatusHandle -> NamedThread
+transferPollerThread st dstatus = thread $ do
 	g <- runThreadState st $ fromRepo id
 	tn <- newNotificationHandle =<<
 		transferNotifier <$> getDaemonStatus dstatus
@@ -33,6 +33,7 @@ transferPollerThread st dstatus = do
 			then waitNotification tn -- block until transfers running
 			else mapM_ (poll g) $ M.toList ts
 	where
+		thread = NamedThread thisThread
 		poll g (t, info)
 			{- Downloads are polled by checking the size of the
 			 - temp file being used for the transfer. -}

Assistant/Threads/TransferScanner.hs

@@ -31,11 +31,12 @@ thisThread = "TransferScanner"
 {- This thread waits until a remote needs to be scanned, to find transfers
  - that need to be made, to keep data in sync.
  -}
-transferScannerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue -> IO ()
-transferScannerThread st dstatus scanremotes transferqueue = do
+transferScannerThread :: ThreadState -> DaemonStatusHandle -> ScanRemoteMap -> TransferQueue -> NamedThread
+transferScannerThread st dstatus scanremotes transferqueue = thread $ do
 	startupScan
 	go S.empty
 	where
+		thread = NamedThread thisThread
 		go scanned = do
 			threadDelaySeconds (Seconds 2)
 			(rs, infos) <- unzip <$> getScanRemote scanremotes

Assistant/Threads/TransferWatcher.hs

@@ -20,8 +20,8 @@ thisThread = "TransferWatcher"
 
 {- This thread watches for changes to the gitAnnexTransferDir,
  - and updates the DaemonStatus's map of ongoing transfers. -}
-transferWatcherThread :: ThreadState -> DaemonStatusHandle -> IO ()
-transferWatcherThread st dstatus = do
+transferWatcherThread :: ThreadState -> DaemonStatusHandle -> NamedThread
+transferWatcherThread st dstatus = thread $ do
 	g <- runThreadState st $ fromRepo id
 	let dir = gitAnnexTransferDir g
 	createDirectoryIfMissing True dir
@@ -33,6 +33,8 @@ transferWatcherThread st dstatus = do
 		}
 	void $ watchDir dir (const False) hooks id
 	debug thisThread ["watching for transfers"]
+	where
+		thread = NamedThread thisThread
 
 type Handler = ThreadState -> DaemonStatusHandle -> FilePath -> Maybe FileStatus -> IO ()
 

Assistant/Threads/Transferrer.hs

@@ -30,9 +30,10 @@ maxTransfers :: Int
 maxTransfers = 1
 
 {- Dispatches transfers from the queue. -}
-transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> IO ()
-transfererThread st dstatus transferqueue slots = go =<< readProgramFile
+transfererThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> TransferSlots -> NamedThread
+transfererThread st dstatus transferqueue slots = thread $ go =<< readProgramFile
 	where
+		thread = NamedThread thisThread
 		go program = forever $ inTransferSlot dstatus slots $
 			maybe (return Nothing) (uncurry $ startTransfer st dstatus program)
 				=<< getNextTransfer transferqueue dstatus notrunning

Assistant/Threads/Watcher.hs

@@ -56,8 +56,8 @@ needLsof = error $ unlines
 	, "Be warned: This can corrupt data in the annex, and make fsck complain."
 	]
 
-watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> IO ()
-watchThread st dstatus transferqueue changechan = do
+watchThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> ChangeChan -> NamedThread
+watchThread st dstatus transferqueue changechan = NamedThread thisThread $ do
 	void $ watchDir "." ignored hooks startup
 	debug thisThread [ "watching", "."]
 	where

Assistant/Threads/WebApp.hs

@@ -50,8 +50,8 @@ webAppThread
 	-> TransferSlots
 	-> Maybe (IO String)
 	-> Maybe (Url -> FilePath -> IO ())
-	-> IO ()
-webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun onstartup = do
+	-> NamedThread
+webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun onstartup = thread $ do
 	webapp <- WebApp
 		<$> pure mst
 		<*> pure dstatus
@@ -72,6 +72,7 @@ webAppThread mst dstatus scanremotes transferqueue transferslots postfirstrun on
 		Nothing -> withTempFile "webapp.html" $ \tmpfile _ -> go port webapp tmpfile
 		Just st -> go port webapp =<< runThreadState st (fromRepo gitAnnexHtmlShim)
 	where
+		thread = NamedThread thisThread
 		getreldir Nothing = return Nothing
 		getreldir (Just st) = Just <$>
 			(relHome =<< absPath