diff options
| -rw-r--r-- | Assistant.hs | 16 | ||||
| -rw-r--r-- | Assistant/Common.hs | 1 | ||||
| -rw-r--r-- | Assistant/Monad.hs | 20 | ||||
| -rw-r--r-- | Assistant/NamedThread.hs | 43 | ||||
| -rw-r--r-- | Assistant/Threads/ConfigMonitor.hs | 3 | ||||
| -rw-r--r-- | Assistant/Types/DaemonStatus.hs | 8 | ||||
| -rw-r--r-- | Assistant/Types/NamedThread.hs | 32 | ||||
| -rw-r--r-- | Command/WebApp.hs | 10 | ||||
| -rw-r--r-- | debian/control | 1 | ||||
| -rw-r--r-- | doc/install/fromscratch.mdwn | 1 | ||||
| -rw-r--r-- | git-annex.cabal | 3 |
11 files changed, 77 insertions, 61 deletions
diff --git a/Assistant.hs b/Assistant.hs index 06f8d64e5..d1a9f7102 100644 --- a/Assistant.hs +++ b/Assistant.hs @@ -154,11 +154,6 @@ import Assistant.Threads.XMPPClient import Assistant.Environment import qualified Utility.Daemon import Utility.LogFile -import Utility.ThreadScheduler - -import Control.Concurrent - -type NamedThread = IO () -> IO (String, IO ()) stopDaemon :: Annex () stopDaemon = liftIO . Utility.Daemon.stopDaemon =<< fromRepo gitAnnexPidFile @@ -197,11 +192,11 @@ startDaemon assistant foreground startbrowser = do =<< newAssistantData st dstatus go webappwaiter = do - d <- getAssistant id #ifdef WITH_WEBAPP + d <- getAssistant id urlrenderer <- liftIO newUrlRenderer #endif - mapM_ (startthread d) + mapM_ startthread [ watch $ commitThread #ifdef WITH_WEBAPP , assist $ webAppThread d urlrenderer False Nothing webappwaiter @@ -229,11 +224,10 @@ startDaemon assistant foreground startbrowser = do , watch $ watchThread ] - liftIO waitForTermination + waitNamedThreads watch a = (True, a) assist a = (False, a) - startthread d (watcher, t) - | watcher || assistant = void $ liftIO $ forkIO $ - runAssistant d $ runNamedThread t + startthread (watcher, t) + | watcher || assistant = startNamedThread t | otherwise = noop diff --git a/Assistant/Common.hs b/Assistant/Common.hs index 0be536250..0c97bd1f7 100644 --- a/Assistant/Common.hs +++ b/Assistant/Common.hs @@ -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 diff --git a/Assistant/Monad.hs b/Assistant/Monad.hs index a676bc8fb..3b1eb86ec 100644 --- a/Assistant/Monad.hs +++ b/Assistant/Monad.hs @@ -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 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 + diff --git a/Assistant/Threads/ConfigMonitor.hs b/Assistant/Threads/ConfigMonitor.hs index 47e197116..afa94f97f 100644 --- a/Assistant/Threads/ConfigMonitor.hs +++ b/Assistant/Threads/ConfigMonitor.hs @@ -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. - diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs index 7f868d957..6c949c8f4 100644 --- a/Assistant/Types/DaemonStatus.hs +++ b/Assistant/Types/DaemonStatus.hs @@ -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 diff --git a/Assistant/Types/NamedThread.hs b/Assistant/Types/NamedThread.hs deleted file mode 100644 index 0e122c097..000000000 --- a/Assistant/Types/NamedThread.hs +++ /dev/null @@ -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 diff --git a/Command/WebApp.hs b/Command/WebApp.hs index 20a2ecdbe..b9d6159b7 100644 --- a/Command/WebApp.hs +++ b/Command/WebApp.hs @@ -109,10 +109,12 @@ firstRun = do urlrenderer <- newUrlRenderer v <- newEmptyMVar let callback a = Just $ a v - void $ runAssistant d $ runNamedThread $ - webAppThread d urlrenderer True - (callback signaler) - (callback mainthread) + runAssistant d $ do + startNamedThread $ + webAppThread d urlrenderer True + (callback signaler) + (callback mainthread) + waitNamedThreads where signaler v = do putMVar v "" diff --git a/debian/control b/debian/control index ca055906f..b88f62f8c 100644 --- a/debian/control +++ b/debian/control @@ -44,6 +44,7 @@ Build-Depends: libghc-network-protocol-xmpp-dev (>= 0.4.3-1+b1), libghc-gnutls-dev (>= 0.1.4), libghc-xml-types-dev, + libghc-async-dev, ikiwiki, perlmagick, git, diff --git a/doc/install/fromscratch.mdwn b/doc/install/fromscratch.mdwn index 1aebc68a2..a5c402c24 100644 --- a/doc/install/fromscratch.mdwn +++ b/doc/install/fromscratch.mdwn @@ -46,6 +46,7 @@ quite a lot. * [network-protocol-xmpp](http://hackage.haskell.org/package/network-protocol-xmpp) * [dns](http://hackage.haskell.org/package/dns) * [xml-types](http://hackage.haskell.org/package/xml-types) + * [async](http://hackage.haskell.org/package/async) * Shell commands * [git](http://git-scm.com/) * [uuid](http://www.ossp.org/pkg/lib/uuid/) diff --git a/git-annex.cabal b/git-annex.cabal index 2ff3fb970..7b3d8a7c4 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -75,6 +75,9 @@ Executable git-annex if flag(WebDAV) Build-Depends: DAV (>= 0.3), http-conduit, xml-conduit, http-types CPP-Options: -DWITH_WEBDAV + + if flag(Assistant) + Build-Depends: async if flag(Assistant) && ! os(windows) && ! os(solaris) Build-Depends: stm >= 2.3 |