use async to track and manage threads

This commit is contained in:
Joey Hess 2013-01-26 14:14:32 +11:00
parent 7fc6ebb765
commit 1713ed95f7
11 changed files with 77 additions and 61 deletions

View file

@ -10,4 +10,3 @@ module Assistant.Common (module X) where
import Common.Annex as X
import Assistant.Monad as X
import Assistant.Types.DaemonStatus as X
import Assistant.Types.NamedThread as X

View file

@ -19,10 +19,15 @@ module Assistant.Monad (
asIO,
asIO1,
asIO2,
NamedThread(..),
ThreadName,
debug,
notice
) where
import "mtl" Control.Monad.Reader
import Control.Monad.Base (liftBase, MonadBase)
import System.Log.Logger
import Common.Annex
import Assistant.Types.ThreadedMonad
@ -37,6 +42,10 @@ import Assistant.Types.Changes
import Assistant.Types.Buddies
import Assistant.Types.NetMessager
{- Information about a named thread that can be run. -}
data NamedThread = NamedThread ThreadName (Assistant ())
type ThreadName = String
newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a }
deriving (
Monad,
@ -118,3 +127,14 @@ asIO2 a = do
{- Runs an IO action on a selected field of the AssistantData. -}
(<<~) :: (a -> IO b) -> (AssistantData -> a) -> Assistant b
io <<~ v = reader v >>= liftIO . io
debug :: [String] -> Assistant ()
debug = logaction debugM
notice :: [String] -> Assistant ()
notice = logaction noticeM
logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
logaction a ws = do
name <- getAssistant threadName
liftIO $ a name $ unwords $ (name ++ ":") : ws

View file

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

View file

@ -23,9 +23,6 @@ import qualified Annex.Branch
import qualified Data.Set as S
thisThread :: ThreadName
thisThread = "ConfigMonitor"
{- This thread detects when configuration changes have been made to the
- git-annex branch and reloads cached configuration.
-

View file

@ -16,12 +16,15 @@ import Utility.NotificationBroadcaster
import Logs.Transfer
import Control.Concurrent.STM
import Control.Concurrent.Async
import Data.Time.Clock.POSIX
import qualified Data.Map as M
data DaemonStatus = DaemonStatus
-- All the named threads that comprise the daemon.
{ startedThreads :: M.Map String (Async ())
-- False when the daemon is performing its startup scan
{ scanComplete :: Bool
, scanComplete :: Bool
-- Time when a previous process of the daemon was running ok
, lastRunning :: Maybe POSIXTime
-- True when the sanity checker is running
@ -58,7 +61,8 @@ type DaemonStatusHandle = TMVar DaemonStatus
newDaemonStatus :: IO DaemonStatus
newDaemonStatus = DaemonStatus
<$> pure False
<$> pure M.empty
<*> pure False
<*> pure Nothing
<*> pure False
<*> pure Nothing

View file

@ -1,32 +0,0 @@
{- git-annex assistant named threads.
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
module Assistant.Types.NamedThread (
ThreadName,
NamedThread(..),
debug,
notice,
) where
import Common.Annex
import Assistant.Monad
import System.Log.Logger
type ThreadName = String
data NamedThread = NamedThread ThreadName (Assistant ())
debug :: [String] -> Assistant ()
debug = logaction debugM
notice :: [String] -> Assistant ()
notice = logaction noticeM
logaction :: (String -> String -> IO ()) -> [String] -> Assistant ()
logaction a ws = do
name <- getAssistant threadName
liftIO $ a name $ unwords $ (name ++ ":") : ws