display errors when any named thread crashes

This commit is contained in:
Joey Hess 2012-09-06 14:56:04 -04:00
parent d11ded822c
commit a00f1d26bc
18 changed files with 133 additions and 64 deletions

View file

@ -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