{-# LANGUAGE FlexibleContexts, OverloadedStrings, QuasiQuotes #-} module Clckwrks.Admin.Template where import Control.Applicative ((<$>)) import Control.Monad.Trans (lift) import Clckwrks.Acid (GetSiteName(..)) import Clckwrks.Monad (ClckT(..), ClckState(adminMenus), plugins, query) import Clckwrks.URL (ClckURL(JS)) import Clckwrks.JS.URL (JSURL(..)) import {-# SOURCE #-} Clckwrks.Authenticate.Plugin (authenticatePlugin) import Clckwrks.Authenticate.URL (AuthURL(Auth)) import Clckwrks.ProfileData.API (getUserRoles) import Clckwrks.ProfileData.Types (Role) import Control.Monad.State (get) import Data.Maybe (mapMaybe, fromMaybe) import Data.Text.Lazy (Text) import qualified Data.Text as T import Data.Set (Set) import qualified Data.Set as Set import Happstack.Authenticate.Core (AuthenticateURL(Controllers)) import Happstack.Server (Happstack, Response, toResponse) import HSP.XMLGenerator import HSP.XML (XML, fromStringLit) import Language.Haskell.HSX.QQ (hsx) import Web.Plugins.Core (pluginName, getPluginRouteFn) template :: ( Happstack m , EmbedAsChild (ClckT url m) headers , EmbedAsChild (ClckT url m) body ) => String -> headers -> body -> ClckT url m Response template title headers body = do siteName <- (fromMaybe "Your Site") <$> query GetSiteName p <- plugins <$> get ~(Just authShowURL) <- getPluginRouteFn p (pluginName authenticatePlugin) ~(Just clckShowURL) <- getPluginRouteFn p "clck" -- let passwordShowURL u = authShowURL (Auth (AuthenticationMethods $ Just (passwordAuthenticationMethod, toPathSegments u))) [] toResponse <$> (unXMLGenT $ [hsx| -- -- <% title %> <% headers %>
Back to <% siteName %>
<% sidebar %>
<% body %>
|]) emptyTemplate :: ( Happstack m , EmbedAsChild (ClckT url m) headers , EmbedAsChild (ClckT url m) body ) => String -> headers -> body -> ClckT url m Response emptyTemplate title headers body = do siteName <- (fromMaybe "Your Site") <$> query GetSiteName toResponse <$> (unXMLGenT $ [hsx| <% title %> <% headers %>
<% siteName %>
-- <% 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 [hsx|
|] 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) = [hsx| <%>
  • <% category %>
    • <% mapM mkLink links %> |] mkLink :: (Functor m, Monad m) => (Set Role, T.Text, T.Text) -> XMLGenT (ClckT url m) XML mkLink (_visible, title, url) = [hsx|
  • <% title %>
    • |]