From 58dfa3fa5b1b8be6f344e9ef5bfb3adda11069ab Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Tue, 31 Jul 2012 01:11:32 -0400 Subject: split up webapp files --- Assistant/Threads/WebApp.hs | 304 +------------------------------------------- 1 file changed, 7 insertions(+), 297 deletions(-) (limited to 'Assistant/Threads/WebApp.hs') diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs index 79a388463..7b794b6eb 100644 --- a/Assistant/Threads/WebApp.hs +++ b/Assistant/Threads/WebApp.hs @@ -11,321 +11,31 @@ module Assistant.Threads.WebApp where import Assistant.Common +import Assistant.WebApp +import Assistant.WebApp.DashBoard +import Assistant.WebApp.SideBar +import Assistant.WebApp.Notifications +import Assistant.WebApp.Configurators import Assistant.ThreadedMonad import Assistant.DaemonStatus import Assistant.TransferQueue -import Assistant.Alert hiding (Widget) -import Utility.NotificationBroadcaster import Utility.WebApp import Utility.Yesod import Utility.FileMode import Utility.TempFile import Git -import Logs.Transfer -import Utility.Percentage -import Utility.DataUnits -import Types.Key -import qualified Remote -import Logs.Web (webUUID) -import Logs.Trust -import Annex.UUID (getUUID) import Yesod import Yesod.Static import Text.Hamlet import Network.Socket (PortNumber) import Text.Blaze.Renderer.String -import Data.Text (Text, pack, unpack) -import qualified Data.Text as T -import qualified Data.Map as M -import Control.Concurrent.STM +import Data.Text (pack, unpack) thisThread :: String thisThread = "WebApp" -data WebApp = WebApp - { threadState :: ThreadState - , daemonStatus :: DaemonStatusHandle - , transferQueue :: TransferQueue - , secretToken :: Text - , relDir :: FilePath - , getStatic :: Static - , webAppState :: TMVar WebAppState - } - -data WebAppState = WebAppState - { showIntro :: Bool - } - -newWebAppState :: IO (TMVar WebAppState) -newWebAppState = liftIO $ atomically $ - newTMVar $ WebAppState { showIntro = True } - -getWebAppState :: forall sub. GHandler sub WebApp WebAppState -getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod - -modifyWebAppState :: forall sub. (WebAppState -> WebAppState) -> GHandler sub WebApp () -modifyWebAppState a = go =<< webAppState <$> getYesod - where - go s = liftIO $ atomically $ do - v <- takeTMVar s - putTMVar s $ a v - -waitNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> NotificationId -> GHandler sub WebApp () -waitNotifier selector nid = do - notifier <- getNotifier selector - liftIO $ waitNotification $ notificationHandleFromId notifier nid - -newNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationId -newNotifier selector = do - notifier <- getNotifier selector - liftIO $ notificationHandleToId <$> newNotificationHandle notifier - -getNotifier :: forall sub. (DaemonStatus -> NotificationBroadcaster) -> GHandler sub WebApp NotificationBroadcaster -getNotifier selector = do - webapp <- getYesod - liftIO $ selector <$> getDaemonStatus (daemonStatus webapp) - -staticFiles "static" - -mkYesod "WebApp" [parseRoutes| -/ HomeR GET -/noscript NoScriptR GET -/noscriptauto NoScriptAutoR GET -/transfers/#NotificationId TransfersR GET -/sidebar/#NotificationId SideBarR GET -/notifier/transfers NotifierTransfersR GET -/notifier/sidebar NotifierSideBarR GET -/closealert/#AlertId CloseAlert GET -/config ConfigR GET -/addrepository AddRepositoryR GET -/static StaticR Static getStatic -|] - -instance PathPiece NotificationId where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance PathPiece AlertId where - toPathPiece = pack . show - fromPathPiece = readish . unpack - -instance Yesod WebApp where - defaultLayout content = do - webapp <- getYesod - page <- widgetToPageContent $ do - addStylesheet $ StaticR css_bootstrap_css - addStylesheet $ StaticR css_bootstrap_responsive_css - addScript $ StaticR jquery_full_js - addScript $ StaticR js_bootstrap_dropdown_js - addScript $ StaticR js_bootstrap_modal_js - $(widgetFile "page") - hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap") - - {- Require an auth token be set when accessing any (non-static route) -} - isAuthorized _ _ = checkAuthToken secretToken - - {- Add the auth token to every url generated, except static subsite - - urls (which can show up in Permission Denied pages). -} - joinPath = insertAuthToken secretToken excludeStatic - where - excludeStatic [] = True - excludeStatic (p:_) = p /= "static" - - makeSessionBackend = webAppSessionBackend - jsLoader _ = BottomOfHeadBlocking - -{- Add to any widget to make it auto-update using long polling. - - - - The widget should have a html element with an id=ident, which will be - - replaced when it's updated. - - - - The geturl route should return the notifier url to use for polling. - - - - ms_delay is how long to delay between AJAX updates - - ms_startdelay is how long to delay before updating with AJAX at the start - -} -autoUpdate :: Text -> Route WebApp -> Int -> Int -> Widget -autoUpdate ident geturl ms_delay ms_startdelay = do - let delay = show ms_delay - let startdelay = show ms_startdelay - addScript $ StaticR longpolling_js - $(widgetFile "longpolling") - -{- Notifier urls are requested by the javascript, to avoid allocation - - of NotificationIds when noscript pages are loaded. This constructs a - - notifier url for a given Route and NotificationBroadcaster. - -} -notifierUrl :: (NotificationId -> Route WebApp) -> (DaemonStatus -> NotificationBroadcaster) -> Handler RepPlain -notifierUrl route selector = do - (urlbits, _params) <- renderRoute . route <$> newNotifier selector - webapp <- getYesod - return $ RepPlain $ toContent $ T.concat - [ "/" - , T.intercalate "/" urlbits - , "?auth=" - , secretToken webapp - ] - -getNotifierTransfersR :: Handler RepPlain -getNotifierTransfersR = notifierUrl TransfersR transferNotifier - -getNotifierSideBarR :: Handler RepPlain -getNotifierSideBarR = notifierUrl SideBarR alertNotifier - -{- A display of currently running and queued transfers. - - - - Or, if there have never been any this run, an intro display. -} -transfersDisplay :: Bool -> Widget -transfersDisplay warnNoScript = do - webapp <- lift getYesod - current <- liftIO $ runThreadState (threadState webapp) $ - M.toList . currentTransfers - <$> liftIO (getDaemonStatus $ daemonStatus webapp) - queued <- liftIO $ getTransferQueue $ transferQueue webapp - let ident = "transfers" - autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int) - let transfers = current ++ queued - if null transfers - then ifM (lift $ showIntro <$> getWebAppState) - ( introDisplay ident - , $(widgetFile "transfers") - ) - else $(widgetFile "transfers") - -{- An intro message, and list of repositories. -} -introDisplay :: Text -> Widget -introDisplay ident = do - webapp <- lift getYesod - let reldir = relDir webapp - l <- liftIO $ runThreadState (threadState webapp) $ do - u <- getUUID - rs <- map Remote.uuid <$> Remote.remoteList - rs' <- snd <$> trustPartition DeadTrusted rs - Remote.prettyListUUIDs $ filter (/= webUUID) $ nub $ u:rs' - let remotelist = zip counter l - let n = length l - let numrepos = show n - let notenough = n < 2 - let barelyenough = n == 2 - let morethanenough = n > 2 - $(widgetFile "intro") - lift $ modifyWebAppState $ \s -> s { showIntro = False } - where - counter = map show ([1..] :: [Int]) - -{- Called by client to get a display of currently in process transfers. - - - - Returns a div, which will be inserted into the calling page. - - - - Note that the head of the widget is not included, only its - - body is. To get the widget head content, the widget is also - - inserted onto the getHomeR page. - -} -getTransfersR :: NotificationId -> Handler RepHtml -getTransfersR nid = do - waitNotifier transferNotifier nid - - page <- widgetToPageContent $ transfersDisplay False - hamletToRepHtml $ [hamlet|^{pageBody page}|] - -sideBarDisplay :: Widget -sideBarDisplay = do - let content = do - {- Any yesod message appears as the first alert. -} - maybe noop rendermessage =<< lift getMessage - - {- Add newest alerts to the sidebar. -} - webapp <- lift getYesod - alertpairs <- M.toList . alertMap - <$> liftIO (getDaemonStatus $ daemonStatus webapp) - mapM_ renderalert $ - take displayAlerts $ reverse $ sortAlertPairs alertpairs - let ident = "sidebar" - $(widgetFile "sidebar") - autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int) - where - bootstrapclass Activity = "alert-info" - bootstrapclass Warning = "alert" - bootstrapclass Error = "alert-error" - bootstrapclass Success = "alert-success" - bootstrapclass Message = "alert-info" - - renderalert (alertid, alert) = addalert - alertid - (alertClosable alert) - (alertBlockDisplay alert) - (bootstrapclass $ alertClass alert) - (alertHeader alert) - $ case alertMessage alert of - StringAlert s -> [whamlet|#{s}|] - WidgetAlert w -> w alert - - rendermessage msg = addalert firstAlertId True False - "alert-info" Nothing [whamlet|#{msg}|] - - addalert :: AlertId -> Bool -> Bool -> Text -> Maybe String -> Widget -> Widget - addalert i closable block divclass heading widget = do - let alertid = show i - let closealert = CloseAlert i - $(widgetFile "alert") - -{- Called by client to get a sidebar display. - - - - Returns a div, which will be inserted into the calling page. - - - - Note that the head of the widget is not included, only its - - body is. To get the widget head content, the widget is also - - inserted onto all pages. - -} -getSideBarR :: NotificationId -> Handler RepHtml -getSideBarR nid = do - waitNotifier alertNotifier nid - - page <- widgetToPageContent sideBarDisplay - hamletToRepHtml $ [hamlet|^{pageBody page}|] - -{- Called by the client to close an alert. -} -getCloseAlert :: AlertId -> Handler () -getCloseAlert i = do - webapp <- getYesod - void $ liftIO $ removeAlert (daemonStatus webapp) i - -{- The main dashboard. -} -dashboard :: Bool -> Widget -dashboard warnNoScript = do - sideBarDisplay - let content = transfersDisplay warnNoScript - $(widgetFile "dashboard") - -getHomeR :: Handler RepHtml -getHomeR = defaultLayout $ dashboard True - -{- Same as HomeR, except with autorefreshing via meta refresh. -} -getNoScriptAutoR :: Handler RepHtml -getNoScriptAutoR = defaultLayout $ do - let ident = NoScriptR - let delayseconds = 3 :: Int - let this = NoScriptAutoR - toWidgetHead $(hamletFile $ hamletTemplate "metarefresh") - dashboard False - -{- Same as HomeR, except no autorefresh at all (and no noscript warning). -} -getNoScriptR :: Handler RepHtml -getNoScriptR = defaultLayout $ - dashboard False - -getConfigR :: Handler RepHtml -getConfigR = defaultLayout $ do - sideBarDisplay - setTitle "Configuration" - [whamlet|main|] - -getAddRepositoryR :: Handler RepHtml -getAddRepositoryR = defaultLayout $ do - sideBarDisplay - setTitle "Add repository" - [whamlet|main|] +mkYesodDispatch "WebApp" $(parseRoutesFile "Assistant/WebApp/routes") webAppThread :: ThreadState -> DaemonStatusHandle -> TransferQueue -> Maybe (IO ()) -> IO () webAppThread st dstatus transferqueue onstartup = do -- cgit v1.2.3