" xs + +-- A handler that renders a template with the template name specified in the argument +tutlayoutSp1 attrs tmpl = withRequest $ \rq -> ( tutlayoutReq rq attrs ) tmpl + +-- Render a template when the request has exactly one path segment left. +-- The template that gets rendered is that path segment +tutlayoutSp attrs = ServerPartT $ \rq -> + case rqPaths rq of + [tmpl] -> ( tutlayoutReq rq attrs ) tmpl + _ -> noHandle + +-- The final value is HtmlString so that the HAppS machinery does the right thing with toMessage. +-- If the final value was left as a String, the page would display as text, not html. +tutlayoutReq :: Request -> [([Char], String)] -> String -> WebT IO Response +tutlayoutReq rq attrs tmpl = liftIO $ do + mbUser <- getmbLoggedInUser rq + attrs <- return $ maybe attrs (\user -> ("loggedInUser",user):attrs) mbUser + return . toResponse . HtmlString =<< tutlayout attrs tmpl + +loginPage :: UserAuthInfo -> [ ServerPartT IO Response ] +loginPage (UserAuthInfo user pass) = [ + ServerPartT $ \rq -> do + allowed <- query $ AuthUser user pass + if allowed + then do startsess user ( {-traceWith dbg -} rq ) + else ( tutlayoutReq rq [("errormsg","login error: invalid username or password")] ) "home" + ] + -- where dbg rq = "loginheaders: " ++ (show . {- rqHeaders -} getHeader "referer" $ rq) + + + +startsess :: String -> Request -> WebT IO Response +startsess user rq = do + key <- update $ NewSession (SessionData user) + addCookie (3600) (mkCookie "sid" (show key)) + ( tutlayoutReq rq [("loggedInUser",user)] "home" ) + +logoutPage :: ServerPartT IO Response +logoutPage = + withRequest $ \rq -> do + let mbSk = getMbSessKey rq + maybe + ( return () ) + ( update . DelSession ) + mbSk + ( tutlayoutReq rq [] ) "home" + + + +newUserPage :: NewUserInfo -> [ServerPartT IO Response] +newUserPage (NewUserInfo user pass1 pass2) = + [ ServerPartT $ \rq -> + if pass1 == pass2 + then do exists <- query $ IsUser user + if exists + then errW "User already exists" rq + else do + update $ ( AddUser user $ User user pass1 ) + startsess user rq + else errW "passwords did not match" rq + ] + where errW msg rq = ( tutlayoutReq rq [("errormsgRegister", msg)] ) "register" + + + + diff --git a/src/ControllerBasic.hs b/src/ControllerBasic.hs --- a/src/ControllerBasic.hs +++ b/src/ControllerBasic.hs @@ -4,6 +4,8 @@ import HAppS.Server import Misc import Data.Monoid +import Control.Monad.Trans +import Text.StringTemplate {- ServerPartTs take a request to a response, approximately like so @@ -33,7 +35,7 @@ simpleHandlers :: [ServerPartT IO Response] -simpleHandlers = debugFilter [ +simpleHandlers = [ ServerPartT $ \rq -> do ru <- (return . rqURL) rq @@ -89,13 +91,13 @@ [ msgToSp "Another response generated using exactdir and msgToSp"] , (exactdir "/ioaction" - [ ioMsgToSp (return "This is an IO value.\ + [ ioMsgToSp (return $ HtmlString "This is an IO value.\ \It could just as easily be the result of a file read operation,\ - \or a database lookup." :: IO String) ] ) + \or a database lookup." :: IO HtmlString) ] ) , (exactdir "/ioaction2" [ ioMsgToSp $ do slurp <- readFile "src/Main.hs" - return $ "Let's try reading the Main.hs file: .....\n" ++ slurp ]) + return $ HtmlString $ "Let's try reading the Main.hs file: .....\n" ++ slurp ]) , (exactdir "/htmlAttemptWrong" [msgToSp "first try at displaying red formatted html (wrong)"]) @@ -111,8 +113,28 @@ -- pretty much useless little server part constructor, for demo purposes simplematch :: String -> TutHandler simplematch u = ServerPartT $ \rq -> do - ru <- (return . rqURL) rq + let ru = rqURL rq if ru == ("/simplematch" ++ u) then ( return . toResponse ) ( "matched " ++ u) else noHandle :: TutWebT +-- don't like these functions, feel they obfuscate. +-- I wrote them when I had a less good understanding +-- oh well, at least I don't use them in "real" code. (eg, took this out of misc.) +msgToSp :: (Monad m, ToMessage a) => a -> ServerPartT m Response +msgToSp = anyRequest . msgToWeb +msgToWeb :: (Monad m, ToMessage a) => a -> WebT m Response +msgToWeb = return . toResponse +ioMsgToSp = anyRequest . liftIO . ( return . toResponse =<< ) + +myFavoriteAnimal :: ServerPartT IO Response +myFavoriteAnimal = + exactdir "/usingtemplates/my-favorite-animal" + [ ServerPartT $ \rq -> + liftIO $ do templates <- directoryGroup "templates" + return . toResponse . HtmlString . + renderTemplateGroup templates [("favoriteAnimal", "Tyrannasaurus Rex") + , ("leastFavoriteAnimal","Bambi")] + $ "my-favorite-animal" + ] + diff --git a/src/ControllerUsingTemplates.hs b/src/ControllerUsingTemplates.hs deleted file mode 100644 --- a/src/ControllerUsingTemplates.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# OPTIONS -XPatternSignatures #-} -module ControllerUsingTemplates where - -import HAppS.Server -import Misc -import Data.Monoid - -import View -import Text.StringTemplate - - -usingTemplatesHandlers :: [ServerPartT IO Response] -usingTemplatesHandlers = debugFilter [ - dir "usingtemplates" - [ exactdir "/testtgio" - [ ioMsgToSp ( withTutTemplate $ renderDef [("favoriteAnimal", "giraffe")] "myhomepage" ) ] - ] - ] - - - - - --- generate some html, from templates in templates directory -{- -generatePages = do - - - -- should probably change this to directoryGroup or directoryGroupLazy in production code - -- but not sure which one is better... figure it out later. - (tg :: STGroup String) <- unsafeVolatileDirectoryGroup "templates" 1 -- 1 second reload time - - (writeFile "myHomepage.html" . genMyHomepage) tg - (writeFile "moreFavoriteAnimals.html" . genMoreFavoriteAnimals) tg - where - genMyHomepage = toString . setAttribute "favoriteAnimal" "giraffe" . (getStringTemplateDef "myhomepage") - genMoreFavoriteAnimals = toString - . optInsertTmpl [("separator","
\n")] - . setAttribute "favoriteAnimals" favoriteAnimals - . getStringTemplateDef "moreFavoriteAnimals" - favoriteAnimals = ["guppies","mayflies","dinosaurs"] --} diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -6,10 +6,31 @@ import Model import Controller import Misc +import System.Environment +import HAppS.State +import Session main = do - let p = 5001 + -- let p = 5001 + let usageMessage = "usage example: happs-tutorial 5001 (starts the app on port 5001)" + args <- getArgs + case args of + [port] -> runserver (read port) + otherwise -> do + putStrLn usageMessage + + +-- run the happs server on some port +runserver p = do startSystemState entryPoint -- start the HAppS state system - putStrLn $ "starting on port " ++ (show p) + putStrLn $ "happs tutorial starting on port " ++ (show p) ++ "\n" ++ + "shut down with ctrl-c" + simpleHTTP (Conf {port=p}) controller -- start serving web pages + where entryPoint :: Proxy TutorialState + entryPoint = Proxy +runInGhci = do + putStrLn $ "happs tutorial running ins ghci. \n" ++ + "exit :q ghci completely and reenter ghci, before restarting." + runserver 5001 diff --git a/src/Misc.hs b/src/Misc.hs --- a/src/Misc.hs +++ b/src/Misc.hs @@ -6,57 +6,39 @@ import qualified Data.ByteString.Lazy.Char8 as L import Control.Monad.Trans import Data.List + import Debug.Trace +import Text.PrettyPrint as PP + import Text.StringTemplate import Data.Monoid +import Control.Monad.Reader newtype HtmlString = HtmlString String instance ToMessage HtmlString where toContentType _ = B.pack "text/html" toMessage (HtmlString s) = L.pack s -instance ToMessage (StringTemplate String) where - toContentType _ = B.pack "text/html" - toMessage = L.pack . toString - -{- -exactdir :: Monad m => String -> [ServerPartT m a] -> ServerPartT m a -exactdir staticPath handlers - = ServerPartT $ \rq -> if ( \rq' -> ( rqURL rq' == staticPath ) ) rq - then (\rq' -> unServerPartT (mconcat handlers) rq') rq - else mempty --} -exactdir staticPath = spCatIf rqmatch - where rqmatch rq = rqURL rq == staticPath - --- concat handlers if... -spCatIf rqmatch handlers = ServerPartT h - where h rq = if rqmatch rq then unServerPartT (mconcat handlers) rq else mempty - -traceTrue x = trace (show x) True - - -msgToWeb :: (Monad m, ToMessage a) => a -> WebT m Response -msgToWeb = return . toResponse +exactdir staticPath = spsIf (\rq -> rqURL rq == staticPath) -ioMsgToWeb :: (ToMessage a) => IO a -> WebT IO Response -ioMsgToWeb ios = liftIO $ do s <- ios - ( return . toResponse ) s +spsIf :: (Monad m) => (Request -> Bool) -> [ServerPartT m a] -> ServerPartT m a +spsIf p sps = withRequest $ \rq -> + if p rq + then unServerPartT (mconcat sps) rq + else mempty -msgToSp :: (Monad m, ToMessage a) => a -> ServerPartT m Response -msgToSp = anyRequest . msgToWeb +traceTrue x = trace (show x ++ "\n\n") True +traceIt x = trace (show x ++ "\n\n") x +traceMsg msg x = trace ( "\n\n" ++ msg ++ (show x) ++ "\n\n") x +traceReadableMsg msg x = trace ( "\n\n" ++ msg ++ (show . show $ x) ++ "\n\n") x -ioMsgToSp :: (ToMessage a) => (IO a) -> ServerPartT IO Response -ioMsgToSp = anyRequest . ioMsgToWeb -traceIt x = trace (show x) x -traceMsg msg x = trace ( msg ++ (show x) ) x +pp[] = ( PP.render . vcat . map text . map show ) +traceWith f v = trace (f v) v instance (Monad m) => Monoid (ServerPartT m a) where mempty = ServerPartT $ \rq -> noHandle mappend a b = ServerPartT $ \rq -> (unServerPartT a rq) `mappend` (unServerPartT b rq) - - instance (Monad m) => Monoid (WebT m a) where mempty = noHandle mappend a b = WebT $ do a' <- unWebT a @@ -64,12 +46,44 @@ NoHandle -> unWebT b _ -> return a' -renderDef :: [(String,String)] -> String -> STGroup String -> StringTemplate String -renderDef attrs tmplname grp = - maybe ( error $ "template not found: " ++ tmplname ) - ( setManyAttrib attrs ) - ( getStringTemplate tmplname grp ) +renderTemplateGroup :: (STGroup String) -> [(String, String)] -> String -> String +renderTemplateGroup gr attrs tmpl = + toString $ + maybe ( error $ "template not found: " ++ tmpl ) + ( setManyAttrib attrs ) + ( getStringTemplate tmpl gr ) --- withTemplateDir :: String -> (STGroup String -> String) -> IO String -withTemplateDir tdir f = return . f =<< unsafeVolatileDirectoryGroup tdir 1 + +----------------- reading data ---------------- +readData :: RqData a -> Request -> Maybe a +readData rqDataReader rq = runReaderT rqDataReader $ (rqInputs rq,rqCookies rq) +readDataDef :: b -> (a -> b) -> RqData a -> Request -> b +readDataDef def f rqDataReader rq = maybe def f . readData rqDataReader $ rq + +dataReaderToWeb :: RqData a -> Request -> WebT IO (Maybe a) +dataReaderToWeb rqDataReader rq = return . readData rqDataReader $ rq +dataReaderToWebDef :: b -> (a -> b) -> RqData a -> Request -> WebT IO b +dataReaderToWebDef def f rqDataReader rq = return . readDataDef def f rqDataReader $ rq + +dataReaderToSp :: RqData a -> ServerPartT IO (Maybe a) +dataReaderToSp rqDataReader = withRequest $ \rq -> dataReaderToWeb rqDataReader rq +dataReaderToSpDef :: b -> (a->b) -> RqData a -> ServerPartT IO b +dataReaderToSpDef def f rqDataReader = withRequest $ \rq -> dataReaderToWebDef def f rqDataReader rq + +alltrue ps x = foldr g True ps + where g p b = b && p x +nonetrue ps x = alltrue (map ( not . ) ps) x + + +-- Do something when the request has exactly one path segment left. +-- lastPathPartSp :: (Request -> String -> WebT IO Response) -> ServerPartT IO Response +lastPathPartSp f = ServerPartT $ \rq -> + case rqPaths rq of + [lastpart] -> f rq lastpart + _ -> noHandle + +ifFirstPathPartSp pathpart f = ServerPartT $ \rq -> + case rqPaths rq of + (x:xs) -> f rq pathpart + _ -> noHandle diff --git a/src/Model.hs b/src/Model.hs --- a/src/Model.hs +++ b/src/Model.hs @@ -1,3 +1,4 @@ +{-# OPTIONS -XPatternSignatures -fno-monomorphism-restriction #-} module Model where import Control.Monad @@ -5,53 +6,39 @@ import HAppS.Server import Session import Misc -import View +import SessionState +-- import UserState +import Control.Monad.Trans -------state data UserAuthInfo = UserAuthInfo String String data NewUserInfo = NewUserInfo String String String instance FromData UserAuthInfo where - fromData = liftM2 UserAuthInfo (look "username") (look "password" `mplus` return "nopassword") + fromData = liftM2 UserAuthInfo (look "username") + (look "password" `mplus` return "nopassword") instance FromData NewUserInfo where - fromData = liftM3 NewUserInfo (look "username") (look "password" `mplus` return "nopassword") (look "password2" `mplus` return "nopassword2") - -entryPoint :: Proxy State -entryPoint = Proxy - --- handlers that affect state -loginPage (UserAuthInfo user pass) = [anyRequest $ do - allowed <- query $ AuthUser user pass - if allowed - then performLogin user - else msgToWeb "Incorrect password" - ] - -performLogin user = do - key <- update $ NewSession (SessionData user) - addCookie (-1) (mkCookie "sid" (show key)) - msgToWeb $ "UserAuthInfo: " ++ show (user) + fromData = liftM3 NewUserInfo (look "username") + (look "password" `mplus` return "nopassword") + (look "password2" `mplus` return "nopassword2") -checkAndAdd user pass = do - exists <- query $ IsUser user - if exists - then msgToWeb $ "User already exists" - else do - update $ ( AddUser user $ User user pass ) - msgToWeb $ "User created." +-- getMbSessKey rq = readData (readCookieValue "sid") rq +getMbSessKey :: Request -> Maybe SessionKey +getMbSessKey rq | traceTrue "getMbSessKey, rq" = traceWith ( ("sidCookie: " ++) . show ) $ readData (readCookieValue "sid") (traceReadableMsg "rq: " rq) -viewPage (Just sid) = [anyRequest $ do - ses <- query $ (GetSession $ sid) - ( ( ioMsgToWeb . withBaseContentW ) $ "Cookie value: " ++ (maybe "not logged in" show (ses :: Maybe SessionData)) :: WebT IO Response)] -viewPage Nothing = - [ msgToSp "Not logged in"] +getmbLoggedInUser :: Request -> IO (Maybe String) +getmbLoggedInUser rq = do + mbSd <- getMbSessData rq + return $ do + sd <- mbSd + Just . sesUser $ sd -newUserPage (NewUserInfo user pass1 pass2) - | pass1 == pass2 = [anyRequest $ do (checkAndAdd user pass1)] - | otherwise = [ msgToSp "Passwords did not match"] +getMbSessData :: Request -> IO (Maybe SessionData) +getMbSessData rq = do + let mbSk = getMbSessKey rq + maybe ( return Nothing ) + ( query . GetSession ) + mbSk -userListPage :: [ServerPartT IO Response] -userListPage = [anyRequest $ do u <- query ListUsers - ( ioMsgToWeb . withBaseContentW ) $ "Users: " ++ (show u)] diff --git a/src/Session.hs b/src/Session.hs --- a/src/Session.hs +++ b/src/Session.hs @@ -1,87 +1,90 @@ -{-# OPTIONS -fglasgow-exts #-} -{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances, - MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, + MultiParamTypeClasses, DeriveDataTypeable, TypeFamilies, + TypeSynonymInstances #-} module Session where import qualified Data.Map as M -import Control.Monad import Control.Monad.Reader import Control.Monad.State (modify,put,get,gets) -import Data.Generics hiding ((:+:)) -import HAppS.Server +import Data.Generics import HAppS.State -import HAppS.Data - -type SessionKey = Integer - -data SessionData = SessionData { - sesUser :: String -} deriving (Read,Show,Eq,Typeable,Data) +import SessionState +import UserState -data Sessions a = Sessions {unsession::M.Map SessionKey a} - deriving (Read,Show,Eq,Typeable,Data) -data State = State { +data TutorialState = TutorialState { sessions :: Sessions SessionData, users :: M.Map String User } deriving (Show,Read,Typeable,Data) -data User = User { - username :: String, - password :: String -} deriving (Show,Read,Typeable,Data) +instance Version TutorialState -instance Version SessionData -instance Version (Sessions a) +$(deriveSerialize ''TutorialState) -$(deriveSerialize ''SessionData) -$(deriveSerialize ''Sessions) +instance Component TutorialState where + type Dependencies TutorialState = End + initialValue = TutorialState { sessions = (Sessions M.empty), + users = M.empty } -instance Version State -instance Version User +authUser :: String -> String -> Query TutorialState Bool +authUser name pass = do + users <- askUsers + return $ (Just pass) == liftM password (M.lookup name users) -$(deriveSerialize ''User) -$(deriveSerialize ''State) -instance Component State where - type Dependencies State = End - initialValue = State (Sessions M.empty) M.empty - -askUsers :: MonadReader State m => m (M.Map String User) +askUsers :: Query TutorialState (M.Map String User) askUsers = return . users =<< ask -askSessions::MonadReader State m => m (Sessions SessionData) +askSessions :: Query TutorialState (Sessions SessionData) askSessions = return . sessions =<< ask -modUsers f = modify (\s -> (State (sessions s) (f $ users s))) -modSessions f = modify (\s -> (State (f $ sessions s) (users s))) +modUsers :: ( M.Map String User -> M.Map String User ) -> Update TutorialState () +modUsers f = modify (\s -> (TutorialState (sessions s) (f $ users s))) + + +modSessions :: (Sessions SessionData -> Sessions SessionData) -> Update TutorialState () +modSessions f = modify (\s -> (TutorialState (f $ sessions s) (users s))) + +isUser :: String -> Query TutorialState Bool isUser name = liftM (M.member name) askUsers + +addUser :: String -> User -> Update TutorialState () addUser name u = modUsers $ M.insert name u -authUser name pass = do - users <- askUsers - return $ (Just pass) == liftM password (M.lookup name users) -listUsers :: MonadReader State m => m [String] -listUsers = liftM M.keys askUsers -setSession key u = do - modSessions $ Sessions . (M.insert key u) . unsession - return () +listUsers :: Query TutorialState [String] +listUsers = liftM M.keys askUsers +newSession :: SessionData -> Update TutorialState SessionKey newSession u = do key <- getRandom - setSession key u + modSessions $ Sessions . (M.insert key u) . unsession return key -getSession::SessionKey -> Query State (Maybe SessionData) -getSession key = liftM ((M.lookup key) . unsession) askSessions +delSession :: SessionKey -> Update TutorialState () +delSession sk = modSessions $ Sessions . (M.delete sk) . unsession -numSessions:: Proxy State -> Query State Int -numSessions = proxyQuery $ liftM (M.size . unsession) askSessions -$(mkMethods ''State ['addUser, 'authUser, 'isUser, 'listUsers, 'setSession, 'getSession, 'newSession, 'numSessions]) +getSession::SessionKey -> Query TutorialState (Maybe SessionData) +getSession key = liftM (M.lookup key . unsession) askSessions +numSessions :: Query TutorialState Int +numSessions = liftM (M.size . unsession) askSessions + +-- define types which are upper case of methods below, eg AddUser, AuthUser... +-- these types work with HApppS query/update machinery +-- in ghci, try :i AddUser +$(mkMethods ''TutorialState + ['addUser + ,'authUser + ,'isUser + , 'listUsers + , 'getSession + , 'newSession + , 'delSession + , 'numSessions] + ) diff --git a/src/SessionState.hs b/src/SessionState.hs new file mode 100644 --- /dev/null +++ b/src/SessionState.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} + +module SessionState where + +import HAppS.State +import Data.Generics +import qualified Data.Map as M + + +type SessionKey = Integer + +data SessionData = SessionData { + sesUser :: String +} deriving (Read,Show,Eq,Typeable,Data) + + +data Sessions a = Sessions {unsession::M.Map SessionKey a} + deriving (Read,Show,Eq,Typeable,Data) + + +instance Version SessionData +instance Version (Sessions a) + +$(deriveSerialize ''SessionData) +$(deriveSerialize ''Sessions) + diff --git a/src/UserState.hs b/src/UserState.hs new file mode 100644 --- /dev/null +++ b/src/UserState.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -XDeriveDataTypeable #-} +{-# LANGUAGE TemplateHaskell #-} +module UserState where +import HAppS.State +import Data.Generics +-- import Data.Typeable +--import Control.Monad.Reader +--import Control.Monad.State + +data User = User { + username :: String, + password :: String +} deriving (Show,Read,Typeable,Data) + +instance Version User + +$(deriveSerialize ''User) diff --git a/src/View.hs b/src/View.hs --- a/src/View.hs +++ b/src/View.hs @@ -1,23 +1,98 @@ -{-# OPTIONS -fglasgow-exts -fno-monomorphism-restriction #-} module View where import Text.StringTemplate import Misc +import Text.StringTemplate +import qualified Data.Map as M +import Data.Char -getTutTemplates = unsafeVolatileDirectoryGroup "templates" 1 -- 1 second reload time +-- 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 --- plug a base templatate with a string which is based on a template file -withBaseTemplateW :: [(String,String)] -> String -> IO (StringTemplate String) -withBaseTemplateW attrs contentTmpl = do - content <- return . toString =<< renderTut attrs contentTmpl - withBaseContentW content +-- 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 --- plug a base template with a string -withBaseContentW :: String -> IO (StringTemplate String) -withBaseContentW content = renderTut [("contentarea",content)] "base" - -renderTut :: [(String,String)] -> String -> IO ( StringTemplate String ) -renderTut attrs tmpl = withTutTemplate ( renderDef attrs tmpl ) +tutlayout' :: IO (STGroup String) -> [(String, String)] -> String -> IO String +tutlayout' f tmplkvs tmpl = do + templates <- f -withTutTemplate :: (STGroup String -> a) -> IO a -withTutTemplate = withTemplateDir "templates" + 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 (/=) [ '-', '_' ] + + + + diff --git a/static/tutorial.css b/static/tutorial.css --- a/static/tutorial.css +++ b/static/tutorial.css @@ -4,17 +4,53 @@ /* p{margin:0 10px 10px} */ -a{color: #006} +/* a{color: green} */ /* 006 */ div#header{position:relative} + +/* div#header h1{ - height:70px;line-height:70px;margin:0; - padding-left:10px;background: #EEE;color: #79B30B} + height:70px; + line-height:70px; + margin:0; + padding-left:10px; + background: #EEE; + color: #79B30B} +*/ + + div#header h4{ margin:0; - padding-left:120px;background: #EEE;} -div#header a{background: #EEE;height:80px} + padding-left:10px; + background: #EEE; + a{color: green} +} + +div#header a { + /* color: green; */ + + +} + +/* menu colors */ +a.menuitem:link {color: blue} +a.menuitem:active {color: blue} +a.menuitem:visited {color: blue} +a.menuitem:hover {color: blue} +a.menuitemselected:link {color: red} +a.menuitemselected:active {color: red} +a.menuitemselected:visited {color: red} +a.menuitemselected:hover {color: red} + + + + + +/* div#header a{background: #EEE;height:80px} */ + + + /* div#content p{line-height:1.4} */ div#content @@ -78,3 +114,4 @@ .btn { background-color:#e9e9e9; border: 1px solid #336699; margin: 0 5px 0 5px; vertical-align: bottom } + diff --git a/templates/base.st b/templates/base.st --- a/templates/base.st +++ b/templates/base.st @@ -1,9 +1,26 @@ -$ header() $ -
| $ tocarea $ | +$ contentarea $ | ++ |
The static file serving example above hints at the templating system used by this tutorial to put together web pages behind the scenes.
-We learn about using-templates next.
+We learn about using templates with HAppS next.
diff --git a/templates/errortemplate.st b/templates/errortemplate.st new file mode 100644 --- /dev/null +++ b/templates/errortemplate.st @@ -0,0 +1,3 @@ + + $ errormsg $ + diff --git a/templates/favoriteAnimal.st b/templates/favoriteAnimal.st deleted file mode 100644 --- a/templates/favoriteAnimal.st +++ /dev/null @@ -1,3 +0,0 @@ -Again, my favorite animal is a $ favoriteAnimal $. (set in another template) --If I forget to set an attribute (favoriteMammal), it just doesn't display: $ favoriteMammal $ diff --git a/templates/footer.st b/templates/footer.st --- a/templates/footer.st +++ b/templates/footer.st @@ -1,6 +1,5 @@
-