webapp: Now allows restarting any threads that crash.

Assistant.hs

@@ -154,6 +154,7 @@ import Assistant.Threads.XMPPClient
 import Assistant.Environment
 import qualified Utility.Daemon
 import Utility.LogFile
+import Utility.ThreadScheduler
 
 stopDaemon :: Annex ()
 stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile
@@ -196,7 +197,7 @@ startDaemon assistant foreground startbrowser = do
 		d <- getAssistant id
 		urlrenderer <- liftIO newUrlRenderer
 #endif
-		mapM_ startthread
+		mapM_ (startthread urlrenderer)
 			[ watch $ commitThread
 #ifdef WITH_WEBAPP
 			, assist $ webAppThread d urlrenderer False Nothing webappwaiter
@@ -224,10 +225,10 @@ startDaemon assistant foreground startbrowser = do
 			, watch $ watchThread
 			]
 	
-		waitNamedThreads
+		liftIO waitForTermination
 
 	watch a = (True, a)
 	assist a = (False, a)
-	startthread (watcher, t)
+	startthread urlrenderer (watcher, t)
-		| watcher || assistant = startNamedThread t
+		| watcher || assistant = startNamedThread (Just urlrenderer) t
 		| otherwise = noop

Assistant/Common.hs

@@ -10,3 +10,4 @@ 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,7 +19,6 @@ module Assistant.Monad (
 	asIO,
 	asIO1,
 	asIO2,
-	NamedThread(..),
 	ThreadName,
 	debug,
 	notice
@@ -41,10 +40,7 @@ import Assistant.Types.Commits
 import Assistant.Types.Changes
 import Assistant.Types.Buddies
 import Assistant.Types.NetMessager
-
+import Assistant.Types.ThreadName
-{- 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 (
@@ -59,7 +55,7 @@ instance MonadBase IO Assistant where
 	liftBase = Assistant . liftBase
 
 data AssistantData = AssistantData
-	{ threadName :: String
+	{ threadName :: ThreadName
 	, threadState :: ThreadState
 	, daemonStatusHandle :: DaemonStatusHandle
 	, scanRemoteMap :: ScanRemoteMap
@@ -75,7 +71,7 @@ data AssistantData = AssistantData
 
 newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData
 newAssistantData st dstatus = AssistantData
-	<$> pure "main"
+	<$> pure (ThreadName "main")
 	<*> pure st
 	<*> pure dstatus
 	<*> newScanRemoteMap
@@ -136,5 +132,5 @@ notice = logaction noticeM
 
 logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
 logaction a ws = do
-	name <- getAssistant threadName
+	ThreadName name <- getAssistant threadName
 	liftIO $ a name $ unwords $ (name ++ ":") : ws

Assistant/NamedThread.hs

@@ -8,50 +8,78 @@
 module Assistant.NamedThread where
 
 import Common.Annex
+import Assistant.Types.NamedThread
+import Assistant.Types.ThreadName
 import Assistant.Types.DaemonStatus
 import Assistant.DaemonStatus
 import Assistant.Alert
 import Assistant.Monad
+import Assistant.WebApp
+import Assistant.WebApp.Types
 
 import Control.Concurrent
 import Control.Concurrent.Async
 import qualified Data.Map as M
+import qualified Data.Text as T
+import qualified Control.Exception as E
 
 {- 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 :: Maybe UrlRenderer -> NamedThread -> Assistant ()
-startNamedThread namedthread@(NamedThread name a) = do
+startNamedThread urlrenderer namedthread@(NamedThread name a) = do
 	m <- startedThreads <$> getDaemonStatus
 	case M.lookup name m of
 		Nothing -> start
-		Just aid ->
+		Just (aid, _) -> do
-			maybe noop (const start) =<< liftIO (poll aid)
+			r <- liftIO (E.try (poll aid) :: IO (Either E.SomeException (Maybe (Either E.SomeException ()))))
+			case r of
+				Right Nothing -> noop
+				_ -> start
   where
 	start = do
 		d <- getAssistant id
 		aid <- liftIO $ runmanaged $ d { threadName = name }
+		restart <- asIO $ startNamedThread urlrenderer namedthread
 		modifyDaemonStatus_ $ \s -> s
-			{ startedThreads = M.insertWith' const name aid (startedThreads s) }
+			{ startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) }
 	runmanaged d = do
 		aid <- async $ runAssistant d a
 		void $ forkIO $ manager d aid
 		return aid
 	manager d aid = do
-		r <- waitCatch aid
+		r <- E.try (wait aid) :: IO (Either E.SomeException ())
 		case r of
 			Right _ -> noop
 			Left e -> do
-				let msg = unwords [name, "crashed:", show e]
+				let msg = unwords
+					[ fromThreadName name
+					, "crashed:", show e
+					]
 				hPutStrLn stderr msg
-				-- TODO click to restart
+				button <- runAssistant d mkbutton
 				runAssistant d $ void $
-					addAlert $ warningAlert name msg
+					addAlert $ (warningAlert (fromThreadName name) msg)
+						{ alertButton = button }
+	mkbutton = case urlrenderer of
+		Nothing -> return Nothing
+		Just renderer -> do
+			close <- asIO1 removeAlert
+			url <- liftIO $ renderUrl renderer (RestartThreadR name) []
+			return $ Just $ AlertButton
+				{ buttonLabel = T.pack "Restart Thread"
+				, buttonUrl = url
+				, buttonAction = Just close
+				}
 
-{- Waits for all named threads that have been started to finish. -}
+{- Waits for all named threads that have been started to finish.
+ -
+ - Note that if a named thread crashes, it will probably
+ - cause this to crash as well. Also, named threads that are started
+ - after this is called will not be waited on. -}
 waitNamedThreads :: Assistant ()
 waitNamedThreads = do
 	m <- startedThreads <$> getDaemonStatus
-	liftIO $ mapM_ wait $ M.elems m
+	liftIO $ mapM_ (wait . fst) $ M.elems m
 

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

Assistant/Types/DaemonStatus.hs

@@ -14,6 +14,7 @@ import Assistant.Alert
 import Assistant.Pairing
 import Utility.NotificationBroadcaster
 import Logs.Transfer
+import Assistant.Types.ThreadName
 
 import Control.Concurrent.STM
 import Control.Concurrent.Async
@@ -21,8 +22,9 @@ import Data.Time.Clock.POSIX
 import qualified Data.Map as M
 
 data DaemonStatus = DaemonStatus
-	-- All the named threads that comprise the daemon.
+	-- All the named threads that comprise the daemon,
-	{ startedThreads :: M.Map String (Async ())
+	-- and actions to run to restart them.
+	{ startedThreads :: M.Map ThreadName (Async (), IO ())
 	-- False when the daemon is performing its startup scan
 	, scanComplete :: Bool
 	-- Time when a previous process of the daemon was running ok

Assistant/Types/NamedThread.hs

@@ -0,0 +1,17 @@
+{- named threads
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.NamedThread where
+
+import Assistant.Monad
+import Assistant.Types.ThreadName
+
+{- Information about a named thread that can be run. -}
+data NamedThread = NamedThread ThreadName (Assistant ())
+
+namedThread :: String -> Assistant () -> NamedThread
+namedThread name a = NamedThread (ThreadName name) a

Assistant/Types/ThreadName.hs

@@ -0,0 +1,14 @@
+{- name of a thread
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Assistant.Types.ThreadName where
+
+newtype ThreadName = ThreadName String
+	deriving (Eq, Read, Show, Ord)
+
+fromThreadName :: ThreadName -> String
+fromThreadName (ThreadName n) = n

Assistant/WebApp/Control.hs

@@ -12,9 +12,11 @@ module Assistant.WebApp.Control where
 import Assistant.WebApp.Common
 import Locations.UserConfig
 import Utility.LogFile
+import Assistant.DaemonStatus
 
 import Control.Concurrent
 import System.Posix (getProcessID, signalProcess, sigTERM)
+import qualified Data.Map as M
 
 getShutdownR :: Handler RepHtml
 getShutdownR = page "Shutdown" Nothing $
@@ -42,6 +44,12 @@ getRestartR = page "Restarting" Nothing $ do
 	restartcommand program = program ++ " assistant --stop; " ++
 		program ++ " webapp"
 
+getRestartThreadR :: ThreadName -> Handler ()
+getRestartThreadR name = do
+	m <- liftAssistant $ startedThreads <$> getDaemonStatus
+	liftIO $ maybe noop snd $ M.lookup name m
+	redirectBack
+
 getLogR :: Handler RepHtml
 getLogR = page "Logs" Nothing $ do
 	logfile <- lift $ runAnnex undefined $ fromRepo gitAnnexLogFile

Assistant/WebApp/Types.hs

@@ -131,3 +131,7 @@ instance PathPiece RepoListNotificationId where
 instance PathPiece RepoSelector where
 	toPathPiece = pack . show
 	fromPathPiece = readish . unpack
+
+instance PathPiece ThreadName where
+	toPathPiece = pack . show
+	fromPathPiece = readish . unpack

Assistant/WebApp/routes

@@ -8,6 +8,7 @@
 /shutdown ShutdownR GET
 /shutdown/confirm ShutdownConfirmedR GET
 /restart RestartR GET
+/restart/thread/#ThreadName RestartThreadR GET
 /log LogR GET
 
 /config ConfigurationR GET

Command/WebApp.hs

@@ -110,7 +110,7 @@ firstRun = do
 	v <- newEmptyMVar
 	let callback a = Just $ a v
 	runAssistant d $ do
-		startNamedThread $
+		startNamedThread (Just urlrenderer) $
 			webAppThread d urlrenderer True 
 				(callback signaler)
 				(callback mainthread)

debian/changelog

@@ -1,3 +1,9 @@
+git-annex (3.20130125) UNRELEASED; urgency=low
+
+  * webapp: Now allows restarting any threads that crash.
+
+ -- Joey Hess <joeyh@debian.org>  Sat, 26 Jan 2013 15:48:40 +1100
+
 git-annex (3.20130124) unstable; urgency=low
 
   * Added source repository group, that only retains files until they've

git-annex.cabal

@@ -1,5 +1,5 @@
 Name: git-annex
-Version: 3.20130124
+Version: 3.20130125
 Cabal-Version: >= 1.8
 License: GPL
 Maintainer: Joey Hess <joey@kitenet.net>