{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}
module Lucid.Rdash (
indexPage
, mkAlert
, mkAlerts
, mkHead
, mkHeaderBar
, mkIndexPage
, mkMetaBox
, mkMetaTitle
, mkPageContent
, mkPageWrapperOpen
, mkSidebar
, mkSidebarFooter
, mkSidebarWrapper
, mkWidget
, mkWidgets
, mkWidgetContent
, mkWidgetIcon
, sidebarMain
, sidebarTitle
, widget_
, widgetBody_
, spacer_
, rdashCSS
, SidebarItem(..)
) where
import Control.Applicative ((<$>))
import qualified Data.Text as T
import Data.List
import Lucid.Bootstrap3
import Lucid hiding (toHtml)
import qualified Lucid (toHtml)
import Data.Monoid ((<>), mempty)
toHtml :: Monad m => T.Text -> HtmlT m ()
toHtml = Lucid.toHtml
rdashCSS, sidebarMain, sidebarTitle :: Monad m => HtmlT m ()
rdashCSS = link_ [rel_ "stylesheet",
href_ "https://cdn.diffusionkinetics.com/rdash-ui/1.0.1/css/rdash.css"]
ariaHidden, tooltip_ :: Term arg result => arg -> result
ariaHidden = term "aria-hidden"
tooltip_ = term "tooltip"
fa_ :: Monad m => T.Text -> HtmlT m ()
fa_ x = i_ [class_ $ T.unwords ["fas", x]] (return ())
aHash_ :: Monad m => HtmlT m () -> HtmlT m ()
aHash_ = a_ [href_ "#"]
sidebarTitle = span_ "NAVIGATION"
sidebarMain = a_ [href_ "#"] $ do
"Dashboard"
span_ [class_ "menu-icon glyphicon glyphicon-transfer"] (return ())
mkPageWrapperOpen :: (Monad m) => HtmlT m () -> HtmlT m () -> HtmlT m ()
mkPageWrapperOpen sbw cw = div_ [id_ "page-wrapper", class_ "open"] $ sbw >> cw
mkSidebarWrapper :: (Monad m) => HtmlT m () -> HtmlT m () -> HtmlT m ()
mkSidebarWrapper sb sbf = div_ [id_ "sidebar-wrapper"] $ sb >> sbf
data SidebarItem = SidebarTitle T.Text
| SidebarLink
{ itemText :: T.Text
, linkUrl :: T.Text
, iconName :: T.Text
}
mkSidebar :: forall m. (Monad m) => HtmlT m () -> [SidebarItem] -> HtmlT m ()
mkSidebar sbm sbl = ul_ [class_ "sidebar"] $ do
li_ [class_ "sidebar-main",
id_ "toggle-sidebar",
onclick_ "$('#page-wrapper').toggleClass('open');"] sbm
let render :: SidebarItem -> HtmlT m ()
render (SidebarTitle sbt)
= li_ [class_ "sidebar-title"] $ span_ $ toHtml sbt
render (SidebarLink t dest fa)
= li_ [class_ "sidebar-list"]
$ a_ [href_ dest]
$ toHtml t <> i_ [class_ (fa<>" menu-icon")] mempty
mapM_ render sbl
mkSidebarFooter :: (Monad m) => HtmlT m () -> HtmlT m ()
mkSidebarFooter footerItems = div_ [class_ "sidebar-footer"] footerItems
mkHead :: (Monad m) => T.Text -> HtmlT m ()
mkHead title = head_ $ do
meta_ [charset_ "UTF-8"]
meta_ [name_ "viewport", content_ "width=device-width"]
title_ (toHtml title)
cdnFontAwesome
cdnCSS
rdashCSS
cdnJqueryJS
cdnBootstrapJS
mkPageContent :: Monad m => HtmlT m () -> HtmlT m ()
mkPageContent = div_ [id_ "content-wrapper"] . div_ [class_ "page-content"]
mkHeaderBar :: Monad m => [HtmlT m ()] -> HtmlT m ()
mkHeaderBar cols = div_ [class_ "row header"] (rowEven XS cols)
mkUserBox :: Monad m => [HtmlT m ()] -> HtmlT m ()
mkUserBox xs = div_ [class_ "user pull-right"] $ sequence_ xs
mkItemDropdown :: Monad m => T.Text -> HtmlT m () -> HtmlT m ()
mkItemDropdown icon x = div_ [class_ "item dropdown"] $ do
a_ [ class_ "dropdown-toggle"
, term "data-toggle" $ "dropdown"
, href_ "#"] (i_ [class_ icon, ariaHidden "true"] (return ()))
x
mkDropdownMenu :: Monad m => HtmlT m () -> [[HtmlT m ()]] -> HtmlT m ()
mkDropdownMenu hdr xs = ul_ [class_ "dropdown-menu dropdown-menu-right"] $ sequence_ dividedItems
where
mkLi = li_ . (a_ [href_ "#"])
items = map (map mkLi) xs
dividedItems = (li_ [class_ "dropdown-header"] hdr) : li_ [class_ "divider"] (return ()) :
(concat $ intersperse [li_ [class_ "divider"] (return ())] items)
mkIndexPage :: (Monad m) => HtmlT m () -> HtmlT m () -> HtmlT m ()
mkIndexPage hd body = html_ [lang_ "en"] $ hd >> body
mkMetaTitle :: Monad m => HtmlT m () -> HtmlT m ()
mkMetaTitle = div_ [class_ "page"]
mkMetaBreadcrumbLinks :: Monad m => HtmlT m () -> HtmlT m ()
mkMetaBreadcrumbLinks = div_ [class_ "breadcrumb-links"]
mkMetaBox :: Monad m => [HtmlT m ()] -> HtmlT m ()
mkMetaBox = div_ [class_ "meta pull-left"] . sequence_
mkAlerts :: Monad m => [HtmlT m ()] -> HtmlT m ()
mkAlerts l = mkCol [(XS, 12)] (sequence_ l)
mkAlert :: Monad m => T.Text -> HtmlT m () -> HtmlT m ()
mkAlert alertType = div_ [class_ $ T.unwords ["alert", alertType]]
mkWidgetIcon :: Monad m => T.Text -> T.Text -> HtmlT m ()
mkWidgetIcon color icon =
div_ [class_$ T.unwords ["widget-icon pull-left", color]] $ i_ [class_ icon] (return ())
mkWidgetContent :: Monad m => HtmlT m () -> HtmlT m () -> HtmlT m ()
mkWidgetContent title comment =
div_ [class_ "widget-content pull-left"] $ do
div_ [class_ "title"] title
div_ [class_ "comment"] comment
mkWidget :: Monad m => HtmlT m () -> HtmlT m () -> HtmlT m ()
mkWidget wIcon wContent =
widget_ $
widgetBody_ $
wIcon >> wContent >> div_ [class_ "clearfix"] (return ())
mkWidgets :: Monad m => [[HtmlT m ()]] -> HtmlT m ()
mkWidgets widgets =
div_ [class_ "row"] . sequence_ $ intersperse spacer_ (map go widgets)
where
go = mapM_ (mkCol [(XS, 12), (MD, 6), (LG, 3)])
spacer_ :: Monad m => HtmlT m ()
spacer_ = div_ [class_ "spacer visible-xs"] $ return ()
widget_ ::Monad m => HtmlT m () -> HtmlT m ()
widget_ = div_ [class_ "widget"]
widgetBody_ ::Monad m => HtmlT m () -> HtmlT m ()
widgetBody_ = div_ [class_ "widget-body"]
mkTable :: Monad m => HtmlT m () -> [[HtmlT m ()]] -> HtmlT m ()
mkTable title content = mkCol [(LG, 6)] $ do
div_ [class_ "widget"] $ do
div_ [class_ "widget-header"] title
div_ [class_ "widget-body medium no-padding"] $
div_ [class_ "table-responsive"] $ table_ [class_ "table"] $ tbody_ (mapM_ (tr_ . (mapM_ td_)) content)
mkTables :: Monad m => [HtmlT m ()] -> HtmlT m ()
mkTables = div_ [class_ "row"] . sequence_
indexPage :: (Monad m) => HtmlT m ()
indexPage = do
mkIndexPage hd body
where
dashboardSI = SidebarLink ("Dashboard") "#" "tachometer"
tablesSI = SidebarLink ("Tables") "#" "table"
sb = mkSidebar sidebarMain [SidebarTitle "NAVIGATION", dashboardSI, tablesSI]
footerContent =
rowEven XS
[ a_ [href_ "https://github.com/rdash/rdash-barebones", target_ "blank_"] "Github"
, a_ [href_ "#", target_ "blank_"] "About"
, a_ [href_ "#"] "Support"]
sbf = mkSidebarFooter footerContent
sbw = mkSidebarWrapper sb sbf
userMenu = mkItemDropdown "fa fa-user-o" $ mkDropdownMenu "Joe Bloggs" [["Profile", "Menu Item"], ["Logout"]]
bellMenu = mkItemDropdown "fa fa-bell-o" $ mkDropdownMenu "Notifications" [["Server Down!"]]
userBox = mkUserBox [userMenu, bellMenu]
metaBox = mkMetaBox [mkMetaTitle "Dashboard", mkMetaBreadcrumbLinks "Home / Dashboard"]
hb = mkHeaderBar [metaBox, userBox]
alerts = mkAlerts [ mkAlert "alert-success" "Thanks for visiting! Feel free to create pull requests to improve the dashboard!"
, mkAlert "alert-danger" "Found a bug? Create an issue with as many details as you can."]
widgets = mkWidgets $
[[ mkWidget (mkWidgetIcon "green" "fa fa-users") (mkWidgetContent (toHtml "80") (toHtml "Users"))
, mkWidget (mkWidgetIcon "red" "fa fa-tasks") (mkWidgetContent (toHtml "16") (toHtml "Servers"))
, mkWidget (mkWidgetIcon "orange" "fa fa-sitemap") (mkWidgetContent (toHtml "225") (toHtml "Documents"))]
, [mkWidget (mkWidgetIcon "blue" "fa fa-support") (mkWidgetContent (toHtml "62") (toHtml "Tickets"))]]
tables = mkTables [serversTable, usersTable, extrasTable, loadingTable]
pcw = mkPageContent (hb >> alerts >> widgets >> tables)
pgw = mkPageWrapperOpen sbw pcw
body = body_ pgw
hd = mkHead "Dashboard"
serversTable :: Monad m => HtmlT m ()
serversTable = mkTable lhs d
where
checked = span_ [class_ "text-success"] $ i_ [class_ "fa fa-check"] $ return ()
warn = span_ [class_ "text-danger", tooltip_ "Server Down!"] $ i_ [class_ "fa fa-warning"] $ return ()
d = [ ["RDVMPC001", "10.0.0.1", checked]
, ["RDVMPC002", "10.1.0.1", warn]
, ["RDVMPC003", "10.0.1.1", checked]
, ["RDVMPC004", "10.1.1.1", checked]
, ["RDVMPC005", "10.1.1.0", warn]]
lhs = do
fa_ "fa-tasks"
" Servers "
div_ [class_ "pull-right"] $ aHash_ "Manage"
usersTable :: Monad m => HtmlT m ()
usersTable = mkTable lhs d
where
d = [["1", "Joe Bloggs", "Super Admin", "AZ23045"]]
lhs = do
fa_ "fa-users"
" Users "
div_ [class_ "pull-right"] $
input_ [type_ "text", placeholder_ "Search"]
extrasTable :: Monad m => HtmlT m ()
extrasTable = mkCol [(LG, 6)] $ do
div_ [class_ "widget"] $ do
div_ [class_ "widget-header"] lhs
div_ [class_ "widget-body"] . div_ [class_ "widget-content"] . sequence_ $
div_ [class_ "message"] <$> messages
where
lhs = do
fa_ "fa-plus"
" Extras "
div_ [class_ "pull-right"] $ button_ "Button"
messages =
[ div_ [class_ "message"] $ span_ [class_ "error"] "Error message!"]
loadingTable :: Monad m => HtmlT m ()
loadingTable = mkCol [(LG, 6)] $ do
div_ [class_ "widget"] $ do
div_ [class_ "widget-header"] lhs
div_ [class_ "widget-body"] loading
where
lhs = do
fa_ "fa-cog fa-spin"
" Loading Directive "
div_ [class_ "pull-right"] $ a_ [href_ "#" ] "SpinKit"
loading = div_ [class_ "loading"] $ do
div_ [class_ "double-bounce1"] (return ())
div_ [class_ "double-bounce2"] (return ())