635c9a1549
Extends the index.lock handling to other git lock files. I surveyed all lock files used by git, and found more than I expected. All are handled the same in git; it leaves them open while doing the operation, possibly writing the new file content to the lock file, and then closes them when done. The gc.pid file is excluded because it won't affect the normal operation of the assistant, and waiting for a gc to finish on startup wouldn't be good. All threads except the webapp thread wait on the new startup sanity checker thread to complete, so they won't try to do things with git that fail due to stale lock files. The webapp thread mostly avoids doing that kind of thing itself. A few configurators might fail on lock files, but only if the user is explicitly trying to run them. The webapp needs to start immediately when the user has opened it, even if there are stale lock files. Arranging for the threads to wait on the startup sanity checker was a bit of a bear. Have to get all the NotificationHandles set up before the startup sanity checker runs, or they won't see its signal. Perhaps the NotificationBroadcaster is not the best interface to have used for this. Oh well, it works. This commit was sponsored by Michael Jakl
102 lines
3 KiB
Haskell
102 lines
3 KiB
Haskell
{- git-annex assistant named threads.
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
|
|
module Assistant.NamedThread where
|
|
|
|
import Common.Annex
|
|
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) = do
|
|
m <- startedThreads <$> getDaemonStatus
|
|
case M.lookup name m of
|
|
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 = do
|
|
r <- E.try (wait aid) :: IO (Either E.SomeException ())
|
|
case r of
|
|
Right _ -> noop
|
|
Left e -> do
|
|
let msg = unwords
|
|
[ fromThreadName $ threadName d
|
|
, "crashed:", show e
|
|
]
|
|
hPutStrLn stderr msg
|
|
#ifdef WITH_WEBAPP
|
|
button <- runAssistant d $ mkAlertButton
|
|
(T.pack "Restart Thread")
|
|
urlrenderer
|
|
(RestartThreadR name)
|
|
runAssistant d $ void $ addAlert $
|
|
(warningAlert (fromThreadName name) msg)
|
|
{ alertButton = Just 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
|
|
|