blob: 5d60731bfe6cbac6e912360993421619df11a7cd (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
{- git-annex assistant webapp control
-
- Copyright 2012, 2013 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
module Assistant.WebApp.Control where
import Assistant.WebApp.Common
import Assistant.DaemonStatus
import Assistant.Alert
import Assistant.TransferSlots
import Assistant.Restart
import Utility.LogFile
import Utility.NotificationBroadcaster
import Control.Concurrent
import qualified Data.Map as M
import qualified Data.Text as T
getShutdownR :: Handler Html
getShutdownR = page "Shutdown" Nothing $
$(widgetFile "control/shutdown")
getShutdownConfirmedR :: Handler Html
getShutdownConfirmedR = do
liftAssistant $ do
{- Remove all alerts for currently running activities. -}
updateAlertMap $ M.filter $ \a -> alertClass a /= Activity
void $ addAlert shutdownAlert
{- Stop transfers the assistant is running,
- otherwise they would continue past shutdown.
- Pausing transfers prevents more being started up (and stops
- the transfer processes). -}
ts <- M.keys . currentTransfers <$> getDaemonStatus
mapM_ pauseTransfer ts
webapp <- getYesod
let url = T.unpack $ yesodRender webapp (T.pack "") NotRunningR []
{- Signal any other web browsers. -}
liftAssistant $ do
modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
{- Wait 2 seconds before shutting down, to give the web
- page time to load in the browser. -}
void $ liftIO $ forkIO $ do
threadDelay 2000000
terminateSelf
redirect NotRunningR
{- Use a custom page to avoid putting long polling elements on it that will
- fail and cause thet web browser to show an error once the webapp is
- truly stopped. -}
getNotRunningR :: Handler Html
getNotRunningR = customPage' False Nothing $
$(widgetFile "control/notrunning")
getRestartR :: Handler Html
getRestartR = do
liftAssistant prepRestart
url <- liftAssistant runRestart
liftAssistant $ postRestart url
redirect url
getRestartThreadR :: ThreadName -> Handler ()
getRestartThreadR name = do
m <- liftAssistant $ startedThreads <$> getDaemonStatus
liftIO $ maybe noop snd $ M.lookup name m
redirectBack
getLogR :: Handler Html
getLogR = page "Logs" Nothing $ do
logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
logs <- liftIO $ listLogs (fromRawFilePath logfile)
logcontent <- liftIO $ concat <$> mapM readFile logs
$(widgetFile "control/log")
|
