40ecf58d4bThis does not change the overall license of the git-annex program, which was already AGPL due to a number of sources files being AGPL already. Legally speaking, I'm adding a new license under which these files are now available; I already released their current contents under the GPL license. Now they're dual licensed GPL and AGPL. However, I intend for all my future changes to these files to only be released under the AGPL license, and I won't be tracking the dual licensing status, so I'm simply changing the license statement to say it's AGPL. (In some cases, others wrote parts of the code of a file and released it under the GPL; but in all cases I have contributed a significant portion of the code in each file and it's that code that is getting the AGPL license; the GPL license of other contributors allows combining with AGPL code.)
99 lines
3 KiB
Haskell
99 lines
3 KiB
Haskell
{- git-annex assistant named threads.
|
|
-
|
|
- Copyright 2012 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL 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.Strict 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.insert 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
|
|
|