blob: 9187448fb047a523478d230675d237f6a4802b83 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
|
{- git-annex assistant named threads.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.NamedThread where
import Common.Annex
import Assistant.Types.DaemonStatus
import Assistant.DaemonStatus
import Assistant.Alert
import Assistant.Monad
import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.Map as M
{- 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
m <- startedThreads <$> getDaemonStatus
case M.lookup name m of
Nothing -> start
Just aid ->
maybe noop (const start) =<< liftIO (poll aid)
where
start = do
d <- getAssistant id
aid <- liftIO $ runmanaged $ d { threadName = name }
modifyDaemonStatus_ $ \s -> s
{ startedThreads = M.insertWith' const name aid (startedThreads s) }
runmanaged d = do
aid <- async $ runAssistant d a
void $ forkIO $ manager d aid
return aid
manager d aid = do
r <- waitCatch aid
case r of
Right _ -> noop
Left e -> do
let msg = unwords [name, "crashed:", show e]
hPutStrLn stderr msg
-- TODO click to restart
runAssistant d $ void $
addAlert $ warningAlert name msg
{- Waits for all named threads that have been started to finish. -}
waitNamedThreads :: Assistant ()
waitNamedThreads = do
m <- startedThreads <$> getDaemonStatus
liftIO $ mapM_ wait $ M.elems m
|
