use async to track and manage threads

Assistant.hs

@@ -154,11 +154,6 @@ import Assistant.Threads.XMPPClient
 import Assistant.Environment
 import qualified Utility.Daemon
 import Utility.LogFile
-import Utility.ThreadScheduler
-
-import Control.Concurrent
-
-type NamedThread = IO () -> IO (String, IO ())
 
 stopDaemon :: Annex ()
 stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
@@ -197,11 +192,11 @@ startDaemon assistant foreground startbrowser = do
 				=<< newAssistantData st dstatus
 
 	go webappwaiter = do
-		d <- getAssistant id
 #ifdef WITH_WEBAPP
+		d <- getAssistant id
 		urlrenderer <- liftIO newUrlRenderer
 #endif
-		mapM_ (startthread d)
+		mapM_ startthread
 			[ watch $ commitThread
 #ifdef WITH_WEBAPP
 			, assist $ webAppThread d urlrenderer False Nothing webappwaiter
@@ -229,11 +224,10 @@ startDaemon assistant foreground startbrowser = do
 			, watch $ watchThread
 			]
 	
-		liftIO waitForTermination
+		waitNamedThreads
 
 	watch a = (True, a)
 	assist a = (False, a)
-	startthread d (watcher, t)
+	startthread (watcher, t)
-		| watcher || assistant = void $ liftIO $ forkIO $
+		| watcher || assistant = startNamedThread t
-			runAssistant d $ runNamedThread t
 		| otherwise = noop

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 ()
+{- Starts a named thread, if it's not already running.
-runNamedThread (NamedThread name a) = do
+ -
-	d <- getAssistant id
+ - Named threads are run by a management thread, so if they crash
-	liftIO . go $ d { threadName = name }
+ - 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
+	start = do
-		r <- E.try (runAssistant d a) :: IO (Either E.SomeException ())
+		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

Command/WebApp.hs

@@ -109,10 +109,12 @@ firstRun = do
 	urlrenderer <- newUrlRenderer
 	v <- newEmptyMVar
 	let callback a = Just $ a v
-	void $ runAssistant d $ runNamedThread $
+	runAssistant d $ do
-		webAppThread d urlrenderer True 
+		startNamedThread $
-			(callback signaler)
+			webAppThread d urlrenderer True 
-			(callback mainthread)
+				(callback signaler)
+				(callback mainthread)
+		waitNamedThreads
   where
 	signaler v = do
 		putMVar v ""

debian/control

@@ -44,6 +44,7 @@ Build-Depends:
 	libghc-network-protocol-xmpp-dev (>= 0.4.3-1+b1),
 	libghc-gnutls-dev (>= 0.1.4),
 	libghc-xml-types-dev,
+	libghc-async-dev,
 	ikiwiki,
 	perlmagick,
 	git,

doc/install/fromscratch.mdwn

@@ -46,6 +46,7 @@ quite a lot.
   * [network-protocol-xmpp](http://hackage.haskell.org/package/network-protocol-xmpp)
   * [dns](http://hackage.haskell.org/package/dns)
   * [xml-types](http://hackage.haskell.org/package/xml-types)
+  * [async](http://hackage.haskell.org/package/async)
 * Shell commands
   * [git](http://git-scm.com/)
   * [uuid](http://www.ossp.org/pkg/lib/uuid/)

git-annex.cabal

@@ -75,6 +75,9 @@ Executable git-annex
   if flag(WebDAV)
     Build-Depends: DAV (>= 0.3), http-conduit, xml-conduit, http-types
     CPP-Options: -DWITH_WEBDAV
+  
+  if flag(Assistant)
+    Build-Depends: async
 
   if flag(Assistant) && ! os(windows) && ! os(solaris)
     Build-Depends: stm >= 2.3