summaryrefslogtreecommitdiff
path: root/Assistant/NamedThread.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Assistant/NamedThread.hs')
-rw-r--r--Assistant/NamedThread.hs43
1 files changed, 35 insertions, 8 deletions
diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs
index 083252f94..9187448fb 100644
--- a/Assistant/NamedThread.hs
+++ b/Assistant/NamedThread.hs
@@ -7,19 +7,39 @@
module Assistant.NamedThread where
-import Assistant.Common
+import Common.Annex
+import Assistant.Types.DaemonStatus
import Assistant.DaemonStatus
import Assistant.Alert
+import Assistant.Monad
-import qualified Control.Exception as E
+import Control.Concurrent
+import Control.Concurrent.Async
+import qualified Data.Map as M
-runNamedThread :: NamedThread -> Assistant ()
-runNamedThread (NamedThread name a) = do
- d <- getAssistant id
- liftIO . go $ d { threadName = name }
+{- 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
- go d = do
- r <- E.try (runAssistant d a) :: IO (Either E.SomeException ())
+ 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
@@ -28,3 +48,10 @@ runNamedThread (NamedThread name a) = do
-- 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
+