git-annex/Assistant/WebApp/Page.hs

{- git-annex assistant webapp page display
 -
 - Copyright 2012 Joey Hess <id@joeyh.name>
 -
 - Licensed under the GNU AGPL version 3 or higher.
 -}

{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}

module Assistant.WebApp.Page where

import Assistant.Common
import Assistant.WebApp
import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod

import qualified Text.Hamlet as Hamlet
import Data.Text (Text)

data NavBarItem = DashBoard | Configuration | About
	deriving (Eq, Ord, Enum, Bounded)

navBarName :: NavBarItem -> Text
navBarName DashBoard = "Dashboard"
navBarName Configuration = "Configuration"
navBarName About = "About"

navBarRoute :: NavBarItem -> Route WebApp
navBarRoute DashBoard = DashboardR
navBarRoute Configuration = ConfigurationR
navBarRoute About = AboutR

defaultNavBar :: [NavBarItem]
defaultNavBar = [minBound .. maxBound]

firstRunNavBar :: [NavBarItem]
firstRunNavBar = [Configuration, About]

selectNavBar :: Handler [NavBarItem]
selectNavBar = ifM inFirstRun (return firstRunNavBar, return defaultNavBar)

{- A standard page of the webapp, with a title, a sidebar, and that may
 - be highlighted on the navbar. -}
page :: Hamlet.Html -> Maybe NavBarItem -> Widget -> Handler Html
page title navbaritem content = customPage navbaritem $ do
	setTitle title
	content
	sideBarDisplay

{- A custom page, with no title or sidebar set. -}
customPage :: Maybe NavBarItem -> Widget -> Handler Html
customPage = customPage' True

customPage' :: Bool -> Maybe NavBarItem -> Widget -> Handler Html
customPage' with_longpolling navbaritem content = do
	webapp <- getYesod
	case cannotRun webapp of
		Nothing -> do
			navbar <- map navdetails <$> selectNavBar
			pageinfo <- widgetToPageContent $ do
				addStylesheet $ StaticR css_bootstrap_css
				addStylesheet $ StaticR css_bootstrap_theme_css
				addScript $ StaticR js_jquery_full_js
				addScript $ StaticR js_bootstrap_js
				when with_longpolling $
					addScript $ StaticR js_longpolling_js
				$(widgetFile "page")
			withUrlRenderer $(Hamlet.hamletFile $ hamletTemplate "bootstrap")
		Just msg -> error msg
  where
	navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)

controlMenu :: Widget
controlMenu = $(widgetFile "controlmenu")