summaryrefslogtreecommitdiff
path: root/Assistant
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2013-01-26 17:09:33 +1100
committerGravatar Joey Hess <joey@kitenet.net>2013-01-26 17:09:33 +1100
commitdc60216eb8fe919acf7ab3984a5f0bf0e0193f6b (patch)
tree7fb8c8bd0189f1868e732fc1c6047df933333ecf /Assistant
parentf0f97334d017eac6d1693bac90c772022fa57aa7 (diff)
webapp: Now allows restarting any threads that crash.
Diffstat (limited to 'Assistant')
-rw-r--r--Assistant/Common.hs1
-rw-r--r--Assistant/Monad.hs12
-rw-r--r--Assistant/NamedThread.hs50
-rw-r--r--Assistant/Threads/Committer.hs2
-rw-r--r--Assistant/Threads/ConfigMonitor.hs2
-rw-r--r--Assistant/Threads/DaemonStatus.hs2
-rw-r--r--Assistant/Threads/Glacier.hs2
-rw-r--r--Assistant/Threads/Merger.hs5
-rw-r--r--Assistant/Threads/MountWatcher.hs5
-rw-r--r--Assistant/Threads/NetWatcher.hs4
-rw-r--r--Assistant/Threads/PairListener.hs5
-rw-r--r--Assistant/Threads/Pusher.hs7
-rw-r--r--Assistant/Threads/SanityChecker.hs2
-rw-r--r--Assistant/Threads/TransferPoller.hs2
-rw-r--r--Assistant/Threads/TransferScanner.hs2
-rw-r--r--Assistant/Threads/TransferWatcher.hs2
-rw-r--r--Assistant/Threads/Transferrer.hs2
-rw-r--r--Assistant/Threads/Watcher.hs2
-rw-r--r--Assistant/Threads/WebApp.hs5
-rw-r--r--Assistant/Threads/XMPPClient.hs2
-rw-r--r--Assistant/Types/DaemonStatus.hs6
-rw-r--r--Assistant/Types/NamedThread.hs17
-rw-r--r--Assistant/Types/ThreadName.hs14
23 files changed, 98 insertions, 55 deletions
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