{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} {-# OPTIONS_GHC -F -pgmFhsx2hs #-} module Clckwrks.Admin.Template where import Clckwrks import Control.Monad.State (get) import Data.Maybe (mapMaybe) import Data.Text.Lazy (Text) import qualified Data.Text as T import Data.Set (Set) import qualified Data.Set as Set import HSP.XMLGenerator import HSP.XML (XML, fromStringLit) template :: ( Happstack m , EmbedAsChild (ClckT url m) headers , EmbedAsChild (ClckT url m) body ) => String -> headers -> body -> ClckT url m Response template title headers body = toResponse <$> (unXMLGenT $ <% title %> <% headers %>
Back to Your Site
<% sidebar %>
<% body %>
) sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML sidebar = adminMenuXML adminMenuXML :: (Happstack m) => XMLGenT (ClckT url m) XML adminMenuXML = do allMenus <- adminMenus <$> get usersMenus <- filterByRole allMenus
where -- filterByRole :: [(T.Text, [(Set Role, T.Text, T.Text)])] -> [(T.Text, [(Set Role, T.Text, T.Text)])] filterByRole menus = do userRoles <- lift getUserRoles return $ mapMaybe (sectionFilter userRoles) menus sectionFilter userRoles (title, items) = case filter (itemFilter userRoles) items of [] -> Nothing items' -> Just (title, items') itemFilter userRoles (visibleRoles, _, _) = not (Set.null (Set.intersection userRoles visibleRoles)) -- mkMenu :: (Functor m, Monad m) => (T.Text, [(Set Role, T.Text, T.Text)]) -> XMLGenT (ClckT url m) XML mkMenu (category, links) = <%>
  • <% category %>
    • <% mapM mkLink links %> mkLink :: (Functor m, Monad m) => (Set Role, T.Text, T.Text) -> XMLGenT (ClckT url m) XML mkLink (_visible, title, url) =
  • <% title %>