use async to track and manage threads

Assistant/Common.hs

@@ -10,4 +10,3 @@ module Assistant.Common (module X) where
 import Common.Annex as X
 import Assistant.Monad as X
 import Assistant.Types.DaemonStatus as X
-import Assistant.Types.NamedThread as X

Assistant/Monad.hs

@@ -19,10 +19,15 @@ module Assistant.Monad (
 	asIO,
 	asIO1,
 	asIO2,
+	NamedThread(..),
+	ThreadName,
+	debug,
+	notice
 ) where
 
 import "mtl" Control.Monad.Reader
 import Control.Monad.Base (liftBase, MonadBase)
+import System.Log.Logger
 
 import Common.Annex
 import Assistant.Types.ThreadedMonad
@@ -37,6 +42,10 @@ import Assistant.Types.Changes
 import Assistant.Types.Buddies
 import Assistant.Types.NetMessager
 
+{- Information about a named thread that can be run. -}
+data NamedThread = NamedThread ThreadName (Assistant ())
+type ThreadName = String
+
 newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
 	deriving (
 		Monad,
@@ -118,3 +127,14 @@ asIO2 a = do
 {- Runs an IO action on a selected field of the AssistantData. -}
 (<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
 io <<~ v = reader v >>= liftIO . io
+
+debug :: [String] -> Assistant ()
+debug = logaction debugM
+
+notice :: [String] -> Assistant ()
+notice = logaction noticeM
+
+logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
+logaction a ws = do
+	name <- getAssistant threadName
+	liftIO $ a name $ unwords $ (name ++ ":") : ws

Assistant/NamedThread.hs

@@ -7,19 +7,39 @@
 
 module Assistant.NamedThread where
 
-import Assistant.Common
+import Common.Annex
+import Assistant.Types.DaemonStatus
 import Assistant.DaemonStatus
 import Assistant.Alert
+import Assistant.Monad
 
-import qualified Control.Exception as E
+import Control.Concurrent
+import Control.Concurrent.Async
+import qualified Data.Map as M
 
-runNamedThread :: NamedThread -> Assistant ()
-runNamedThread (NamedThread name a) = do
-	d <- getAssistant id
-	liftIO . go $ d { threadName = name }
+{- Starts a named thread, if it's not already running.
+ -
+ - Named threads are run by a management thread, so if they crash
+ - an alert is displayed, allowing the thread to be restarted. -}
+startNamedThread :: NamedThread -> Assistant ()
+startNamedThread namedthread@(NamedThread name a) = do
+	m <- startedThreads <$> getDaemonStatus
+	case M.lookup name m of
+		Nothing -> start
+		Just aid ->
+			maybe noop (const start) =<< liftIO (poll aid)
   where
-	go d = do
-		r <- E.try (runAssistant d a) :: IO (Either E.SomeException ())
+	start = do
+		d <- getAssistant id
+		aid <- liftIO $ runmanaged $ d { threadName = name }
+		modifyDaemonStatus_ $ \s -> s
+			{ startedThreads = M.insertWith' const name aid (startedThreads s) }
+	runmanaged d = do
+		aid <- async $ runAssistant d a
+		void $ forkIO $ manager d aid
+		return aid
+	manager d aid = do
+		r <- waitCatch aid
 		case r of
 			Right _ -> noop
 			Left e -> do
@@ -28,3 +48,10 @@ runNamedThread (NamedThread name a) = do
 				-- TODO click to restart
 				runAssistant d $ void $
 					addAlert $ warningAlert name msg
+
+{- Waits for all named threads that have been started to finish. -}
+waitNamedThreads :: Assistant ()
+waitNamedThreads = do
+	m <- startedThreads <$> getDaemonStatus
+	liftIO $ mapM_ wait $ M.elems m
+

Assistant/Threads/ConfigMonitor.hs

@@ -23,9 +23,6 @@ import qualified Annex.Branch
 
 import qualified Data.Set as S
 
-thisThread :: ThreadName
-thisThread = "ConfigMonitor"
-
 {- This thread detects when configuration changes have been made to the
  - git-annex branch and reloads cached configuration.
  -

Assistant/Types/DaemonStatus.hs

@@ -16,12 +16,15 @@ import Utility.NotificationBroadcaster
 import Logs.Transfer
 
 import Control.Concurrent.STM
+import Control.Concurrent.Async
 import Data.Time.Clock.POSIX
 import qualified Data.Map as M
 
 data DaemonStatus = DaemonStatus
+	-- All the named threads that comprise the daemon.
+	{ startedThreads :: M.Map String (Async ())
 	-- False when the daemon is performing its startup scan
-	{ scanComplete :: Bool
+	, scanComplete :: Bool
 	-- Time when a previous process of the daemon was running ok
 	, lastRunning :: Maybe POSIXTime
 	-- True when the sanity checker is running
@@ -58,7 +61,8 @@ type DaemonStatusHandle = TMVar DaemonStatus
 
 newDaemonStatus :: IO DaemonStatus
 newDaemonStatus = DaemonStatus
-	<$> pure False
+	<$> pure M.empty
+	<*> pure False
 	<*> pure Nothing
 	<*> pure False
 	<*> pure Nothing

Assistant/Types/NamedThread.hs

@@ -1,32 +0,0 @@
-{- git-annex assistant named threads.
- -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
- -
- - Licensed under the GNU GPL version 3 or higher.
- -}
-
-module Assistant.Types.NamedThread (
-	ThreadName,
-	NamedThread(..),
-	debug,
-	notice,
-) where
-
-import Common.Annex
-import Assistant.Monad
-
-import System.Log.Logger
-
-type ThreadName = String
-data NamedThread = NamedThread ThreadName (Assistant ())
-
-debug :: [String] -> Assistant ()
-debug = logaction debugM
-
-notice :: [String] -> Assistant ()
-notice = logaction noticeM
-
-logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
-logaction a ws = do
-	name <- getAssistant threadName
-	liftIO $ a name $ unwords $ (name ++ ":") : ws