webapp: Now allows restarting any threads that crash.

1 files changed, 39 insertions, 11 deletions

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