webapp: Now allows restarting any threads that crash.

23 files changed, 98 insertions, 55 deletions

diff --git a/Assistant/Common.hs b/Assistant/Common.hs
index 0c97bd1f7..0be536250 100644
--- a/Assistant/Common.hs
+++ b/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
diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs
index 3b1eb86ec..140b9f582 100644
--- a/Assistant/Monad.hs
+++ b/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
-
-{- Information about a named thread that can be run. -}
-data NamedThread = NamedThread ThreadName (Assistant ())
-type ThreadName = String
+import Assistant.Types.ThreadName
 
 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
diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs
index 9187448fb..fbb7da4c2 100644
--- a/Assistant/NamedThread.hs
+++ b/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 namedthread@(NamedThread name a) = do
+startNamedThread :: Maybe UrlRenderer -> NamedThread -> Assistant ()
+startNamedThread urlrenderer 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)
+		Just (aid, _) -> do
+			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
 
diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs
index 46ad83663..c11c6667e 100644
--- a/Assistant/Threads/Committer.hs
+++ b/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
diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs
index afa94f97f..6a01ff35e 100644
--- a/Assistant/Threads/ConfigMonitor.hs
+++ b/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
diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs
index 07f0986a6..fffc6ed37 100644
--- a/Assistant/Threads/DaemonStatus.hs
+++ b/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
diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs
index 3ccb57cbe..2f3b03b16 100644
--- a/Assistant/Threads/Glacier.hs
+++ b/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
diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs
index c581f8087..d8eea8c84 100644
--- a/Assistant/Threads/Merger.hs
+++ b/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
diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs
index 594035c52..143ae9cee 100644
--- a/Assistant/Threads/MountWatcher.hs
+++ b/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
diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs
index c5a48ad25..6ac7203b0 100644
--- a/Assistant/Threads/NetWatcher.hs
+++ b/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
diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs
index 1f9de09ac..b7e3ce66d 100644
--- a/Assistant/Threads/PairListener.hs
+++ b/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 $ 
diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs
index 035a454a1..a444a8530 100644
--- a/Assistant/Threads/Pusher.hs
+++ b/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
diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs
index 1871b680e..24f4f6b29 100644
--- a/Assistant/Threads/SanityChecker.hs
+++ b/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"]
diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs
index 9118e9be3..20b832652 100644
--- a/Assistant/Threads/TransferPoller.hs
+++ b/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
diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs
index 9b863d306..929fb53e7 100644
--- a/Assistant/Threads/TransferScanner.hs
+++ b/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
diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs
index d2f7ebe14..d2ca0e535 100644
--- a/Assistant/Threads/TransferWatcher.hs
+++ b/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)
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index 399e732be..0acadec4b 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/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)
diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs
index f2702ec35..2c61b50f5 100644
--- a/Assistant/Threads/Watcher.hs
+++ b/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
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index c4c9fa87a..e2eed4588 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/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 <$>
diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs
index 99b46dabb..ebface796 100644
--- a/Assistant/Threads/XMPPClient.hs
+++ b/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. -}
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index 6c949c8f4..b60d49edf 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/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.
-	{ startedThreads :: M.Map String (Async ())
+	-- All the named threads that comprise the daemon,
+	-- 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
diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs
new file mode 100644
index 000000000..0e884637a
--- /dev/null
+++ b/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
diff --git a/Assistant/Types/ThreadName.hs b/Assistant/Types/ThreadName.hs
new file mode 100644
index 000000000..c8d264a38
--- /dev/null
+++ b/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