happs-tutorial-0.3: src/View.hs

module View where

import Text.StringTemplate
import Misc
import Text.StringTemplate
import qualified Data.Map as M
import Data.Char

-- Notice, there are no HApps.* imports 
-- Idea is, view is meant to be used from controller.
-- Try to keep functions as type
--   Pure -> .. -> Pure -> IO String
--   or Pure -> Pure -> String

-- 1 second reload time/IO for templates.
-- tmplkvs: key/value pairs used for filling in a template
tutlayout, tutlayoutSafe :: [(String, String)] -> String -> IO String
tutlayout tmplkvs tmpl = tutlayout' (unsafeVolatileDirectoryGroup "templates" 1) tmplkvs tmpl
-- how much stress does this put on the server?
-- how could I even find this out?
-- I could try setting a higher reload time, run top, and see if the happs process uses less memory
-- withTemplateDir :: String -> (STGroup String -> String) -> IO String
-- Could also see if it's practical to try working with the safe version
-- Probably it's fine for "production", where not making template changes all the time
-- and it's fine to stop/restart server when I do.
tutlayoutSafe tmplkvs tmpl = tutlayout' (directoryGroup "templates")  tmplkvs tmpl 

tutlayout' :: IO (STGroup String) -> [(String, String)] -> String -> IO String
tutlayout' f tmplkvs tmpl = do
  templates <- f 

  let rendertut kvs tmpl = ( renderTemplateGroup templates ) kvs tmpl

      content = rendertut tmplkvs  tmpl
      kvMenustyleActivelink = getMenuCssStyles tmpl      
      userMenu = maybe 
        ( rendertut (tmplkvs ++ kvMenustyleActivelink) "login" )
        ( \user -> rendertut [("user",user)] "menuLoggedIn" )
        ( lookup "loggedInUser" tmplkvs )
      header =  rendertut (kvMenustyleActivelink ++ [("userMenu",userMenu)] ) "header"
      toc = rendertut kvMenustyleActivelink "tableofcontents" 

  return $ rendertut ( [("tocarea",toc)
                     , ("contentarea",content)
                     , ("headerarea",header)] ) "base"

getMenuCssStyles :: String -> [(String,String)]
getMenuCssStyles tmpl = 
  maybe
    defaultMenuActivelinks
    tweakCssStyles
    mbActiveLink
  where defaultMenuActivelinks = zip ( map snd kvTmplMenucontrol ) ( repeat "menuitem" )
        mbActiveLink = lookup tmpl kvTmplMenucontrol
        tweakCssStyles menuControlVar = map highlightselected defaultMenuActivelinks
          where highlightselected (mv,style) | mv == menuControlVar = (mv,"menuItemSelected")
                highlightselected a | otherwise = a
        

-- In header and table of contents menus: 
-- style "menuItemSelected" makes a colored link
-- style "menuItem" is default
-- default for menu control is no menu item is highlighted
-- Some templates trigger a menu link color change
-- Some templates have no effect
-- This is controlled at the template level by using "menustyle_somepage" type vars 
-- to control css, and in the following list, which controls which templates that style
-- will have an effect in
-- In all cases, the template named "sometmpl" will have an active menu item which is controlled by the template variable
-- "menustyleSometmpl"
-- url-with_dashes would be controlled with var menustyleUrlwithdashes
-- (Template system doens't like punctuation in template vars)
kvTmplMenucontrol :: [(String,String)]
kvTmplMenucontrol = map stylify
                      [ "home"
                        , "view-all-users"
                        , "login"
                        , "register"

                        , "prerequisites"
                        , "overview"
                        , "run-tutorial-locally"
                        , "main-function"
                        , "basic-url-handling"
                        , "templates-dont-repeat-yourself"
                        , "stringtemplate-basics"
                        , "start-happs-on-boot"
                        
                      ]
  where -- how to do this with Control.Arrow?
        stylify tmpl = (tmpl, ( ("menustyle" ++ ) . capitalize . stripPunctuation . (map toLower) ) tmpl)
        capitalize [] = []
        capitalize (x:xs) = toUpper x : xs
        stripPunctuation = filter $ alltrue $ map (/=) [ '-', '_' ]