{-# 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 :: String -> headers -> body -> ClckT url m Response
template String
title headers
headers body
body = do
Text
siteName <- (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"Your Site") (Maybe Text -> Text)
-> ClckT url m (Maybe Text) -> ClckT url m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetSiteName -> ClckT url m (EventResult GetSiteName)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query GetSiteName
GetSiteName
ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT url m ClckState -> ClckT url m ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get
~(Just AuthURL -> [(Text, Maybe Text)] -> Text
authShowURL) <- ClckPlugins
-> Text
-> ClckT url m (Maybe (AuthURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn ClckPlugins
p (Plugin
AuthURL
Theme
(ClckT ClckURL (ServerPartT IO) Response)
(ClckT ClckURL IO ())
ClckwrksConfig
ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
AuthURL
Theme
(ClckT ClckURL (ServerPartT IO) Response)
(ClckT ClckURL IO ())
ClckwrksConfig
ClckPluginsSt
authenticatePlugin)
~(Just ClckURL -> [(Text, Maybe Text)] -> Text
clckShowURL) <- ClckPlugins
-> Text
-> ClckT url m (Maybe (ClckURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn ClckPlugins
p Text
"clck"
XML -> Response
forall a. ToMessage a => a -> Response
toResponse (XML -> Response) -> ClckT url m XML -> ClckT url m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XMLGenT (ClckT url m) XML -> ClckT url m XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (XMLGenT (ClckT url m) XML -> ClckT url m XML)
-> XMLGenT (ClckT url m) XML -> ClckT url m XML
forall a b. (a -> b) -> a -> b
$ [hsx|
<html>
<head>
<link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.3.2/css/bootstrap-combined.min.css" rel="stylesheet" media="screen" />
-- <link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap-responsive.css" rel="stylesheet" />
<link type="text/css" href="/static/admin.css" rel="stylesheet" />
<script type="text/javascript" src="/jquery/jquery.js" ></script>
<script type="text/javascript" src="/json2/json2.js" ></script>
<script type="text/javascript" src="//netdna.bootstrapcdn.com/twitter-bootstrap/2.3.2/js/bootstrap.min.js" ></script>
<script src="//ajax.googleapis.com/ajax/libs/angularjs/1.2.24/angular.min.js"></script>
<script src="//ajax.googleapis.com/ajax/libs/angularjs/1.2.24/angular-route.min.js"></script>
-- <script src=(passwordShowURL UsernamePasswordCtrl)></script>
<script src=(clckShowURL (JS ClckwrksApp) [])></script>
<script src=(authShowURL (Auth Controllers) [])></script>
<title><% title %></title>
<% headers %>
</head>
<body ng-app="clckwrksApp" ng-controller="AuthenticationCtrl">
<div class="navbar">
<div class="navbar-inner">
<div class="container-fluid">
<a href="/" class="brand">Back to <% siteName %></a>
</div>
</div>
</div>
<div class="container-fluid">
<div class="row-fluid">
<div class="span2">
<% sidebar %>
</div>
<div class="span10">
<% body %>
</div>
</div>
</div>
</body>
</html>
|])
emptyTemplate ::
( Happstack m
, EmbedAsChild (ClckT url m) headers
, EmbedAsChild (ClckT url m) body
) => String -> headers -> body -> ClckT url m Response
emptyTemplate :: String -> headers -> body -> ClckT url m Response
emptyTemplate String
title headers
headers body
body = do
Text
siteName <- (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"Your Site") (Maybe Text -> Text)
-> ClckT url m (Maybe Text) -> ClckT url m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GetSiteName -> ClckT url m (EventResult GetSiteName)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query GetSiteName
GetSiteName
XML -> Response
forall a. ToMessage a => a -> Response
toResponse (XML -> Response) -> ClckT url m XML -> ClckT url m Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (XMLGenT (ClckT url m) XML -> ClckT url m XML
forall (m :: * -> *) a. XMLGenT m a -> m a
unXMLGenT (XMLGenT (ClckT url m) XML -> ClckT url m XML)
-> XMLGenT (ClckT url m) XML -> ClckT url m XML
forall a b. (a -> b) -> a -> b
$ [hsx|
<html>
<head>
<link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap.min.css" rel="stylesheet" media="screen" />
<link href="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/css/bootstrap-responsive.css" rel="stylesheet" />
<link type="text/css" href="/static/admin.css" rel="stylesheet" />
<script type="text/javascript" src="/jquery/jquery.js" ></script>
<script type="text/javascript" src="/json2/json2.js" ></script>
<script type="text/javascript" src="//netdna.bootstrapcdn.com/twitter-bootstrap/2.2.2/js/bootstrap.min.js" ></script>
<title><% title %></title>
<% headers %>
</head>
<body>
<div class="navbar">
<div class="navbar-inner">
<div class="container-fluid">
<div class="brand"><% siteName %></div>
</div>
</div>
</div>
<div class="container-fluid">
<div class="row-fluid">
<div class="span2">
-- <% sidebar %>
</div>
<div class="span10">
<% body %>
</div>
</div>
</div>
</body>
</html> |])
sidebar :: (Happstack m) => XMLGenT (ClckT url m) XML
= XMLGenT (ClckT url m) XML
forall (m :: * -> *) url. Happstack m => XMLGenT (ClckT url m) XML
adminMenuXML
adminMenuXML :: (Happstack m) => XMLGenT (ClckT url m) XML
=
do [(Text, [(Set Role, Text, Text)])]
allMenus <- ClckState -> [(Text, [(Set Role, Text, Text)])]
adminMenus (ClckState -> [(Text, [(Set Role, Text, Text)])])
-> XMLGenT (ClckT url m) ClckState
-> XMLGenT (ClckT url m) [(Text, [(Set Role, Text, Text)])]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> XMLGenT (ClckT url m) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
[(Text, [(Set Role, Text, Text)])]
usersMenus <- [(Text, [(Set Role, Text, Text)])]
-> XMLGenT (ClckT url m) [(Text, [(Set Role, Text, Text)])]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) u a b c.
(MonadTrans t, Monad (t (ClckT u m)), Happstack m) =>
[(a, [(Set Role, b, c)])]
-> t (ClckT u m) [(a, [(Set Role, b, c)])]
filterByRole [(Text, [(Set Role, Text, Text)])]
allMenus
[hsx| <div class="well">
<ul class="nav nav-list">
<% mapM mkMenu usersMenus %>
</ul>
</div> |]
where
filterByRole :: [(a, [(Set Role, b, c)])]
-> t (ClckT u m) [(a, [(Set Role, b, c)])]
filterByRole [(a, [(Set Role, b, c)])]
menus =
do Set Role
userRoles <- ClckT u m (Set Role) -> t (ClckT u m) (Set Role)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ClckT u m (Set Role)
forall (m :: * -> *) u.
(Happstack m, MonadIO m) =>
ClckT u m (Set Role)
getUserRoles
[(a, [(Set Role, b, c)])]
-> t (ClckT u m) [(a, [(Set Role, b, c)])]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, [(Set Role, b, c)])]
-> t (ClckT u m) [(a, [(Set Role, b, c)])])
-> [(a, [(Set Role, b, c)])]
-> t (ClckT u m) [(a, [(Set Role, b, c)])]
forall a b. (a -> b) -> a -> b
$ ((a, [(Set Role, b, c)]) -> Maybe (a, [(Set Role, b, c)]))
-> [(a, [(Set Role, b, c)])] -> [(a, [(Set Role, b, c)])]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Set Role
-> (a, [(Set Role, b, c)]) -> Maybe (a, [(Set Role, b, c)])
forall a a b c.
Ord a =>
Set a -> (a, [(Set a, b, c)]) -> Maybe (a, [(Set a, b, c)])
sectionFilter Set Role
userRoles) [(a, [(Set Role, b, c)])]
menus
sectionFilter :: Set a -> (a, [(Set a, b, c)]) -> Maybe (a, [(Set a, b, c)])
sectionFilter Set a
userRoles (a
title, [(Set a, b, c)]
items) =
case ((Set a, b, c) -> Bool) -> [(Set a, b, c)] -> [(Set a, b, c)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Set a -> (Set a, b, c) -> Bool
forall a b c. Ord a => Set a -> (Set a, b, c) -> Bool
itemFilter Set a
userRoles) [(Set a, b, c)]
items of
[] -> Maybe (a, [(Set a, b, c)])
forall a. Maybe a
Nothing
[(Set a, b, c)]
items' -> (a, [(Set a, b, c)]) -> Maybe (a, [(Set a, b, c)])
forall a. a -> Maybe a
Just (a
title, [(Set a, b, c)]
items')
itemFilter :: Set a -> (Set a, b, c) -> Bool
itemFilter Set a
userRoles (Set a
visibleRoles, b
_, c
_) = Bool -> Bool
not (Set a -> Bool
forall a. Set a -> Bool
Set.null (Set a -> Set a -> Set a
forall a. Ord a => Set a -> Set a -> Set a
Set.intersection Set a
userRoles Set a
visibleRoles))
mkMenu :: (c, t (Set Role, Text, Text)) -> GenChildList (ClckT url m)
mkMenu (c
category, t (Set Role, Text, Text)
links) = [hsx|
<%>
<li class="nav-header"><% category %></li>
<% mapM mkLink links %>
</%> |]
mkLink :: (Functor m, Monad m) => (Set Role, T.Text, T.Text) -> XMLGenT (ClckT url m) XML
mkLink :: (Set Role, Text, Text) -> XMLGenT (ClckT url m) XML
mkLink (Set Role
_visible, Text
title, Text
url) = [hsx|
<li><a href=url><% title %></a></li>
|]