happs-tutorial-0.6.4: src/View.hs

module View where

import Text.StringTemplate
import Misc
import qualified Data.Map as M
import Data.List
import HAppS.Server.HTTP.Types (rqURL, Request)
import qualified Data.ByteString.Char8 as B
import Data.Char
import Control.Monad.Reader
import HAppS.Helpers.HtmlOutput
import Text.StringTemplate.Helpers
import Network.HTTP (urlEncode)

import Data.Maybe
import StateVersions.AppState1

-- 
--import SerializeableUserInfos (UserProfile (..))
-- (Job(..), JobName(..))
import HAppS.Helpers

--import MiscStringTemplate

-- debug problem with foreign character display
-- foreign chars displau okay
--t = do templates <- directoryGroup "templates" 
--       -- let content = renderTemplateGroup templates [] "foreignchars"
--       writeFile "output.html" $ tutlayout (RenderGlobals templates Nothing) [] "foreignchars"


-- Notice, there are no HApps.* imports 
-- Idea is, view is meant to be used from controller.
-- Try to keep functions pure: > :browse View in ghci should reveal there's no IO for any of these function sigs.

data RenderGlobals = RenderGlobals {
                            origrq :: Request
                            , templates :: STDirGroups String -- STGroup String -- STDirGroups String -- 
                            , mbSession :: Maybe SessionData
                            }
  deriving Show







tutlayout :: RenderGlobals -> [([Char], [Char])] -> String -> String
tutlayout (RenderGlobals rq ts' mbSess) attrs tmpl0 = 
  let ts = getTemplateGroup "." ts'
      tmpl = cleanTemplateName tmpl0
      mbU = return . sesUser =<< mbSess
      rendertut :: [(String,String)] -> String -> String
      rendertut attrs file = ( renderTemplateGroup ts ) attrs file

      -- should use readM, or whatever it's called, from Data.Safe
      --readtut :: (Monad m, Read a) => String -> m a
      readtut file = (Misc.safeRead . rendertut [] . concatMap escapequote $ file)
        where escapequote char = if char=='"' then "\\\"" else [char]
      readTutTuples :: String -> [(String,String)]
      readTutTuples f = either (const [("readTutTuples error","")]) id
                                         $ (readtut f :: Either String [(String,String)] )
      attrsL = maybe attrs( \user -> [("loggedInUser",B.unpack . unusername $ user)] ++ attrs ) mbU  

      content = rendertut attrsL tmpl

      header =  rendertut [("menubarMenu",menubarMenu),("userMenu",userMenu),("mainUserMenu",mainUserMenu)] "header"
        where 
          userMenu = maybe 
            ( rendertut attrsL "login" )
            ( \user -> hMenuBars rq $
              [("/tutorial/logout","logout " ++ (B.unpack . unusername $ user))
               , ("/tutorial/changepassword","change password")] )
            ( mbU ) 
          mainUserMenu = if (isJust mbU) 
                           then hMenuBars rq $ readTutTuples "mainusermenu" 
                           else "" 

          menubarMenu = hMenuBars rq $ readTutTuples "menubarmenu"
      --, ("post-data","form post data")
      --, ("get-data","querystring get data")
      --, ("macid-data","macid data")
      --, ("migrating","changing the data model")
      tocArea = vMenuOL rq $ readTutTuples "toc"
           
  
  in rendertut ( [("tocarea",tocArea)
                     , ("contentarea",content)
                     , ("headerarea",header)] ) "base"

cleanTemplateName tmpl = filter isAlpha tmpl
paintblurb b =  newlinesToHtmlLines b

--paintProfile :: RenderGlobals -> String -> UserProfile -> String
paintProfile rglobs user cp userimagepath =
  let ts = getTemplateGroup "." . templates $ rglobs
      
      attrs = [("username",user) 
               , ("userimage", userimagepath ) -- avatarimage (UserName . B.pack $ user) 
               , ("blurb",newlinesToHtmlLines . B.unpack . blurb $ cp)
               --, ("jobsPosted",paintJobsTable n rglobs $ js)
               , ("contact", newlinesToHtmlLines . B.unpack . contact $ cp)]
  in renderTemplateGroup ts attrs "consultantprofile"



paintUserJobsTable rglobs postedBy rsUserJobs currP resPP = 
  let jobCells = map ( \( JobName j', Job budget blurb)  -> let j :: String
                                                                j = B.unpack j' in 
                       [ joblink postedBy j
                         , simpleLink ("/tutorial/editjob?user="++ (B.unpack postedBy) ++"&job=" ++ j,"edit")
                         , simpleLink ("/tutorial/deletejob?user="++ (B.unpack postedBy) ++"&job=" ++ j,"delete")

                       ] )  rsUserJobs
  in  paintTable Nothing jobCells Nothing -- no pagination for now 

joblink postedBy j = simpleLink ("/tutorial/viewjob?user="++(B.unpack postedBy)++"&job=" ++ j,j)
userlink pBy = simpleLink ("/tutorial/viewprofile?user=" ++ (B.unpack pBy),(B.unpack pBy) )
paintjob rglobs (UserName pBy) (JobName jN, Job jBud jBlu) =
  let ts = getTemplateGroup "." . templates $ rglobs
      joblink = simpleLink ("/tutorial/viewjob?user=" ++ (B.unpack pBy),(B.unpack pBy) )
      attrs = [ ("username",B.unpack pBy)
              , ("jobname",B.unpack jN)               
              , ("budget",B.unpack jBud)
              , ("jobblurb",B.unpack jBlu)
              , ("postedBy",userlink pBy)] 
  in renderTemplateGroup ts attrs "job"