display errors when any named thread crashes

1 files changed, 24 insertions, 0 deletions

diff --git a/Assistant/Common.hs b/Assistant/Common.hs
index c1a346e75..d6df77f69 100644
--- a/Assistant/Common.hs
+++ b/Assistant/Common.hs
@@ -8,14 +8,38 @@
 module Assistant.Common (
 	module X,
 	ThreadName,
+	NamedThread(..),
+	runNamedThread,
 	debug
 ) where
 
 import Common.Annex as X
+import Assistant.DaemonStatus
+import Assistant.Alert
 
 import System.Log.Logger
+import qualified Control.Exception as E
 
 type ThreadName = String
+data NamedThread = NamedThread ThreadName (IO ())
 
 debug :: ThreadName -> [String] -> IO ()
 debug threadname ws = debugM threadname $ unwords $ (threadname ++ ":") : ws
+
+runNamedThread :: DaemonStatusHandle -> NamedThread -> IO ()
+runNamedThread dstatus (NamedThread name a) = go
+	where
+		go = do
+			r <- E.try a :: IO (Either E.SomeException ())
+			case r of
+				Right _ -> noop
+				Left e -> do
+					let msg = unwords
+						[ name
+						, "crashed:"
+						, show e
+						]
+					hPutStrLn stderr msg
+					-- TODO click to restart
+					void $ addAlert dstatus $
+						warningAlert name msg