{-# LANGUAGE NoMonomorphismRestriction, PatternSignatures #-}
module View where
import Text.StringTemplate
import Misc
import Text.StringTemplate
import qualified Data.Map as M
import Data.List
import Data.Char
import Control.Monad.Reader
import Network.HTTP (urlEncode)
import Data.Maybe
import SerializeableUsers
import ViewPagination
-- 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 -> String -> IO String
--tutlayout tmplkvs basedomain tmpl = tutlayout' (unsafeVolatileDirectoryGroup "templates" 1) tmplkvs basedomain 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 basedomain tmpl = tutlayout' (directoryGroup "templates") tmplkvs basedomain tmpl
getTemplates :: IO (STGroup String)
getTemplates = directoryGroupSafer "templates"
data RenderGlobals = RenderGlobals { templates :: STGroup String,
mbUser :: Maybe User
}
tutlayout :: RenderGlobals -> [([Char], [Char])] -> String -> String
tutlayout (RenderGlobals ts mbU) attrs tmpl0 =
let tmpl = cleanTemplateName tmpl0
rendertut :: [(String,String)] -> String -> String
rendertut attrs file = ( renderTemplateGroup ts ) attrs file
-- should use readM, or whatever it's called, from Data.Safe
readtut file = read . rendertut [] . concatMap escapequote $ file
where escapequote char = if char=='"' then "\\\"" else [char]
attrsL = maybe attrs( \user -> [("loggedInUser",username user)] ++ attrs ) mbU
content = rendertut attrsL tmpl
header = rendertut [("menubarMenu",menubarMenu),("userMenu",userMenu),("mainUserMenu",mainUserMenu)] "header"
where
userMenu = maybe
( rendertut attrsL "login" )
( \user -> paintHMenu . map (menuLink ts ("/tutorial/" ++ tmpl0) ) $
[("/tutorial/logout","logout " ++ (username user))
, ("/tutorial/changepassword","change password")] )
( mbU )
mainUserMenu = if (isJust mbU)
then paintHMenu .
map (menuLink ts ("/tutorial/" ++ tmpl0) )
. readtut $ "mainusermenu"
else ""
menubarMenu =
paintHMenu . map (menuLink ts ("/tutorial/" ++ tmpl0) ) . readtut $ "menubarmenu"
--, ("post-data","form post data")
--, ("get-data","querystring get data")
--, ("macid-data","macid data")
--, ("migrating","changing the data model")
tocArea = paintVMenuOL . map (menuLink ts ("/tutorial/" ++ tmpl0) ) . readtut $ "toc"
in rendertut ( [("tocarea",tocArea)
, ("contentarea",content)
, ("headerarea",header)] ) "base"
-- menuLink :: Maybe String -> String -> (String, String) -> String
menuLink :: STGroup String
-> String
-> (String, String)
-> String
menuLink templates currUrl (url,anchortext) =
let r = renderTemplateGroup templates attrs
attrs = [("url",url),("anchortext",anchortext)]
in if ( currUrl == url)
then r "menulinkselected"
else if null url
then r "menulinkgray"
else r "menulinkunselected"
simpleLink templates (url,anchortext) = renderTemplateGroup templates [("url",url),("anchortext",anchortext)] "simplelink"
paintVMenu = concatMap (\mi -> "<p>" ++ mi ++ "</p>")
paintVMenuUL xs = "<ul>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ul>"
paintVMenuOL xs = "<ol>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ol>"
paintHMenu = intercalate " | "
--paintTable :: [String] -> Maybe [String] -> [[String]] -> Maybe Pagination -> String
paintTable templates mbHeaderCells datacells mbPagination =
let trows = maybe rows ( (++rows) . paintHeaderTr) mbHeaderCells
where rows = paintTrs tableCells
tableCells :: [[String]]
tableCells = maybe datacells (getPaginatedCells datacells) mbPagination
paginationBar :: String
paginationBar = maybe "" (paintPaginationBar templates datacells) mbPagination
in ( table trows ) ++ paginationBar
paintHeaderTr hc = tr . concat . (map (td {-. biggerfont -} ) ) $ hc
paintTrs cells = concat . map (tr . concat) . ( (map . map) td ) $ cells
biggerfont x = "<font size=+1>" ++ x ++ "</font>"
tr x = "<tr>" ++ x ++ "</tr>"
td x = "<td>" ++ x ++ "</td>"
table x = "<table>" ++ x ++ "</table>"
cleanTemplateName tmpl = filter isAlpha tmpl
paintblurb b = (concatMap formatnewlines) b
where formatnewlines c = if c == '\n' then "<br>" else [c]
{-
paintConsultantProfile :: RenderGlobals -> ConsultantProfile -> String -> String
paintConsultantProfile rglobs (ConsultantProfile cRate cBlurb listAsC) uName =
let showblurb = paintblurb cBlurb
-- jobsPosted = paintJobsTable n rglobs $ js
in renderTemplateGroup (templates rglobs) [("username",uName)
, ("blurb",showblurb)
-- , ("jobsPosted",jobsPosted)
, ("billingRate",cRate)] "viewconsultantprofileInclude"
-}
paintProfile :: RenderGlobals -> String -> ConsultantProfile -> String
paintProfile rglobs user cp =
let attrs = [("username",user)
, ("blurb",paintblurb . blurb $ cp)
--, ("jobsPosted",paintJobsTable n rglobs $ js)
, ("contact",contact cp)]
in renderTemplateGroup (templates rglobs) attrs "consultantprofile"
paintUserJobsTable rglobs postedBy rsUserJobs currP resPP=
let jobCells = map ( \(Job j budget blurb) ->
[ simpleLink (templates rglobs) ("/tutorial/viewjob?user="++postedBy++"&job=" ++ j,j)
, simpleLink (templates rglobs) ("/tutorial/editjob?user="++postedBy++"&job=" ++ j,"edit")
, simpleLink (templates rglobs) ("/tutorial/deletejob?user="++postedBy++"&job=" ++ j,"delete")
] ) rsUserJobs
in paintTable (templates rglobs) Nothing -- (Just ["<b>project</b>","<b>budget</b>"])
jobCells
Nothing -- no pagination for now
paintAllJobsTable rglobs rsListAllJobs currP resPP =
let p = Pagination { currentpage = currP,
resultsPerPage = resPP,
baselink = "tutorial/jobs",
paginationtitle = "Job Results: "}
jobCells = map ( \((Job j budget blurb),postedBy) ->
[ simpleLink (templates rglobs) ("/tutorial/viewjob?user="++postedBy++"&job=" ++ j,j)
, budget
, simpleLink (templates rglobs) ("/tutorial/viewprofile?user="++postedBy, postedBy )
] ) rsListAllJobs
in paintTable (templates rglobs) (Just ["<b>project</b>","<b>budget</b>","<b>posted by</b>"])
jobCells
(Just p)
paintjob rglobs pBy (Job jN jBud jBlu) =
let userlink = simpleLink (templates rglobs) ("/tutorial/viewprofile?user=" ++ pBy,pBy)
attrs = [("jobname",jN)
, ("budget",jBud)
, ("jobblurb",jBlu)
, ("postedBy",userlink)]
in renderTemplateGroup (templates rglobs) attrs "job"