cd544e548b
giveup changed to filter out control characters. (It is too low level to make it use StringContainingQuotedPath.) error still does not, but it should only be used for internal errors, where the message is not attacker-controlled. Changed a lot of existing error to giveup when it is not strictly an internal error. Of course, other exceptions can still be thrown, either by code in git-annex, or a library, that include some attacker-controlled value. This does not guard against those. Sponsored-by: Noam Kremen on Patreon
75 lines
2.3 KiB
Haskell
75 lines
2.3 KiB
Haskell
{- 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 -> giveup msg
|
|
where
|
|
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
|
|
|
|
controlMenu :: Widget
|
|
controlMenu = $(widgetFile "controlmenu")
|