diff options
27 files changed, 111 insertions, 61 deletions
diff --git a/Assistant.hs b/Assistant.hs index d1a9f7102..45c0e9f03 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -154,6 +154,7 @@ import Assistant.Threads.XMPPClient import Assistant.Environment import qualified Utility.Daemon import Utility.LogFile +import Utility.ThreadScheduler stopDaemon :: Annex () stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile @@ -196,7 +197,7 @@ startDaemon assistant foreground startbrowser = do d <- getAssistant id urlrenderer <- liftIO newUrlRenderer #endif - mapM_ startthread + mapM_ (startthread urlrenderer) [ watch $ commitThread #ifdef WITH_WEBAPP , assist $ webAppThread d urlrenderer False Nothing webappwaiter @@ -224,10 +225,10 @@ startDaemon assistant foreground startbrowser = do , watch $ watchThread ] - waitNamedThreads + liftIO waitForTermination watch a = (True, a) assist a = (False, a) - startthread (watcher, t) - | watcher || assistant = startNamedThread t + startthread urlrenderer (watcher, t) + | watcher || assistant = startNamedThread (Just urlrenderer) t | otherwise = noop diff --git a/Assistant/Common.hs b/Assistant/Common.hs index 0c97bd1f7..0be536250 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -10,3 +10,4 @@ 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 diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index 3b1eb86ec..140b9f582 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -19,7 +19,6 @@ module Assistant.Monad ( asIO, asIO1, asIO2, - NamedThread(..), ThreadName, debug, notice @@ -41,10 +40,7 @@ import Assistant.Types.Commits 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 +import Assistant.Types.ThreadName newtype Assistant a = Assistant { mkAssistant :: ReaderT AssistantData IO a } deriving ( @@ -59,7 +55,7 @@ instance MonadBase IO Assistant where liftBase = Assistant . liftBase data AssistantData = AssistantData - { threadName :: String + { threadName :: ThreadName , threadState :: ThreadState , daemonStatusHandle :: DaemonStatusHandle , scanRemoteMap :: ScanRemoteMap @@ -75,7 +71,7 @@ data AssistantData = AssistantData newAssistantData :: ThreadState -> DaemonStatusHandle -> IO AssistantData newAssistantData st dstatus = AssistantData - <$> pure "main" + <$> pure (ThreadName "main") <*> pure st <*> pure dstatus <*> newScanRemoteMap @@ -136,5 +132,5 @@ notice = logaction noticeM logaction :: (String -> String -> IO ()) -> [String] -> Assistant () logaction a ws = do - name <- getAssistant threadName + ThreadName name <- getAssistant threadName liftIO $ a name $ unwords $ (name ++ ":") : ws diff --git a/Assistant/NamedThread.hs b/Assistant/NamedThread.hs index 9187448fb..fbb7da4c2 100644 --- a/Assistant/NamedThread.hs +++ b/Assistant/NamedThread.hs @@ -8,50 +8,78 @@ module Assistant.NamedThread where import Common.Annex +import Assistant.Types.NamedThread +import Assistant.Types.ThreadName import Assistant.Types.DaemonStatus import Assistant.DaemonStatus import Assistant.Alert import Assistant.Monad +import Assistant.WebApp +import Assistant.WebApp.Types import Control.Concurrent import Control.Concurrent.Async import qualified Data.Map as M +import qualified Data.Text as T +import qualified Control.Exception as E {- 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 +startNamedThread :: Maybe UrlRenderer -> NamedThread -> Assistant () +startNamedThread urlrenderer 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) + 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 = do d <- getAssistant id aid <- liftIO $ runmanaged $ d { threadName = name } + restart <- asIO $ startNamedThread urlrenderer namedthread modifyDaemonStatus_ $ \s -> s - { startedThreads = M.insertWith' const name aid (startedThreads s) } + { startedThreads = M.insertWith' const name (aid, restart) (startedThreads s) } runmanaged d = do aid <- async $ runAssistant d a void $ forkIO $ manager d aid return aid manager d aid = do - r <- waitCatch aid + r <- E.try (wait aid) :: IO (Either E.SomeException ()) case r of Right _ -> noop Left e -> do - let msg = unwords [name, "crashed:", show e] + let msg = unwords + [ fromThreadName name + , "crashed:", show e + ] hPutStrLn stderr msg - -- TODO click to restart + button <- runAssistant d mkbutton runAssistant d $ void $ - addAlert $ warningAlert name msg + addAlert $ (warningAlert (fromThreadName name) msg) + { alertButton = button } + mkbutton = case urlrenderer of + Nothing -> return Nothing + Just renderer -> do + close <- asIO1 removeAlert + url <- liftIO $ renderUrl renderer (RestartThreadR name) [] + return $ Just $ AlertButton + { buttonLabel = T.pack "Restart Thread" + , buttonUrl = url + , buttonAction = Just close + } -{- Waits for all named threads that have been started to finish. -} +{- 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 $ M.elems m + liftIO $ mapM_ (wait . fst) $ M.elems m diff --git a/Assistant/Threads/Committer.hs b/Assistant/Threads/Committer.hs index 46ad83663..c11c6667e 100644 --- a/Assistant/Threads/Committer.hs +++ b/Assistant/Threads/Committer.hs @@ -41,7 +41,7 @@ import Data.Either {- This thread makes git commits at appropriate times. -} commitThread :: NamedThread -commitThread = NamedThread "Committer" $ do +commitThread = namedThread "Committer" $ do delayadd <- liftAnnex $ maybe delayaddDefault (return . Just . Seconds) =<< annexDelayAdd <$> Annex.getGitConfig diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index afa94f97f..6a01ff35e 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -32,7 +32,7 @@ import qualified Data.Set as S - be detected immediately. -} configMonitorThread :: NamedThread -configMonitorThread = NamedThread "ConfigMonitor" $ loop =<< getConfigs +configMonitorThread = namedThread "ConfigMonitor" $ loop =<< getConfigs where loop old = do waitBranchChange diff --git a/Assistant/Threads/DaemonStatus.hs b/Assistant/Threads/DaemonStatus.hs index 07f0986a6..fffc6ed37 100644 --- a/Assistant/Threads/DaemonStatus.hs +++ b/Assistant/Threads/DaemonStatus.hs @@ -16,7 +16,7 @@ import Utility.NotificationBroadcaster - frequently than once every ten minutes. -} daemonStatusThread :: NamedThread -daemonStatusThread = NamedThread "DaemonStatus" $ do +daemonStatusThread = namedThread "DaemonStatus" $ do notifier <- liftIO . newNotificationHandle =<< changeNotifier <$> getDaemonStatus checkpoint diff --git a/Assistant/Threads/Glacier.hs b/Assistant/Threads/Glacier.hs index 3ccb57cbe..2f3b03b16 100644 --- a/Assistant/Threads/Glacier.hs +++ b/Assistant/Threads/Glacier.hs @@ -24,7 +24,7 @@ import qualified Data.Set as S - downloads. If so, runs glacier-cli to check if the files are now - available, and queues the downloads. -} glacierThread :: NamedThread -glacierThread = NamedThread "Glacier" $ runEvery (Seconds 3600) <~> go +glacierThread = namedThread "Glacier" $ runEvery (Seconds 3600) <~> go where isglacier r = Remote.remotetype r == Glacier.remote go = do diff --git a/Assistant/Threads/Merger.hs b/Assistant/Threads/Merger.hs index c581f8087..d8eea8c84 100644 --- a/Assistant/Threads/Merger.hs +++ b/Assistant/Threads/Merger.hs @@ -17,13 +17,10 @@ import qualified Git import qualified Git.Branch import qualified Command.Sync -thisThread :: ThreadName -thisThread = "Merger" - {- This thread watches for changes to .git/refs/, and handles incoming - pushes. -} mergeThread :: NamedThread -mergeThread = NamedThread "Merger" $ do +mergeThread = namedThread "Merger" $ do g <- liftAnnex gitRepo let dir = Git.localGitDir g </> "refs" liftIO $ createDirectoryIfMissing True dir diff --git a/Assistant/Threads/MountWatcher.hs b/Assistant/Threads/MountWatcher.hs index 594035c52..143ae9cee 100644 --- a/Assistant/Threads/MountWatcher.hs +++ b/Assistant/Threads/MountWatcher.hs @@ -33,11 +33,8 @@ import qualified Control.Exception as E #warning Building without dbus support; will use mtab polling #endif -thisThread :: ThreadName -thisThread = "MountWatcher" - mountWatcherThread :: NamedThread -mountWatcherThread = NamedThread "MountWatcher" $ +mountWatcherThread = namedThread "MountWatcher" $ #if WITH_DBUS dbusThread #else diff --git a/Assistant/Threads/NetWatcher.hs b/Assistant/Threads/NetWatcher.hs index c5a48ad25..6ac7203b0 100644 --- a/Assistant/Threads/NetWatcher.hs +++ b/Assistant/Threads/NetWatcher.hs @@ -33,7 +33,7 @@ netWatcherThread = thread dbusThread netWatcherThread = thread noop #endif where - thread = NamedThread "NetWatcher" + thread = namedThread "NetWatcher" {- This is a fallback for when dbus cannot be used to detect - network connection changes, but it also ensures that @@ -41,7 +41,7 @@ netWatcherThread = thread noop - while (despite the local network staying up), are synced with - periodically. -} netWatcherFallbackThread :: NamedThread -netWatcherFallbackThread = NamedThread "NetWatcherFallback" $ +netWatcherFallbackThread = namedThread "NetWatcherFallback" $ runEvery (Seconds 3600) <~> handleConnection #if WITH_DBUS diff --git a/Assistant/Threads/PairListener.hs b/Assistant/Threads/PairListener.hs index 1f9de09ac..b7e3ce66d 100644 --- a/Assistant/Threads/PairListener.hs +++ b/Assistant/Threads/PairListener.hs @@ -23,11 +23,8 @@ import Network.Socket import qualified Data.Text as T import Data.Char -thisThread :: ThreadName -thisThread = "PairListener" - pairListenerThread :: UrlRenderer -> NamedThread -pairListenerThread urlrenderer = NamedThread "PairListener" $ do +pairListenerThread urlrenderer = namedThread "PairListener" $ do listener <- asIO1 $ go [] [] liftIO $ withSocketsDo $ runEvery (Seconds 1) $ void $ tryIO $ diff --git a/Assistant/Threads/Pusher.hs b/Assistant/Threads/Pusher.hs index 035a454a1..a444a8530 100644 --- a/Assistant/Threads/Pusher.hs +++ b/Assistant/Threads/Pusher.hs @@ -19,12 +19,9 @@ import qualified Types.Remote as Remote import Data.Time.Clock -thisThread :: ThreadName -thisThread = "Pusher" - {- This thread retries pushes that failed before. -} pushRetryThread :: NamedThread -pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do +pushRetryThread = namedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do -- We already waited half an hour, now wait until there are failed -- pushes to retry. topush <- getFailedPushesBefore (fromIntegral halfhour) @@ -38,7 +35,7 @@ pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do {- This thread pushes git commits out to remotes soon after they are made. -} pushThread :: NamedThread -pushThread = NamedThread "Pusher" $ runEvery (Seconds 2) <~> do +pushThread = namedThread "Pusher" $ runEvery (Seconds 2) <~> do -- We already waited two seconds as a simple rate limiter. -- Next, wait until at least one commit has been made commits <- getCommits diff --git a/Assistant/Threads/SanityChecker.hs b/Assistant/Threads/SanityChecker.hs index 1871b680e..24f4f6b29 100644 --- a/Assistant/Threads/SanityChecker.hs +++ b/Assistant/Threads/SanityChecker.hs @@ -20,7 +20,7 @@ import Data.Time.Clock.POSIX {- This thread wakes up occasionally to make sure the tree is in good shape. -} sanityCheckerThread :: NamedThread -sanityCheckerThread = NamedThread "SanityChecker" $ forever $ do +sanityCheckerThread = namedThread "SanityChecker" $ forever $ do waitForNextCheck debug ["starting sanity check"] diff --git a/Assistant/Threads/TransferPoller.hs b/Assistant/Threads/TransferPoller.hs index 9118e9be3..20b832652 100644 --- a/Assistant/Threads/TransferPoller.hs +++ b/Assistant/Threads/TransferPoller.hs @@ -19,7 +19,7 @@ import qualified Data.Map as M {- This thread polls the status of ongoing transfers, determining how much - of each transfer is complete. -} transferPollerThread :: NamedThread -transferPollerThread = NamedThread "TransferPoller" $ do +transferPollerThread = namedThread "TransferPoller" $ do g <- liftAnnex gitRepo tn <- liftIO . newNotificationHandle =<< transferNotifier <$> getDaemonStatus diff --git a/Assistant/Threads/TransferScanner.hs b/Assistant/Threads/TransferScanner.hs index 9b863d306..929fb53e7 100644 --- a/Assistant/Threads/TransferScanner.hs +++ b/Assistant/Threads/TransferScanner.hs @@ -31,7 +31,7 @@ import qualified Data.Set as S - that need to be made, to keep data in sync. -} transferScannerThread :: NamedThread -transferScannerThread = NamedThread "TransferScanner" $ do +transferScannerThread = namedThread "TransferScanner" $ do startupScan go S.empty where diff --git a/Assistant/Threads/TransferWatcher.hs b/Assistant/Threads/TransferWatcher.hs index d2f7ebe14..d2ca0e535 100644 --- a/Assistant/Threads/TransferWatcher.hs +++ b/Assistant/Threads/TransferWatcher.hs @@ -22,7 +22,7 @@ import Control.Concurrent {- This thread watches for changes to the gitAnnexTransferDir, - and updates the DaemonStatus's map of ongoing transfers. -} transferWatcherThread :: NamedThread -transferWatcherThread = NamedThread "TransferWatcher" $ do +transferWatcherThread = namedThread "TransferWatcher" $ do dir <- liftAnnex $ gitAnnexTransferDir <$> gitRepo liftIO $ createDirectoryIfMissing True dir let hook a = Just <$> asIO2 (runHandler a) diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs index 399e732be..0acadec4b 100644 --- a/Assistant/Threads/Transferrer.hs +++ b/Assistant/Threads/Transferrer.hs @@ -25,7 +25,7 @@ import System.Process (create_group) {- Dispatches transfers from the queue. -} transfererThread :: NamedThread -transfererThread = NamedThread "Transferr" $ do +transfererThread = namedThread "Transferrer" $ do program <- liftIO readProgramFile forever $ inTransferSlot $ maybe (return Nothing) (uncurry $ startTransfer program) diff --git a/Assistant/Threads/Watcher.hs b/Assistant/Threads/Watcher.hs index f2702ec35..2c61b50f5 100644 --- a/Assistant/Threads/Watcher.hs +++ b/Assistant/Threads/Watcher.hs @@ -59,7 +59,7 @@ needLsof = error $ unlines ] watchThread :: NamedThread -watchThread = NamedThread "Watcher" $ do +watchThread = namedThread "Watcher" $ do startup <- asIO1 startupScan direct <- liftAnnex isDirect addhook <- hook $ if direct then onAddDirect else onAdd diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index c4c9fa87a..e2eed4588 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -38,9 +38,6 @@ import Yesod.Static import Network.Socket (SockAddr) import Data.Text (pack, unpack) -thisThread :: String -thisThread = "WebApp" - mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") type Url = String @@ -76,7 +73,7 @@ webAppThread assistantdata urlrenderer noannex postfirstrun onstartup = thread $ urlfile <- runThreadState st $ fromRepo gitAnnexUrlFile go addr webapp htmlshim (Just urlfile) where - thread = NamedThread thisThread + thread = namedThread "WebApp" getreldir | noannex = return Nothing | otherwise = Just <$> diff --git a/Assistant/Threads/XMPPClient.hs b/Assistant/Threads/XMPPClient.hs index 99b46dabb..ebface796 100644 --- a/Assistant/Threads/XMPPClient.hs +++ b/Assistant/Threads/XMPPClient.hs @@ -34,7 +34,7 @@ import qualified Git.Branch import Data.Time.Clock xmppClientThread :: UrlRenderer -> NamedThread -xmppClientThread urlrenderer = NamedThread "XMPPClient" $ +xmppClientThread urlrenderer = namedThread "XMPPClient" $ restartableClient . xmppClient urlrenderer =<< getAssistant id {- Runs the client, handing restart events. -} diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 6c949c8f4..b60d49edf 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -14,6 +14,7 @@ import Assistant.Alert import Assistant.Pairing import Utility.NotificationBroadcaster import Logs.Transfer +import Assistant.Types.ThreadName import Control.Concurrent.STM import Control.Concurrent.Async @@ -21,8 +22,9 @@ 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 ()) + -- All the named threads that comprise the daemon, + -- and actions to run to restart them. + { startedThreads :: M.Map ThreadName (Async (), IO ()) -- False when the daemon is performing its startup scan , scanComplete :: Bool -- Time when a previous process of the daemon was running ok diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs new file mode 100644 index 000000000..0e884637a --- /dev/null +++ b/Assistant/Types/NamedThread.hs @@ -0,0 +1,17 @@ +{- named threads + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.NamedThread where + +import Assistant.Monad +import Assistant.Types.ThreadName + +{- Information about a named thread that can be run. -} +data NamedThread = NamedThread ThreadName (Assistant ()) + +namedThread :: String -> Assistant () -> NamedThread +namedThread name a = NamedThread (ThreadName name) a diff --git a/Assistant/Types/ThreadName.hs b/Assistant/Types/ThreadName.hs new file mode 100644 index 000000000..c8d264a38 --- /dev/null +++ b/Assistant/Types/ThreadName.hs @@ -0,0 +1,14 @@ +{- name of a thread + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Assistant.Types.ThreadName where + +newtype ThreadName = ThreadName String + deriving (Eq, Read, Show, Ord) + +fromThreadName :: ThreadName -> String +fromThreadName (ThreadName n) = n diff --git a/Command/WebApp.hs b/Command/WebApp.hs index b9d6159b7..274a00c93 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -110,7 +110,7 @@ firstRun = do v <- newEmptyMVar let callback a = Just $ a v runAssistant d $ do - startNamedThread $ + startNamedThread (Just urlrenderer) $ webAppThread d urlrenderer True (callback signaler) (callback mainthread) diff --git a/debian/changelog b/debian/changelog index 5ab0df93f..0570d15a6 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +git-annex (3.20130125) UNRELEASED; urgency=low + + * webapp: Now allows restarting any threads that crash. + + -- Joey Hess <joeyh@debian.org> Sat, 26 Jan 2013 15:48:40 +1100 + git-annex (3.20130124) unstable; urgency=low * Added source repository group, that only retains files until they've diff --git a/git-annex.cabal b/git-annex.cabal index 7b3d8a7c4..06c612722 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -1,5 +1,5 @@ Name: git-annex -Version: 3.20130124 +Version: 3.20130125 Cabal-Version: >= 1.8 License: GPL Maintainer: Joey Hess <joey@kitenet.net> |