{-# LANGUAGE FlexibleContexts, OverloadedStrings, QuasiQuotes #-}
module Clckwrks.Admin.Template where

import Control.Applicative     ((<$>))
import Control.Monad.Trans     (lift)
import Clckwrks.Acid           (GetSiteName(..), GetBackToSiteRedirect(..))
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
   Text
backURL  <- GetBackToSiteRedirect
-> ClckT url m (EventResult GetBackToSiteRedirect)
forall event (m :: * -> *).
(QueryEvent event, GetAcidState m (EventState event), Functor m,
 MonadIO m, MonadState ClckState m) =>
event -> m (EventResult event)
query GetBackToSiteRedirect
GetBackToSiteRedirect
   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"
--   let passwordShowURL u = authShowURL (Auth (AuthenticationMethods $ Just (passwordAuthenticationMethod, toPathSegments u))) []
   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=backURL 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
sidebar :: XMLGenT (ClckT url m) XML
sidebar = XMLGenT (ClckT url m) XML
forall (m :: * -> *) url. Happstack m => XMLGenT (ClckT url m) XML
adminMenuXML

adminMenuXML :: (Happstack m) => XMLGenT (ClckT url m) XML
adminMenuXML :: XMLGenT (ClckT url m) XML
adminMenuXML =
    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 :: [(T.Text, [(Set Role, T.Text, T.Text)])] -> [(T.Text, [(Set Role, T.Text, T.Text)])]
      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 :: (Functor m, Monad m) => (T.Text, [(Set Role, T.Text, T.Text)]) -> XMLGenT (ClckT url m) XML
      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>
        |]