blob: 090a3a7cd1fa3adde1bab77701f63d0de5ab6c7e (
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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
|
{- git-annex assistant named threads.
-
- Copyright 2012 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU GPL version 3 or higher.
-}
{-# LANGUAGE CPP #-}
module Assistant.NamedThread where
import Annex.Common
import Assistant.Types.NamedThread
import Assistant.Types.ThreadName
import Assistant.Types.DaemonStatus
import Assistant.Types.UrlRenderer
import Assistant.DaemonStatus
import Assistant.Monad
import Utility.NotificationBroadcaster
import Control.Concurrent
import Control.Concurrent.Async
import qualified Data.Map as M
import qualified Control.Exception as E
#ifdef WITH_WEBAPP
import Assistant.WebApp.Types
import Assistant.Types.Alert
import Assistant.Alert
import qualified Data.Text as T
#endif
{- 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 :: UrlRenderer -> NamedThread -> Assistant ()
startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) =
M.lookup name . startedThreads <$> getDaemonStatus >>= \case
Nothing -> start
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
| afterstartupsanitycheck = do
status <- getDaemonStatus
h <- liftIO $ newNotificationHandle False $
startupSanityCheckNotifier status
startwith $ runmanaged $
liftIO $ waitNotification h
| otherwise = startwith $ runmanaged noop
startwith runner = do
d <- getAssistant id
aid <- liftIO $ runner $ d { threadName = name }
restart <- asIO $ startNamedThread urlrenderer (NamedThread False name a)
modifyDaemonStatus_ $ \s -> s
{ startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) }
runmanaged first d = do
aid <- async $ runAssistant d $ do
void first
a
void $ forkIO $ manager d aid
return aid
manager d aid = (E.try (wait aid) :: IO (Either E.SomeException ())) >>= \case
Right _ -> noop
Left e -> do
let msg = unwords
[ fromThreadName $ threadName d
, "crashed:", show e
]
hPutStrLn stderr msg
#ifdef WITH_WEBAPP
button <- runAssistant d $ mkAlertButton True
(T.pack "Restart Thread")
urlrenderer
(RestartThreadR name)
runAssistant d $ void $ addAlert $
(warningAlert (fromThreadName name) msg)
{ alertButtons = [button] }
#endif
namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)
namedThreadId (NamedThread _ name _) = do
m <- startedThreads <$> getDaemonStatus
return $ asyncThreadId . fst <$> M.lookup name m
{- 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 . fst) $ M.elems m
|
