2013-01-03 19:16:40 +00:00
|
|
|
{- git-annex assistant webapp control
|
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2012, 2013 Joey Hess <id@joeyh.name>
|
2013-01-03 19:16:40 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
2014-09-16 17:37:50 +00:00
|
|
|
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
|
2013-01-03 19:16:40 +00:00
|
|
|
|
|
|
|
module Assistant.WebApp.Control where
|
|
|
|
|
|
|
|
import Assistant.WebApp.Common
|
2013-01-26 06:09:33 +00:00
|
|
|
import Assistant.DaemonStatus
|
2013-04-10 21:52:04 +00:00
|
|
|
import Assistant.Alert
|
2013-10-26 20:54:49 +00:00
|
|
|
import Assistant.TransferSlots
|
2013-11-23 19:50:17 +00:00
|
|
|
import Assistant.Restart
|
2013-11-23 20:21:09 +00:00
|
|
|
import Utility.LogFile
|
|
|
|
import Utility.NotificationBroadcaster
|
2013-01-03 19:16:40 +00:00
|
|
|
|
|
|
|
import Control.Concurrent
|
2013-12-11 04:15:10 +00:00
|
|
|
import qualified Data.Map as M
|
|
|
|
import qualified Data.Text as T
|
2013-01-03 19:16:40 +00:00
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
getShutdownR :: Handler Html
|
2013-01-03 19:16:40 +00:00
|
|
|
getShutdownR = page "Shutdown" Nothing $
|
|
|
|
$(widgetFile "control/shutdown")
|
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
getShutdownConfirmedR :: Handler Html
|
2013-04-10 21:38:53 +00:00
|
|
|
getShutdownConfirmedR = do
|
2013-04-10 21:52:04 +00:00
|
|
|
liftAssistant $ do
|
2013-10-26 20:54:49 +00:00
|
|
|
{- Remove all alerts for currently running activities. -}
|
2013-04-10 21:52:04 +00:00
|
|
|
updateAlertMap $ M.filter $ \a -> alertClass a /= Activity
|
|
|
|
void $ addAlert shutdownAlert
|
2013-10-26 20:54:49 +00:00
|
|
|
{- 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
|
2013-11-25 18:33:14 +00:00
|
|
|
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
|
2014-09-15 18:45:37 +00:00
|
|
|
terminateSelf
|
2013-11-25 18:33:14 +00:00
|
|
|
redirect NotRunningR
|
2013-11-23 20:21:09 +00:00
|
|
|
|
|
|
|
{- Use a custom page to avoid putting long polling elements on it that will
|
2014-09-15 18:45:37 +00:00
|
|
|
- fail and cause thet web browser to show an error once the webapp is
|
2013-11-23 20:21:09 +00:00
|
|
|
- truely stopped. -}
|
|
|
|
getNotRunningR :: Handler Html
|
|
|
|
getNotRunningR = customPage' False Nothing $
|
|
|
|
$(widgetFile "control/notrunning")
|
2013-01-03 22:50:30 +00:00
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
getRestartR :: Handler Html
|
2013-11-23 19:50:17 +00:00
|
|
|
getRestartR = do
|
|
|
|
liftAssistant prepRestart
|
|
|
|
url <- liftAssistant runRestart
|
|
|
|
liftAssistant $ postRestart url
|
|
|
|
redirect url
|
2013-01-15 17:52:35 +00:00
|
|
|
|
2013-01-26 06:09:33 +00:00
|
|
|
getRestartThreadR :: ThreadName -> Handler ()
|
|
|
|
getRestartThreadR name = do
|
|
|
|
m <- liftAssistant $ startedThreads <$> getDaemonStatus
|
|
|
|
liftIO $ maybe noop snd $ M.lookup name m
|
|
|
|
redirectBack
|
|
|
|
|
2013-06-27 05:15:28 +00:00
|
|
|
getLogR :: Handler Html
|
2013-01-15 17:52:35 +00:00
|
|
|
getLogR = page "Logs" Nothing $ do
|
2020-10-20 19:06:55 +00:00
|
|
|
logfile <- liftAnnex $ fromRepo gitAnnexDaemonLogFile
|
2013-01-15 17:52:35 +00:00
|
|
|
logs <- liftIO $ listLogs logfile
|
2016-12-24 18:46:31 +00:00
|
|
|
logcontent <- liftIO $ concat <$> mapM readFile logs
|
2013-01-15 17:52:35 +00:00
|
|
|
$(widgetFile "control/log")
|