happs-tutorial 0.3 → 0.4
raw patch · 74 files changed
+1562/−788 lines, 74 filesdep +HTTPdep +directorydep +filepath
Dependencies added: HTTP, directory, filepath, hscolour, pureMD5
Files
- hackInGhci.sh +2/−2
- happs-tutorial.cabal +47/−20
- runServerWithCompileNLink.sh +1/−1
- src/AppStateGraphBased.hs +161/−0
- src/AppStateSetBased.hs +192/−0
- src/Controller.hs +121/−81
- src/ControllerBasic.hs +18/−4
- src/Main.hs +5/−5
- src/Misc.hs +71/−7
- src/Model.hs +0/−44
- src/SerializeableSessions.hs +29/−0
- src/SerializeableUsers.hs +39/−0
- src/Session.hs +0/−90
- src/SessionState.hs +0/−27
- src/UserState.hs +0/−17
- src/View.hs +151/−62
- static/tutorial.css +5/−0
- templates/accountsettingschanged.st +1/−0
- templates/base.st +2/−2
- templates/basic-url-handling.st +0/−54
- templates/basicurlhandling.st +54/−0
- templates/changepassword.st +26/−0
- templates/consultantprofile.st +12/−0
- templates/consultants.st +11/−0
- templates/consultantswanted.st +9/−0
- templates/editconsultantprofile.st +21/−0
- templates/editjob.st +21/−0
- templates/favoritePlant.st +7/−0
- templates/footer.st +1/−1
- templates/gettingstarted.st +29/−0
- templates/happs-slow-linking-bug.st +0/−37
- templates/happsslowlinkingbug.st +37/−0
- templates/header.st +1/−7
- templates/home.st +37/−32
- templates/job.st +7/−0
- templates/jobs.st +11/−0
- templates/leastFavoriteAnimal.st +3/−0
- templates/login.st +2/−2
- templates/main-function.st +0/−33
- templates/mainfunction.st +56/−0
- templates/mainusermenu.st +3/−0
- templates/menuLoggedIn.st +0/−2
- templates/menubar.st +8/−19
- templates/menubarmenu.st +4/−0
- templates/menulinkgray.st +1/−0
- templates/menulinkselected.st +1/−0
- templates/menulinkunselected.st +1/−0
- templates/missinghappsdocumentation.st +45/−0
- templates/my-favorite-animal.st +0/−10
- templates/myFavoriteAnimal.st +18/−0
- templates/myFavoriteAnimalBase.st +12/−0
- templates/myjobposts.st +4/−0
- templates/paginationlinkselected.st +1/−0
- templates/paginationlinkunselected.st +1/−0
- templates/postnewjob.st +16/−0
- templates/prerequisites.st +10/−2
- templates/register.st +10/−9
- templates/run-tutorial-locally.st +0/−36
- templates/runtutoriallocally.st +36/−0
- templates/simplelink.st +1/−0
- templates/start-happs-on-boot.st +0/−26
- templates/starthappsonboot.st +26/−0
- templates/stringtemplate-basics.st +0/−44
- templates/stringtemplatebasics.st +48/−0
- templates/tableofcontents.st +0/−14
- templates/templates-dont-repeat-yourself.st +0/−69
- templates/templatesdontrepeatyourself.st +69/−0
- templates/thanks.st +9/−0
- templates/toc.st +17/−0
- templates/understanding-happs-types.st +0/−28
- templates/understandinghappstypes.st +29/−0
- templates/view-all-users.st +0/−1
- templates/viewconsultantprofile.st +1/−0
- templates/viewjob.st +1/−0
hackInGhci.sh view
@@ -1,5 +1,5 @@-ghci -isrc src/Main.hs+ghci -iDataGraphInductive -isrc src/Main.hs -#ghci -isrc \+#ghci -iDataGraphInductive -isrc \ # -hide-package HAppS-Server-0.9.2.1 -i/home/thartman/haskellInstalls/smallInstalls/HAppS-Server-0.9.2.1/src \ # src/Main.hs
happs-tutorial.cabal view
@@ -1,5 +1,5 @@ Name: happs-tutorial-Version: 0.3+Version: 0.4 Synopsis: A HAppS Tutorial that is is own demo Description: A nice way to learn how to build web sites with HAppS @@ -25,36 +25,64 @@ -- when cabal install 1.6 comes out, hopefully can use * patterns for templates -- see http://hackage.haskell.org/trac/hackage/ticket/213 Extra-Source-Files:+ runServerWithCompileNLink.sh hackInGhci.sh- -- templates/*.st++ static/tutorial.css static/HAppSTutorialLogo.png++ -- templates/*.st+ templates/accountsettingschanged.st templates/base.st- templates/basic-url-handling.st+ templates/basicurlhandling.st+ templates/changepassword.st+ templates/consultantprofile.st+ templates/consultants.st+ templates/consultantswanted.st+ templates/editconsultantprofile.st+ templates/editjob.st templates/errortemplate.st+ templates/favoritePlant.st templates/footer.st+ templates/gettingstarted.st templates/googleanalytics.st- templates/happs-slow-linking-bug.st+ templates/happsslowlinkingbug.st templates/header.st templates/home.st+ templates/jobs.st+ templates/job.st templates/leastFavoriteAnimal.st templates/login.st- templates/main-function.st+ templates/mainfunction.st+ templates/mainusermenu.st+ templates/menubarmenu.st templates/menubar.st- templates/menuLoggedIn.st+ templates/menulinkgray.st+ templates/menulinkselected.st+ templates/menulinkunselected.st+ templates/missinghappsdocumentation.st templates/moreFavoriteAnimals.st- templates/my-favorite-animal.st+ templates/myFavoriteAnimalBase.st+ templates/myFavoriteAnimal.st+ templates/myjobposts.st templates/newuser.st+ templates/paginationlinkselected.st+ templates/paginationlinkunselected.st+ templates/postnewjob.st templates/prerequisites.st templates/register.st- templates/run-tutorial-locally.st- templates/start-happs-on-boot.st- templates/stringtemplate-basics.st- templates/tableofcontents.st- templates/templates-dont-repeat-yourself.st- templates/understanding-happs-types.st- templates/view-all-users.st+ templates/runtutoriallocally.st+ templates/simplelink.st+ templates/starthappsonboot.st+ templates/stringtemplatebasics.st+ templates/templatesdontrepeatyourself.st+ templates/thanks.st+ templates/toc.st+ templates/understandinghappstypes.st+ templates/viewconsultantprofile.st+ templates/viewjob.st @@ -69,14 +97,13 @@ Misc View Controller - Model - Session- UserState - SessionState- Session+ SerializeableSessions+ SerializeableUsers + AppStateSetBased+ AppStateGraphBased Build-Depends: base >= 3, HStringTemplate, mtl, bytestring, HAppS-Server, HAppS-Data, HAppS-State,- containers, pretty+ containers, pretty, pureMD5, directory, filepath, hscolour, HTTP
runServerWithCompileNLink.sh view
@@ -5,7 +5,7 @@ # rm happs-tutorial src/*.hi src/*.o # time ghc -fwarn-missing-signatures -isrc --make src/Main.hs -o happs-tutorial-time ghc -isrc --make src/Main.hs -o happs-tutorial+time ghc -iDataGraphInductive -isrc --make src/Main.hs -o happs-tutorial beep -r 5
+ src/AppStateGraphBased.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, + MultiParamTypeClasses, DeriveDataTypeable, TypeFamilies,+ TypeSynonymInstances, PatternSignatures #-}++module AppStateGraphBased where ++import qualified Data.Map as M+import qualified Data.Set as S+import Data.List+import Control.Monad.Reader+import Control.Monad.State (modify,put,get,gets)++import Data.Generics+import HAppS.State+++import SerializeableSessions+import SerializeableSocialGraph+import SerializeableUsers++import Misc+import SerializeableTree++{-+DynGraphUqL is class hack datastructure for a graph with unique labels, with functions+for non-unique-labeled graphs hidden from imported Data.Graph.Inductive++(Eg mkGraph, insNode, etc are hidden)++So don't import anything from Data.Graph.Inductive.+Export whatever you need in UniqueLabelsGraph+++class (Ord a, DynGraph gr) => DynGraphUqL a gr where ........+-}+import UniqueLabelsGraph++++-- Think of appdatastore as the database in a traditional web app.+-- Data there gets stored permanently+-- Data in appsessions is stored permanently too, but we don't care as much about its persistence,+-- it's just to keep track of who is logged in at a point in time.+-- appsessions field could be less complicated, just have M.Map Int SessionData+-- don't really see the advantage of declaring a wrapper over map.++-- Works! At least, it compiles :)+data AppState = AppState {+ appsessions :: Sessions SessionData, + appdatastore :: SocialGraph+} deriving (Show,Read,Typeable,Data)+instance Version AppState +$(deriveSerialize ''AppState) +instance Component AppState where + type Dependencies AppState = End + initialValue = AppState { appsessions = (Sessions M.empty),+ appdatastore = SocialGraph empty }++askDatastore = do+ (s :: AppState ) <- ask+ return . appdatastore $ s++askUsersGraph = do+ s <- askDatastore+ return . socialgraph $ s++askUsersSet :: Query AppState (S.Set User) +askUsersSet = do+ g <- askUsersGraph+ return . labelsetFromGraph $ g+++askSessions :: Query AppState (Sessions SessionData)+askSessions = return . appsessions =<< ask++-- modUsers :: ( S.Set User -> S.Set User ) -> Update AppState ()+modGraph :: ( Gr User Float -> Gr User Float ) -> Update AppState ()+modGraph f = modify (\appS -> (AppState (appsessions appS)+ ( SocialGraph . f . socialgraph . appdatastore $ appS)))++modSessions :: (Sessions SessionData -> Sessions SessionData) -> Update AppState ()+modSessions f = modify (\s -> (AppState (f $ appsessions s) (appdatastore s))) ++isUser :: String -> Query AppState Bool+isUser name = do+ return . (S.member name) . (setmap username) =<< askUsersSet++-- I tried to declare a functor instance for Set a but got blocked.+setmap f = S.fromList . map f . S.toList+++addUser :: String -> String -> Update AppState ()+addUser name pass = modGraph $ addLab (User name (scramblepass pass) Nothing Nothing ) ++--modUsers :: ( S.Set User -> S.Set User ) -> Update AppState ()+modUsers f = modify (\s -> (AppState (appsessions s) (f $ appdatastore s)))+++changePassword :: String -> String -> String -> Update AppState ()+changePassword username oldpass newpass = modUsers $ changepasswordPure username oldpass newpass+++-- yowch! modify is delete plus insert? +-- this will work for the time being, but will probably eventually need to be something smarter+-- also it would be nice if the type could reflect the possibility of failure, (Maybe, Either, etc)+-- but can't figure out how to do that smartly+-- modify is simply delete plus insert +changepasswordPure :: String -> String -> String -> SocialGraph -> SocialGraph+changepasswordPure u inputtedOldpass inputtedNewpass (SocialGraph usersgraph ) = + let hashedoldpass = scramblepass inputtedOldpass+ hashednewpass = scramblepass inputtedNewpass+ mbU = lookupUser ( (==u). username) usersgraph + resetP olduser@(User u realoldpass mbCP mbJobs ) =+ if realoldpass == hashedoldpass+ then modLab (const $ User u hashednewpass mbCP mbJobs ) olduser $ usersgraph+ else usersgraph+ in SocialGraph $ maybe usersgraph resetP mbU ++getUser :: String -> Query AppState (Maybe User)+getUser u = do+ askUsersGraph >>=+ return . lookupUser ((==u) . username)++lookupUser f users = find f . S.toList . labelsetFromGraph $ users+++listUsers :: Query AppState [String]+listUsers = liftM (map username . S.toList) askUsersSet+newSession :: SessionData -> Update AppState SessionKey+newSession u = do+ key <- getRandom+ modSessions $ Sessions . (M.insert key u) . unsession+ return key++delSession :: SessionKey -> Update AppState ()+delSession sk = modSessions $ Sessions . (M.delete sk) . unsession+++getSession::SessionKey -> Query AppState (Maybe SessionData)+getSession key = liftM (M.lookup key . unsession) askSessions++numSessions :: Query AppState 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 ''AppState+ ['askUsersSet+ , 'getUser + , 'addUser+ , 'changePassword + , 'isUser+ , 'listUsers+ , 'getSession+ , 'newSession+ , 'delSession+ , 'numSessions]+ )+
+ src/AppStateSetBased.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, + MultiParamTypeClasses, DeriveDataTypeable, TypeFamilies,+ TypeSynonymInstances, PatternSignatures #-}++module AppStateSetBased where ++import qualified Data.Map as M+import qualified Data.Set as S+import Data.List++import Control.Monad.Reader+import Control.Monad.State (modify,put,get,gets)+import Data.Generics+import HAppS.State+import SerializeableSessions+import SerializeableUsers+import Misc+--import Data.Graph.Inductive++-- Think of appdatastore as the database in a traditional web app.+-- Data there gets stored permanently+-- Data in appsessions is stored permanently too, but we don't care as much about its persistence,+-- it's just to keep track of who is logged in at a point in time.+-- appsessions field could be less complicated, just have M.Map Int SessionData+-- don't really see the advantage of declaring a wrapper over map.+data AppState = AppState {+ appsessions :: Sessions SessionData, + appdatastore :: S.Set User+} deriving (Show,Read,Typeable,Data) ++instance Version AppState++$(deriveSerialize ''AppState) ++instance Component AppState where + type Dependencies AppState = End + initialValue = AppState { appsessions = (Sessions M.empty),+ appdatastore = S.empty }+++askDatastore :: Query AppState (S.Set User) +askDatastore = do+ (s :: AppState ) <- ask+ return . appdatastore $ s+++askSessions :: Query AppState (Sessions SessionData)+askSessions = return . appsessions =<< ask++++modUsers :: ( S.Set User -> S.Set User ) -> Update AppState ()+modUsers f = modify (\s -> (AppState (appsessions s) (f $ appdatastore s))) ++modSessions :: (Sessions SessionData -> Sessions SessionData) -> Update AppState ()+modSessions f = modify (\s -> (AppState (f $ appsessions s) (appdatastore s))) ++isUser :: String -> Query AppState Bool+isUser name = do+ return . (S.member name) . (setmap username) =<< askDatastore++-- I tried to declare a functor instance for Set a but got blocked.+setmap f = S.fromList . map f . S.toList++updateUser olduser newuser = modUsers $ updateUserPure olduser newuser+updateUserPure o n users | username o == username n = S.insert n . S.delete o $ users+ | otherwise = error "updateUser, username is not allowed to change"+{-+changeConsultantProfile olduser newcp = modUsers $ changeConsultantProfilePure olduser newcp+changeConsultantProfilePure olduser@(User u p mbCP mbJobs ) newcp users =+ S.insert (User u p newcp mbJobs ) . S.delete olduser $ users+-}++addUser :: String -> String -> Update AppState ()+addUser name pass = modUsers $ S.insert (User name (scramblepass pass) cp []) + where cp = ConsultantProfile "" "" False+changePassword :: User -> String -> String -> Update AppState ()+changePassword u oldpass newpass = modUsers $ changepasswordPure u oldpass newpass++++-- modify is simply delete plus insert +changepasswordPure :: User -> String -> String -> S.Set User -> S.Set User+changepasswordPure olduser@(User u realoldpass mbCP mbJobs ) inputtedOldpass inputtedNewpass users = + let hashedoldpass = scramblepass inputtedOldpass+ hashednewpass = scramblepass inputtedNewpass+ + in if (realoldpass /= hashedoldpass)+ then users+ else do S.insert (User u hashednewpass mbCP mbJobs ) . S.delete olduser $ users++getUser :: String -> Query AppState (Maybe User)+getUser u = return . lookupUserByName u =<< askDatastore++lookupUserByName :: String -> S.Set User -> Maybe User+lookupUserByName u users = lookupUser ((==u) . username) users++-- list the job along with the username who posted the job+listAllJobs :: Query AppState [(Job,String)]+listAllJobs = liftM alljobs askDatastore+ where alljobs users = concatMap userJobs . S.toList $ users+ userJobs (User n _ _ js) = map (\j -> (j,n)) js + ++lookupUser f users = find f . S.toList $ users+listUsers :: Query AppState [String]+listUsers = liftM (map username . S.toList) askDatastore++--listUsersWantingDevelopers = liftM (map username . filter wantingDeveloper . S.toList) askDatastore+-- where wantingDeveloper u = not . null . jobs $ u++newSession :: SessionData -> Update AppState SessionKey+newSession u = do+ key <- getRandom+ modSessions $ Sessions . (M.insert key u) . unsession+ return key++delSession :: SessionKey -> Update AppState ()+delSession sk = modSessions $ Sessions . (M.delete sk) . unsession+++getSession::SessionKey -> Query AppState (Maybe SessionData)+getSession key = liftM (M.lookup key . unsession) askSessions++numSessions :: Query AppState Int+numSessions = liftM (M.size . unsession) askSessions+++ +++--------------dummy data++datastoreDummyData :: S.Set User+datastoreDummyData = S.fromList [+ User "tphyahoo" (scramblepass "password") tphyahooProfile tphyahooJobs+ , User "zzz" (scramblepass "password") (ConsultantProfile "" "" False) serpinskiJobs+ ] ++tphyahooProfile = ConsultantProfile {+ --billing_rate = "it depends on the project"+ contact = "thomashartman1 at gmail, +48 51 365 3957"+ -- tell something about yourself. Edited via a text area. should replace newlines with <br> when displayed.+ , blurb = "I'm currently living in poland, doing a software sabbatical where I'm \+ \learning new things and writing and releasing open source software, including this tutorial."+ , consultant = True +}++tphyahooJobs = map (\(j,b)-> Job { jobname = j, jobbudget = b, jobblurb ="make " ++ j ++ " using HAppS "} ) $+ [ ("darcshub", "$5000")+ , ("community wizard", "$500,000")+ , ("hpaste in happs", "karma points?")+ , ("facebook clone", "$10,000")+ , ("rentacoder clone", "12,000 Eu")+ , ("ebay clone", "")+ , ("reddit clone", "")+ , ("ripplepay clone", "best offer")+ , ("oscommerce clone", "$1500")+ , ("phpbb clone", "")+ , ("sql-ledger clone", "")]+serpinskiJobs = map (\num -> ( Job ("job" ++ (show num)) "$0" "") ) [10..203]++-- create dummy data++initializeDummyData = modUsers g+ where g users = if ( S.null users)+ then datastoreDummyData+ else error failmsg+ failmsg = "initializeDummyData, for safety, only works if there is currently no data in app\+ \Maybe you shouldd first do mv _local _local.bak to get any existing data out of the way."+++-- 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 ''AppState+ ['askDatastore+ , 'getUser + , 'addUser+ , 'changePassword + , 'updateUser+ , 'isUser+ , 'listUsers + , 'listAllJobs+ , 'getSession+ , 'newSession+ , 'delSession+ , 'numSessions+ , 'initializeDummyData]+ )++
src/Controller.hs view
@@ -1,28 +1,39 @@-{-# OPTIONS_GHC -XPatternSignatures -fno-monomorphism-restriction #-}+{-# options_ghc -XPatternSignatures -fno-monomorphism-restriction #-} module Controller where import Control.Monad import Control.Monad.Trans import Data.List+import qualified Data.Map as M+import qualified Data.Set as S+import Data.Maybe import HAppS.Server import Misc +import ControllerMisc --- state-import HAppS.State-import Session-import SessionState-import UserState+import Text.StringTemplate -import View+import System.FilePath -import Model+-- colorizing+import System.Directory+import Data.Char+import qualified Language.Haskell.HsColour.HTML as HTML+import Language.Haskell.HsColour.Colourise (readColourPrefs) +-- state+import StateStuff+import ViewStuff+ import ControllerBasic+import ControllerPostActions+import ControllerGetActions import Debug.Trace-import Data.ByteString (unpack)+--import Data.ByteString (pack,unpack)+import Data.ByteString.Internal -- SPs: ServerParts -- main controller@@ -32,93 +43,122 @@ ++ [ msgToSp "Quoth this server... 404." ] -staticfiles = [ fileservedir "src" - , fileservedir "static" ] + fileservedir d = dir d [ fileServe [] d ] -tutorial = [- exactdir "/" [ tutlayoutSp1 [] "home" ]- , dir "tutorial" [- exactdir "/view-all-users" [ viewAllUsers ]- , lastPathPartSp (\rq tmpl -> ( tutlayoutReq rq []) tmpl ) -- tutlayoutSp [] - , dir "actions" [- dir "login" [ methodSP POST $ withData loginPage ]- , dir "newuser" [ methodSP POST $ do withData newUserPage ]- , dir "logout" [ logoutPage ] - ]- ]- ]--viewAllUsers = do- users <- anyRequest $ query ListUsers- tutlayoutSp1 [("userList", (paint users))] "view-all-users"- where paint xs = intercalate "<p>" xs+tutorial :: [ServerPartT IO Response]+tutorial = [ ServerPartT $ \rq -> do+ ts <- liftIO getTemplates+ mbUName <- liftIO . getmbLoggedInUser $ rq+ mbU <- case mbUName of+ Nothing -> return Nothing+ Just un -> query . GetUser $ un+ + unServerPartT ( multi . tutorialCommon $ RenderGlobals ts mbU ) rq+ ] + +tutorialCommon :: RenderGlobals -> [ServerPartT IO Response]+tutorialCommon rglobs =+ [ exactdir "/" [ ServerPartT $ \_ -> ( return . tutlayoutU rglobs [] ) "home" ]+ , dir "tutorial" [+ dir "consultants" $ viewConsultants rglobs + , dir "consultantswanted" $ viewConsultantsWanted rglobs + , dir "jobs" [ methodSP GET . viewJobs $ rglobs]+ , dir "logout" [ (logoutPage rglobs)] + , dir "changepassword" [ methodSP POST $ changePasswordSP rglobs ] --- A handler that renders a template with the template name specified in the argument-tutlayoutSp1 attrs tmpl = withRequest $ \rq -> ( tutlayoutReq rq attrs ) tmpl + , dir "editconsultantprofile" [ methodSP GET . viewEditConsultantProfile $ rglobs ] + , dir "editconsultantprofile" [ methodSP POST . processformEditConsultantProfile $ rglobs ] --- 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+ , dir "editjob" [ methodSP GET . viewEditJobWD $ rglobs ]+ , dir "deletejob" [ methodSP GET . deleteJobWD $ rglobs ]+ , dir "editjob" [ methodSP POST . processformEditJob $ rglobs ] --- 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 + , dir "postnewjob" [ methodSP POST . processformNewJob $ rglobs ]+ , dir "myjobposts" [ methodSP GET . pageMyJobPosts $ rglobs ]+ , dir "viewprofile" [ methodSP GET . userProfile $ rglobs ]+ , dir "viewjob" [ methodSP GET . viewJob $ rglobs ]+ , dir "initializedummydata" [ spAddDummyData rglobs ]+ , dir "actions" $+ [ dir "login" [ methodSP POST . loginPage $ rglobs ]+ , dir "newuser" [ methodSP POST . newUserPage $ rglobs ]+ ]+ , lastPathPartSp0 (\rq tmpl -> ( return . tutlayoutU rglobs []) 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"+viewConsultants :: RenderGlobals -> [ServerPartT IO Response]+viewConsultants rglobs = [ ServerPartT $ \rq -> do+ consultants :: [String] <- return . map username+ =<< return . filter (consultant . consultantprofile) . S.toList+ =<< query AskDatastore+ let consultantlist =+ paintVMenu . map (\c -> simpleLink (templates rglobs) ("/tutorial/viewprofile?user="++c,c) ) $ consultants+ -- if not logged in, you get an invite to register as a consultant+ -- basically an incentive to register+ tmplattrs = maybe (def ++ [("registerAsConsultant","list yourself as a HAppS developer")])+ (\_ -> def )+ (mbUser rglobs)+ where def = [("consultantList", consultantlist)]+ return . tutlayoutU rglobs tmplattrs $ "consultants" ]- -- 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" )+viewConsultantsWanted :: RenderGlobals -> [ServerPartT IO Response]+viewConsultantsWanted rglobs = [ ServerPartT $ \rq -> do+ consultantswanted :: [String] <- return . map username+ =<< return . filter (not . null . jobs) . S.toList+ =<< query AskDatastore+ let ulist =+ paintVMenu . map (\c -> simpleLink (templates rglobs) ("/tutorial/viewprofile?user="++c,c) ) $ consultantswanted+ + -- an incentive to register+ tmplattrs = maybe (def ++ [("postJob","post a HAppS job")])+ (\_ -> def )+ (mbUser rglobs)+ where def = [("ulist", ulist)]+ return . tutlayoutU rglobs tmplattrs $ "consultantswanted"+ ] -logoutPage :: ServerPartT IO Response-logoutPage = +--logoutPage :: RenderGlobals -> ServerPartT IO Response+logoutPage rglobs@(RenderGlobals ts mbU) = withRequest $ \rq -> do let mbSk = getMbSessKey rq- maybe - ( return () )- ( update . DelSession )+ newRGlobs <-+ maybe + ( return rglobs )+ ( \sk -> do update . DelSession $ sk+ return (RenderGlobals ts Nothing)+ ) 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" -+ ( return . tutlayoutU newRGlobs [] ) "home" +spAddDummyData rglobs = do+ withRequest $ \rq -> (update InitializeDummyData) + ( return . tutlayoutU rglobs [] ) "home" +staticfiles = [ haskellFile [withRequest colorize] + , fileservedir "src" + , fileservedir "static" ] + where + -- Takes the request and tries to find a file from the current directory+ -- based on the request path. Colorizes the file as Haskell and returns the+ -- HTML.+ colorize rq = do+ currDir <- liftIO $ getCurrentDirectory+ let sep = [pathSeparator] -- eg '/' or '\' or whatever + path = intercalate sep ([currDir ++ sep ] ++ rqPaths rq)+ file <- liftIO $ readFile path+ prefs <- liftIO $ readColourPrefs+ let color :: String+ color = HTML.hscolour prefs False False file+ return . toResponse . HtmlString $ color + -- Detects if a request ends in a .hs.+ haskellFile = spsIf endsInHS+ where endsInHS rq =+ let url = rqURL rq+ extension = drop (length url - 3) url+ in extension == ".hs"
src/ControllerBasic.hs view
@@ -132,9 +132,23 @@ 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" + let fp2 :: String+ fp2 = renderTemplateGroup templates [("favoritePlantTwo","Venus Fly Trap")] "favoritePlant"+ r = renderTemplateGroup templates [("favoriteAnimal", "Tyrannasaurus Rex")+ , ("leastFavoriteAnimal","Bambi")+ -- if you set the same template variable several times it+ -- gets repeated when it gets displayed+ -- I think this is reasonable, because it gives you + -- feedback that there's probably a bug in your program+ , ("favoritePlant","Ficus")+ , ("favoritePlant","Wheat")+ , ("favoritePlant","Sugarcane")+ -- note that template variable names must be alpha+ -- favoritePlant2 below would get rejected + , ("fpTwo", fp2)]+ $ "myFavoriteAnimalBase" + return . toResponse . HtmlString $ r+ -- if template key is repeated, only the first value appears+ ]
src/Main.hs view
@@ -3,13 +3,12 @@ module Main where import HAppS.Server-import Model import Controller import Misc import System.Environment-import HAppS.State-import Session +import StateStuff+ main = do -- let p = 5001 let usageMessage = "usage example: happs-tutorial 5001 (starts the app on port 5001)"@@ -21,14 +20,15 @@ -- run the happs server on some port-runserver p = do+runserver p = withProgName "happs-tutorial" $ do startSystemState entryPoint -- start the HAppS state system 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+ where entryPoint :: Proxy AppState entryPoint = Proxy+ runInGhci = do putStrLn $ "happs tutorial running ins ghci. \n" ++ "exit :q ghci completely and reenter ghci, before restarting."
src/Misc.hs view
@@ -6,13 +6,18 @@ import qualified Data.ByteString.Lazy.Char8 as L import Control.Monad.Trans import Data.List-+import qualified Data.Set as S+import Data.Digest.Pure.MD5 import Debug.Trace import Text.PrettyPrint as PP+import Control.Applicative +import System.Directory+import System.FilePath import Text.StringTemplate import Data.Monoid import Control.Monad.Reader+import Data.Char -- for rot13, which we shouldn't be using anyway newtype HtmlString = HtmlString String instance ToMessage HtmlString where@@ -46,14 +51,26 @@ NoHandle -> unWebT b _ -> return a' -renderTemplateGroup :: (STGroup String) -> [(String, String)] -> String -> String+-- Chooses a template from an STGroup, or errors if not found.+-- Renders that template uses attrs, and gives the string.+-- if you don't clean and a template k/v pair is repeated, it appears twice.+-- Possibly this should be a fix inside StringTemplate. Tell sclv?+-- what is the expected StringTemplate behavior according to the original program?+--clean = nubBy (\(a1,b1) (a2,b2) -> a1 == a2) . sortBy (\(a1,b1) (a2,b2) -> a1 `compare` a2)+-- but then again, why should a key be repeated twice? maybe showing a repeat is a good thing+-- as it indicates buggy behavior+-- The ToSElem type is probably either String or [String]+--renderTemplateGroup :: (ToSElem a) => STGroup String -> [(String, a)] -> [Char] -> String+renderTemplateGroup :: STGroup String -> [(String, String)] -> [Char] -> String renderTemplateGroup gr attrs tmpl = - toString $- maybe ( error $ "template not found: " ++ tmpl )- ( setManyAttrib attrs )+ maybe ( "template not found: " ++ tmpl )+ ( toString . setManyAttribSafer attrs ) ( getStringTemplate tmpl gr ) +++ ----------------- reading data ---------------- readData :: RqData a -> Request -> Maybe a readData rqDataReader rq = runReaderT rqDataReader $ (rqInputs rq,rqCookies rq) @@ -73,17 +90,64 @@ alltrue ps x = foldr g True ps where g p b = b && p x nonetrue ps x = alltrue (map ( not . ) ps) x- +pathPartsSp pps f = ServerPartT $ \rq ->+ if rqPaths rq == pps+ then f rq + else noHandle+ -- Do something when the request has exactly one path segment left. -- lastPathPartSp :: (Request -> String -> WebT IO Response) -> ServerPartT IO Response-lastPathPartSp f = ServerPartT $ \rq ->+lastPathPartSp0 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+-}++-- why can't I do this? ask #haskell sometime.+--instance Functor (S.Set a) where+ -- fmap :: (a-> b ) (S.Set a) (S.Set b)+-- fmap f s = S.fromList . map f . S.toList $ s++-- for now just do rot13, but get this working for real. (md5? what do people use?)+scramblepass = show . md5 . L.pack -- map ( chr . (+13) . ord )+++-- HStringTemplate modifications -- copy/paste/tweak from HStringTemplate.+-- same as directoryGroup, but throws an error for template names with punctuation++directoryGroupSafer :: (Stringable a) => FilePath -> IO (STGroup a)+directoryGroupSafer path = groupStringTemplates <$>+ (fmap <$> zip . (map dropExtension)+ <*> mapM (newSTMP <$$> (readFile . (path </>)))+ =<< mapM checkTmplName+ =<< return . filter (not . or . map (=='#') {-naughty emacs backup character-} )+ . filter ( (".st" ==) . takeExtension )+ =<< getDirectoryContents path)+ where checkTmplName t = if ( badTmplVarName . takeBaseName ) t+ then fail $ "safeDirectoryGroup, bad template name: " ++ t+ else return t++(<$$>) :: (Functor f1, Functor f) => (a -> b) -> f (f1 a) -> f (f1 b)+(<$$>) x y = ((<$>) . (<$>)) x y++setManyAttribSafer attrs st = + let mbFoundbadattr = find badTmplVarName . map fst $ attrs+ in maybe (setManyAttrib attrs st)+ (\mbA -> newSTMP . ("setManyAttribSafer, bad template atr: "++) $ mbA)+ mbFoundbadattr+++++badTmplVarName t = or . map (not . isAlpha) $ t++tFromTo = fromTo 10 20 [1..1000] == [10..20] +fromTo fr to xs = take (to-(fr-1)) . drop (fr-1) $ xs
− src/Model.hs
@@ -1,44 +0,0 @@-{-# OPTIONS -XPatternSignatures -fno-monomorphism-restriction #-}-module Model where--import Control.Monad-import HAppS.State-import HAppS.Server-import Session-import Misc-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")--instance FromData NewUserInfo where- fromData = liftM3 NewUserInfo (look "username")- (look "password" `mplus` return "nopassword")- (look "password2" `mplus` return "nopassword2")---- getMbSessKey rq = readData (readCookieValue "sid") rq-getMbSessKey :: Request -> Maybe SessionKey-getMbSessKey rq | traceTrue "getMbSessKey, rq" = traceWith ( ("sidCookie: " ++) . show ) $ readData (readCookieValue "sid") (traceReadableMsg "rq: " rq)--getmbLoggedInUser :: Request -> IO (Maybe String)-getmbLoggedInUser rq = do- mbSd <- getMbSessData rq- return $ do- sd <- mbSd- Just . sesUser $ sd--getMbSessData :: Request -> IO (Maybe SessionData) -getMbSessData rq = do- let mbSk = getMbSessKey rq- maybe ( return Nothing )- ( query . GetSession )- mbSk--
+ src/SerializeableSessions.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}++module SerializeableSessions where++import Data.Generics --for deriving Typeable+import HAppS.State -- for deriving Serialize++++import qualified Data.Map as M+++++type SessionKey = Integer +newtype SessionData = SessionData { + sesUser :: String+} deriving (Read,Show,Eq,Typeable,Data) +instance Version SessionData +$(deriveSerialize ''SessionData)+++++data Sessions a = Sessions {unsession::M.Map SessionKey a} + deriving (Read,Show,Eq,Typeable,Data)+instance Version (Sessions a)+$(deriveSerialize ''Sessions)+
+ src/SerializeableUsers.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, NoMonomorphismRestriction #-}+module SerializeableUsers where+import HAppS.State+import Data.Generics+import qualified Data.Set as S+data Job = Job {jobname :: String+ , jobbudget :: String -- we allow jobs with unspecified budgets+ , jobblurb :: String}+ deriving (Show,Read,Ord, Eq, Typeable,Data)+instance Version Job+$(deriveSerialize ''Job) +++-- Better name would be just "Profile." Users who aren't consultants, eg want consultants for a project,+-- also use profiles. But I'm in a hurry so leaving as is for now and not changing the names everywhere.+data ConsultantProfile = ConsultantProfile {+ --billing_rate :: String -- eg "" (blank is ok), "$30-$50/hour", "40-50 Euro/hour", "it depends on the project", etc.+ contact :: String -- eg, "thomashartman1 at gmail, 917 915 9941"+ -- tell something about yourself. Edited via a text area. should replace newlines with <br> when displayed.+ , blurb :: String + , consultant :: Bool -- this is what actually determines whether the profile will list as a consultant or not+} deriving (Show,Read,Ord, Eq, Typeable,Data)+instance Version ConsultantProfile+$(deriveSerialize ''ConsultantProfile) ++-- Users should also have Maybe a consultant profile, Maybe [list of jobs they want done]+data User = User { + username :: String + , password :: String+ , consultantprofile :: ConsultantProfile+ , jobs :: [Job]+} deriving (Show,Read,Ord, Eq, Typeable,Data)+instance Version User+$(deriveSerialize ''User) +++++
− src/Session.hs
@@ -1,90 +0,0 @@-{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, - MultiParamTypeClasses, DeriveDataTypeable, TypeFamilies,- TypeSynonymInstances #-}--module Session where --import qualified Data.Map as M-import Control.Monad.Reader-import Control.Monad.State (modify,put,get,gets)-import Data.Generics-import HAppS.State-import SessionState-import UserState-- -data TutorialState = TutorialState { - sessions :: Sessions SessionData, - users :: M.Map String User-} deriving (Show,Read,Typeable,Data) --instance Version TutorialState --$(deriveSerialize ''TutorialState) --instance Component TutorialState where - type Dependencies TutorialState = End - initialValue = TutorialState { sessions = (Sessions M.empty),- users = M.empty } --authUser :: String -> String -> Query TutorialState Bool -authUser name pass = do- users <- askUsers- return $ (Just pass) == liftM password (M.lookup name users)---askUsers :: Query TutorialState (M.Map String User) -askUsers = return . users =<< ask--askSessions :: Query TutorialState (Sessions SessionData)-askSessions = return . sessions =<< ask--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 ----listUsers :: Query TutorialState [String]-listUsers = liftM M.keys askUsers--newSession :: SessionData -> Update TutorialState SessionKey-newSession u = do- key <- getRandom- modSessions $ Sessions . (M.insert key u) . unsession- return key--delSession :: SessionKey -> Update TutorialState ()-delSession sk = modSessions $ Sessions . (M.delete sk) . unsession---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]- )
− src/SessionState.hs
@@ -1,27 +0,0 @@-{-# 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)-
− src/UserState.hs
@@ -1,17 +0,0 @@-{-# 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)
src/View.hs view
@@ -1,11 +1,19 @@+{-# 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@@ -14,8 +22,9 @@ -- 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+--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@@ -23,76 +32,156 @@ -- 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 +--tutlayoutSafe tmplkvs basedomain tmpl = tutlayout' (directoryGroup "templates") tmplkvs basedomain tmpl -tutlayout' :: IO (STGroup String) -> [(String, String)] -> String -> IO String-tutlayout' f tmplkvs tmpl = do- templates <- f +getTemplates :: IO (STGroup String)+getTemplates = directoryGroupSafer "templates" - let rendertut kvs tmpl = ( renderTemplateGroup templates ) kvs tmpl+data RenderGlobals = RenderGlobals { templates :: STGroup String,+ mbUser :: Maybe User+ } - 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" +tutlayout :: RenderGlobals -> [([Char], [Char])] -> String -> String+tutlayout (RenderGlobals ts mbU) attrs tmpl0 = + let tmpl = cleanTemplateName tmpl0 - return $ rendertut ( [("tocarea",toc)+ 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" -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 (/=) [ '-', '_' ] +-- 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"
static/tutorial.css view
@@ -43,6 +43,11 @@ a.menuitemselected:visited {color: red} a.menuitemselected:hover {color: red} +a.attention:link {color: orange}+a.attention:active {color: orange}+a.attention:visited {color: orange}+a.attention:hover {color: orange}+
+ templates/accountsettingschanged.st view
@@ -0,0 +1,1 @@+Account Settings Changed Successfully.
templates/base.st view
@@ -3,7 +3,7 @@ <html xmlns="http://www.w3.org/1999/xhtml"> <head> <meta http-equiv="content-type" content="text/html; charset=utf-8" />- <title> HAppS Tutorial </title>+ <title> Real World HAppS: The Cabalized, Self-Demoing HAppS Tutorial </title> <link rel="stylesheet" href="/static/tutorial.css" type="text/css" /> </head> @@ -13,7 +13,7 @@ $ headerarea $ <div id="content"> <table> <tr> <td valign=top width = 200> $ tocarea $ </td> - <td> $ contentarea $ </td>+ <td valign=top> $ contentarea $ </td> <td width=100></td> </tr> </table> </div>
− templates/basic-url-handling.st
@@ -1,54 +0,0 @@-<h3>Basic Request Handling in HAppS</h3>--<p>One of the most basic functions of a web framework is to give you a way of controlling what happens when a web browser makes an http request.</p>--<p>$! Before explaining the theory of request handling in HAppS, !$ Let's look at some simple examples.</p>--<!-- who cares about MVC?... <p>In the <a href="tk">FIX LINK... MVC paradigm</a> employed by Ruby on Rails and other popular frameworks, this is the task of the Controller. </p> -->--<ol>- <li> Read the source code of the simpleHandlers function in <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a> to see how urls are handled in HAppS. <b>Pay attention to the comments!</b>- <li>Follow the urls below by clicking on them. Match what happens when you click on a link with the code in <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a></li>-</ol>--<ul>- <li>introduction to handlers: <a href="/helloworld">hello world</a></li>-- <li>exactdir and msgToSp (subdirectories of the path argument do not match):- <a href="/exactdir-with-msgtosp">exactdir-with-msgtosp</a> ... - <a href="/exactdir-with-msgtosp/subdir">exactdir-with-msgtosp/subdir</a> ... -- </li>- <li>introduction to dir and msgToSp -- subdirectories *do* match:- <a href="/dir-with-msgtosp">dir-with-msgtosp</a> ...- <a href="/dir-with-msgtosp/subdir">dir-with-msgtosp/subdir</a>- </li>- <li>gluing handlers together / handlers as monoids: - <a href="/handleraddition1">handleraddition1</a> ... - <a href="/handleraddition2">handleraddition2</a> ...- <a href="/handleraddition3">handleraddition3</a> ...- <a href="/handleraddition4">handleraddition4</a> ...- <a href="/handleraddition5">handleraddition5</a>- </li>-- <li>the "empty" handler:- <a href="/nohandle1">nohandle1</a> ...- <a href="/nohandle2">nohandle2</a>- </li>-- <li>IO in the response: <a href="/ioaction">IO Response</a> ... - <a href="/ioaction2">Another IO Response</a- </li>- <li>Formatted html: <a href="/htmlAttemptWrong">First attempt at formatted html (wrong)</a> ... - <a href="/htmlAttemptRight">Second attempt at formatted html (right)</a>- </li>-- <li>Serving static files: <a href="/templates/base.st">Using dir and fileserve "templates", we can view templates</a> ... - <a href="/templates/basic-url-handling.st">The template that was used to generate this page</a>- </li>--</ul> --<p>The static file serving example above hints at the templating system used by this tutorial to put together web pages behind the scenes.</p>--<p>We learn about <a href="/tutorial/templates-dont-repeat-yourself">using templates with HAppS</a> next.</p>
+ templates/basicurlhandling.st view
@@ -0,0 +1,54 @@+<h3>Basic Request Handling in HAppS</h3>++<p>One of the most basic functions of a web framework is to give you a way of controlling what happens when a web browser makes an http request.</p>++<p>$! Before explaining the theory of request handling in HAppS, !$ Let's look at some simple examples.</p>++<!-- who cares about MVC?... <p>In the <a href="#">FIX LINK... MVC paradigm</a> employed by Ruby on Rails and other popular frameworks, this is the task of the Controller. </p> -->++<ol>+ <li> Read the source code of the simpleHandlers function in <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a> to see how urls are handled in HAppS. <b>Pay attention to the comments!</b>+ <li>Follow the urls below by clicking on them. Match what happens when you click on a link with the code in <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a></li>+</ol>++<ul>+ <li>introduction to handlers: <a href="/helloworld">hello world</a></li>++ <li>exactdir and msgToSp (subdirectories of the path argument do not match):+ <a href="/exactdir-with-msgtosp">exactdir-with-msgtosp</a> ... + <a href="/exactdir-with-msgtosp/subdir">exactdir-with-msgtosp/subdir</a> ... ++ </li>+ <li>introduction to dir and msgToSp -- subdirectories *do* match:+ <a href="/dir-with-msgtosp">dir-with-msgtosp</a> ...+ <a href="/dir-with-msgtosp/subdir">dir-with-msgtosp/subdir</a>+ </li>+ <li>gluing handlers together / handlers as monoids: + <a href="/handleraddition1">handleraddition1</a> ... + <a href="/handleraddition2">handleraddition2</a> ...+ <a href="/handleraddition3">handleraddition3</a> ...+ <a href="/handleraddition4">handleraddition4</a> ...+ <a href="/handleraddition5">handleraddition5</a>+ </li>++ <li>the "empty" handler:+ <a href="/nohandle1">nohandle1</a> ...+ <a href="/nohandle2">nohandle2</a>+ </li>++ <li>IO in the response: <a href="/ioaction">IO Response</a> ... + <a href="/ioaction2">Another IO Response</a+ </li>+ <li>Formatted html: <a href="/htmlAttemptWrong">First attempt at formatted html (wrong)</a> ... + <a href="/htmlAttemptRight">Second attempt at formatted html (right)</a>+ </li>++ <li>Serving static files: <a href="/templates/base.st">Using dir and fileserve "templates", we can view templates</a> ... + <a href="/templates/basic-url-handling.st">The template that was used to generate this page</a>+ </li>++</ul> ++<p>The static file serving example above hints at the templating system used by this tutorial to put together web pages behind the scenes.</p>++<p>We learn about <a href="/tutorial/templates-dont-repeat-yourself">using templates with HAppS</a> next.</p>
+ templates/changepassword.st view
@@ -0,0 +1,26 @@+<h3> Change Password </h3>++ <form action="/tutorial/changepassword" method="post">+ <table>+ <tr><td>Old Password:</td><td><input type="password" name="oldpass"/></td></tr>++ <tr><td>Password:</td><td><input type="password" name="password"/></td></tr>++ <tr><td>Verify Password:</td><td><input type="password" name="password2"/></td></tr>++ <tr><td><input type="submit" name="change_password" value="Change Password"></td></tr>+ </table>+ </form>+ <font color=red>+ $ errormsgAccountSettings $+ </font>++ $!+ <form action="/tutorial/actions/emailsettings" method="post">+ <table>+ <tr><td>Email:</td><td><input type="textfield" name="oldpass" value = $ email $ ></td></tr>+ <tr><td><input type="submit" name="change_settings" value="Change Settings"></td></tr>+ </table>+ </form>+ !$+
+ templates/consultantprofile.st view
@@ -0,0 +1,12 @@+$! <h3><font color=brown>$ username $</font></h3> !$+<h3><a href=/tutorial/viewprofile?user=$username$>$username$</a></h3>++<font color="red">$ errormsgProfile$</font>++$! <h3><font size=-1>Profile</br></h3> !$+ <p><b>About Me:</b> $ blurb $</p>+ <p><b>Contact: </b> $ contact $ </p> +$!+<h4>Job Posts</h4>+ $ jobsPosted $+!$
+ templates/consultants.st view
@@ -0,0 +1,11 @@+<h3>HAppS Developers+++   <font size=-2>+ <a class="attention" href="/tutorial/register?wantregisterconsult=1"> $ registerAsConsultant $</a></p>+ </font>+</h3>+++<p>The following users wish to be listed as HAppS developers:</p>+$ consultantList $
+ templates/consultantswanted.st view
@@ -0,0 +1,9 @@+<h3>HAppS Developers Wanted+   <font size=-2>+ <a class="attention" href="/tutorial/register?wantregisterconsult=1"> $ registerAsConsultant $ </a></p>+ </font>+</h3>++<p> The following users have posted HAppS jobs:</p>++$ ulist $
+ templates/editconsultantprofile.st view
@@ -0,0 +1,21 @@+<h3>Edit Profile</h3>+ <form action="/tutorial/editconsultantprofile" method="post">+ <table>+ <tr><td>About Me:</td><td><input type="textfield" rows=5 name="consultantblurb" value = $blurb$ ></td></tr>++ <tr><td>Contact:</td><td><input type="textfield" name="contact" value=$contact$ ></td></tr>++ <tr><td>List me on the HAppS developers page:</td>+ <td><input type="checkbox" name="listasconsultant" value="listasconsultant" $listAsConsultantChecked$ ></td></tr> + + <tr><td></td>+ <td><input type="submit" name="submitbtn" value="submit">+ $! <input type="submit" name="editconsultantaction" value="preview"> !$+ $! <input type="submit" name="submitbtn" value="delete consultant profile"> !$+ </td>+ <td></td>+ </tr>+ </table>+ </form>+<hr>+$ profile $
+ templates/editjob.st view
@@ -0,0 +1,21 @@+<h3>Edit Job</h3>+ <form action="/tutorial/editjob" method="post">+ <input type=hidden name="oldjobname" value=$oldJobname$>+ <table>+ <tr><td>Title:</td><td><input type="textfield" rows=5 name="jobtitle" value = $newJobname$ ></td></tr>++ <tr><td>Budget:</td><td><input type="textfield" name="jobbudget" value=$budget$ ></td></tr>++ <tr><td>Description:</td><td><input type="textfield" name="jobdescription" value=$jobblurb$ ></td></tr>++ <tr><td></td>+ <td><input type="submit" name="submitbtn" value="submit">+ $! <input type="submit" name="editconsultantaction" value="preview"> !$+ $! <input type="submit" name="submitbtn" value="delete consultant profile"> !$+ </td>+ <td></td>+ </tr>+ </table>+ </form>+<hr>+$ showJob $
+ templates/favoritePlant.st view
@@ -0,0 +1,7 @@+ <p>+ If I set the same attribute several times, it just shows up repeated.+ I think this is reasonable, because it gives you feedback that there's probably a bug in your program:+ <p>+ Favorite plant: $ favoritePlant $+ <p>+ Favorite plant Two: $ favoritePlantTwo $
@@ -1,5 +1,5 @@ <div id="footer"> copyright thomashartman1 at gmail - <br><a href="http://code.haskell.org/happs-tutorial">use the source</a>+ <br><a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/happs-tutorial">use the source</a> </div>
+ templates/gettingstarted.st view
@@ -0,0 +1,29 @@+<h4>Getting started with HAppS</h4>++<p>If you use Ruby on Rails, Django, Perl Catalyst, PHP, or some other popular web framework, but+have programmed in haskell and would like to use the world's greatest language for your next web project,+just keep reading. I promise by the time you're done you will give you all the knowledge you need.</p>++<p>This tutorial is its own demo. Both the job board part, and the text you are reading this moment.+For best results, you should+<a href="/tutorial/run-tutorial-locally">install and run</a>+it in a local environment where you have control. Then, when you are done+learning, you can use the tutorial code as a starting point for your own+HAppS applications. +</p>++<p>I'm going to repeat myself now. The best way to learn how to use use HAppS with this tutorial is to <a+href="/tutorial/run-tutorial-locally">install and run</a> it in a+local environment. So if you can, do that first.++<p>Getting on with the tutorial proper, our first lesson examines the +<a href="/tutorial/main-function">main function</a> in a HAppS program.+The second lesson explains how to do <a+href="/tutorial/basic-url-handling">basic url handling</a>.+The third lesson covers <a href="/tutorial/templates-dont-repeat-yourself">using templates</a>.</p>++<p>All the lessons can be seen in the left panel.+Lessons that are planned but haven't been written yet are grayed out. +</p>++<p><a href="/tutorial/prerequisites">Installation prerequisites</a></p>
− templates/happs-slow-linking-bug.st
@@ -1,37 +0,0 @@-<h3>HAppS Slow Link Time Workarounds</h3>-<p>-The fact that cabal-installing HAppS takes an hour is-officially a <a-href="http://code.google.com/p/happs/issues/detail?id=29">bug</a>. Hopefully-this situation will be remedied as HAppS matures and, eventually, has-an official release. -<p>-I found this bug pretty problematic when I was experiencing it and I know I'm not the only one. -So, I will share some experiences and observations that will hopefully help others,-and maybe even help diagnose and eventually squash this bug.-<p>-First of all, you don't actually need to compile an executable to run a HAppS server, -and when you run from inside ghci the link time bug has no effect. So for a while I -was doing this, by loading ghci using ./hackInGhci.sh and then running runInGhci inside Main.hs.-<p>-Secondly, at some point this problem went away, and my link time dropped from 5-10 minutes to under 10 seconds.-<p>-This is definitely due to a change in my own code base, not HAppS repo code, since I am only -running against what I cabal installed and not the volatile HAppS library code in darcs.-At some point I intend to attempt a more precise diagnosis-by doing binary cuts on my repo and identifying the changes that seem-to have the biggest impact. I do have some suspicions. -<ul>- <li>Problems are related to Template Haskell and/or Data.Deriving</li>- <li>Splitting up big modules into smaller modules- <br>When I saw link times over 5 minutes I tried to isolate the - "slow" methods in a file called "Slow.hs" so that the linking is only slow when that file changes.- Lately I removed the Slow module since it didn't seem necessary anymore.</li>- <li>Supplying type signatures helps, and the more concrete the type signature the better.- <br>So, (askUsers :: Query TutorialState (M.Map String User) ) rather than (askUsers :: MonadReader State m => m (M.Map String User) )- <br>tentative idea: ghc -fwarn-missing-signatures and give maximally precise signatures everywhere.</li>-</ul>--<p>--The shell command ./runServer.sh, which creates an executable and starts the server, also times the compile & link, and rings a bell when it's done. I figure this will be helpful if slow link times creep back in.
+ templates/happsslowlinkingbug.st view
@@ -0,0 +1,37 @@+<h3>HAppS Slow Link Time Workarounds</h3>+<p>+The fact that cabal-installing HAppS takes an hour is+officially a <a+href="http://code.google.com/p/happs/issues/detail?id=29">bug</a>. Hopefully+this situation will be remedied as HAppS matures and, eventually, has+an official release. +<p>+I found this bug pretty problematic when I was experiencing it and I know I'm not the only one. +So, I will share some experiences and observations that will hopefully help others,+and maybe even help diagnose and eventually squash this bug.+<p>+First of all, you don't actually need to compile an executable to run a HAppS server, +and when you run from inside ghci the link time bug has no effect. So for a while I +was doing this, by loading ghci using ./hackInGhci.sh and then running runInGhci inside Main.hs.+<p>+Secondly, at some point this problem went away, and my link time dropped from 5-10 minutes to under 10 seconds.+<p>+This is definitely due to a change in my own code base, not HAppS repo code, since I am only +running against what I cabal installed and not the volatile HAppS library code in darcs.+At some point I intend to attempt a more precise diagnosis+by doing binary cuts on my repo and identifying the changes that seem+to have the biggest impact. I do have some suspicions. +<ul>+ <li>Problems are related to Template Haskell and/or Data.Deriving</li>+ <li>Splitting up big modules into smaller modules+ <br>When I saw link times over 5 minutes I tried to isolate the + "slow" methods in a file called "Slow.hs" so that the linking is only slow when that file changes.+ Lately I removed the Slow module since it didn't seem necessary anymore.</li>+ <li>Supplying type signatures helps, and the more concrete the type signature the better.+ <br>So, (askUsers :: Query TutorialState (M.Map String User) ) rather than (askUsers :: MonadReader State m => m (M.Map String User) )+ <br>tentative idea: ghc -fwarn-missing-signatures and give maximally precise signatures everywhere.</li>+</ul>++<p>++The shell command ./runServer.sh, which creates an executable and starts the server, also times the compile & link, and rings a bell when it's done. I figure this will be helpful if slow link times creep back in.
templates/header.st view
@@ -4,12 +4,6 @@ <img src="/static/HAppSTutorialLogo.png" alt="HAppS Tutorial"> <a href="http://h-master.net/web2.0/"><font size=1>logo created by the web 2.0 logo generator</font></a> - <h4> - $ menubar() $- + <h4> $ menubar() $ </h4> - </h4>- <h4>- - </h4> </div>
templates/home.st view
@@ -1,45 +1,50 @@-<h3>Why another HAppS Tutorial?</h3>+<h3>Real World HAppS</h3> -<p><a href="http://www.haskell.org">Haskell</a> is a <a href="http://www.google.com/search?hl=en&q=why+haskell">great way to program</a>.</p>+<p>Haskell is a great way to program.</p> -<p>And <a href="http://www.happs.org">HAppS</a> is a great way to build web applications.</p>+<p>And <a href="http://www.happs.org">HAppS</a> is a great way to build+web applications. -<p>I created this tutorial to popularize the use of my favorite language, haskell, in web applications. </p>+<p>Especially if you believe, like I do, that as+modern software systems tend toward ever increasing complexity,+database usage is an unnecessary source of complication that+<a href=http://gilesbowkett.blogspot.com/2007/05/sql-unnecessary-in-haskells-happs.html>should be factored out</a>. -<p>This tutorial is its own demo. For best results, you should-<a href="/tutorial/run-tutorial-locally">install and run</a>-it in a local environment where you have control. Then, when you are done-learning, you can use the tutorial code as a template for your own-HAppS applications. -</p>+<p>Ruby's <a href="http://rubyonrails.com/">rails</a> and python's <a href="http://www.djangoproject.com">django</a> have become popular largely because of their <a href="">object relational mapping</a> systems,+which hide the complexity of database engines by converting application data manipulation logic into sql.+When I first used an ORM, it felt like a huge improvement over writing sql statements every time I wanted to manipulate+an application's state. But pretty soon ORMs started seeming hackish to me too. At some point,+the metaphors I wanted to use just <a href="http://en.wikipedia.org/wiki/Object-Relational_impedance_mismatch">broke down</a>. -<p>If you use Ruby on Rails, Django, Perl Catalyst, PHP, or some other popular web framework, but-have programmed in haskell and would like to use the world's greatest language for your next web project,-this tutorial will give you all the knowledge you need.</p> -<p>As I just said a second ago,-the best way to learn how to use use HAppS with this tutorial is to actually <a-href="/tutorial/run-tutorial-locally">install and run</a> it in a-local environment. --<p>So if you can, do that first.--<p>Getting on with the tutorial proper, our first lesson examines the -<a href="/tutorial/main-function">main function</a> in a HAppS program.-The second lesson explains how to do <a-href="/tutorial/basic-url-handling">basic url handling</a>.-The third lesson covers <a href="/tutorial/templates-dont-repeat-yourself">using templates</a>.</p>--<p>More lessons are planned. This is a work in progress. Stay tuned.</p>--$! <p>Lesson 2 is <a href="/tutorial/using-templates">using templates</a</p> !$- -$! <p>Lesson 3 is <a href="/tutorial/managing-state">managing state</a></p> !$-+$!Or to put it another way, that <a+href=http://gilesbowkett.blogspot.com/2007/05/sql-unnecessary-in-haskells-happs.html>sql+is an ugly hack</a>. !$+<p>+HAppS is haskell's answer to rails and django (and perl's <a href="http://www.catalystframework.org/">catalyst</a>, and <a href="http://www.php.net">php</a>).+$! , and every ORM ever written in the history of software) !$ +With HAppS, there is no wrangling data+structures into and out of the database, because there is no database. You use whatever data+structures are natural to your application, and serialize them+transparently using+<a href="http://www.google.com/search?q=scrap+your+boilerplate">powerful</a>+machinery</a> that's running <a href="http://www.haskell.org/th/">behind the+scenes</a>. And if there are existing databases that you need to connect to, you can do that too -- you're not locked in to using macid for everything. +<p><a href="http://hackage.haskell.org/packages/archive/HAppS-State/0.9.2.1/doc/html/HAppS-State.html#1">MACID</a>,+the HAppS storage mechanism, is no vanilla serialization layer that will+start acting in weird ways when an application has many concurrent users doing possibly conflicting things. +By <a href="http://research.microsoft.com/~simonpj/papers/stm/">leveraging haskell's type system</a> +(see composable memory transactions paper),+you get the same <a href="http://en.wikipedia.org/wiki/ACID">ACID</a> guarantees that+normally only come with a database. </p> +<p>You also get all the <a href="http://www.google.com/search?hl=en&q=why+haskell">goodness</a>+that comes from programming in <a href="http://www.haskell.org">haskell</a>, my favorite language.</p> +<p>In short, HAppS is awesome, and webmonkeys everywhere should use it. Except... +<p>There is this one <a href="/tutorial/missing-happs-documentation">minor detail</a>.
+ templates/job.st view
@@ -0,0 +1,7 @@+<h3><font color=brown>$jobname$</font></h3>+<p>+<ul>+ <li>Budget: $budget$</li>+ <li>Project Summary: $jobblurb$</li>+ <li>Posted by: $postedBy$</li>+</ul>
+ templates/jobs.st view
@@ -0,0 +1,11 @@+<h3>HAppS Jobs+   <font size=-2>+ <a class="attention" href="/tutorial/register?wantpostjob=1"> $ postJob $ </a></p>+ </font>+</h3>+++<p>++$ jobTable $+
templates/leastFavoriteAnimal.st view
@@ -7,5 +7,8 @@ <p>*********** Notice that this template file uses CamelCase rather than dashes to separate words. Otherwise there's an error with included templates. So, in general: avoid template file names with dashes or underscores, and just use CamelCase for templates.+ Numbers are also not allowed. +<br>Try uncommenting the next line and see what you get:+ $! <p>Include least-favorite-animal.st: $ least-favorite-animal.st $ !$
templates/login.st view
@@ -1,9 +1,9 @@ <div id="login"> <form action="/tutorial/actions/login" method="post"> <table>- <tr><td><label>Username:</td> <td><input type="textfield" name="username"/></label></td> </tr>+ <tr><td>Username:</td> <td><input type="textfield" name="username"/></td> </tr> - <tr> <td><label>Password:</td> <td><input type="password" name="password"/></label> </td> </tr>+ <tr> <td>Password:</td> <td><input type="password" name="password"/></td> </tr> <tr> <td> <input type="submit" name="create" value="Log in"> </td> <td> <a href="/tutorial/register">register </a></td>
− templates/main-function.st
@@ -1,33 +0,0 @@-<h3>Where it all begins: the function main</h3>--<p>Have a look at <a href="/src/Main.hs">main</a> function at the core of this web application.</p>--<p>Two bits of code that should jump out at you as being important are "entrypoint" and "controller".</p>--<p>So, open this file in ghci: cd src; ghci Main.hs and have a look at these functions using ghci :i .</p>--<p>*Main> :info entryPoint-<br>entryPoint :: HAppS.Data.Proxy.Proxy Session.State-<br> -- Defined at <a href="/src/Model.hs">Model.hs</a>...-<br>*Main> :i controller-<br>controller :: [ServerPartT IO Response]-<br> -- Defined at <a href="/src/Controller.hs">Controller.hs</a>...-</p>--<p>The entrypoint function has to do with the HAppS state system, and we'll pospone learning about it for later.</p>--<p>The controller function is a list of ServerPartTs, which are basically handlers that-accept an HTTP request and return a response. We look at what is going on in the controller code in-<a href="/tutorial/basic-url-handling">basic url handling</a>, next.-</p>--$! -<p>Now you have a choice about what to read next.</p>--<p>If you are in a hurry to write a HAppS application without delving too much into what's going on behind the scenes,-read , which looks at what's happening in the controller code.</p>--<p>If you want to understand the HAppS type system in more detail, read <a href="understanding-happs-types">understanding HAppS types</a>.-</p>-!$-
+ templates/mainfunction.st view
@@ -0,0 +1,56 @@+<h3>Where it all begins: the function main</h3>++<p>Have a look at <a href="/src/Main.hs">main</a> function at the core of this web application.</p>++<p>Two bits of code that should jump out at you as being important are "entrypoint :: Proxy AppState"+ and "controller".</p>++<p>The entrypoint function has to do with the HAppS state system, and we'll pospone learning about it for later.</p>++<p>To learn more about what the controller function is doing,+ , open this file in ghci: cd src; ghci Main.hs and have a look at these functions using ghci :info .</p>++<p>*Main> :i controller+<br>controller :: [ServerPartT IO Response]+<br> -- Defined at <a href="/src/Controller.hs">Controller.hs</a>...+<br>*Main> :i ServerPartT+<br>newtype ServerPartT m a+<br> = ServerPartT {unServerPartT :: Request -> WebT m a}+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => Monad (ServerPartT m)+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>*Main> :i WebT+<br>newtype WebT m a = WebT {unWebT :: m (Result a)}+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => Monad (WebT m)+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>*Main> :i Result+<br>data Result a+<br> = NoHandle | Ok (Response -> Response) a | Escape Response+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>instance [overlap ok] (Show a) => Show (Result a)+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>+</p>++<p>The controller function is a list of ServerPartTs, which are basically handlers that+accept an HTTP request and return a response. +Well, ok... this is a bit obfuscated by the many types involved in the construction, +and if you want to be pedantic it's probably a bit more complicated than that, but you don't need to understand all+the details at this point. So, for the moment, just think about a ServerPartT as a wrapper+over a function that takes an HTTP request and returns a response.++We look at what is going on in the controller code in+<a href="/tutorial/basic-url-handling">basic url handling</a>, next.+</p>++$! +<p>Now you have a choice about what to read next.</p>++<p>If you are in a hurry to write a HAppS application without delving too much into what's going on behind the scenes,+read , which looks at what's happening in the controller code.</p>++<p>If you want to understand the HAppS type system in more detail, read <a href="understanding-happs-types">understanding HAppS types</a>.+</p>+!$+
@@ -0,0 +1,3 @@+[("/tutorial/editconsultantprofile","my profile")+, ("/tutorial/myjobposts","my job posts")+]
@@ -1,2 +0,0 @@-<a class = "menuitem" href="/tutorial/actions/logout"> logout $ user $ </a>-
@@ -1,25 +1,14 @@ <table><tr> <td> -- <!--- |<a href="/tutorial/about">About</a>- |<a href="/tutorial/faq">FAQ</a>- |<a href="/tutorial/contact">Contact</a>- -->- - <a class="$ menustyleHome $" href="/tutorial/home" class="leftitem">home</a>- |<a class="$ menustyleViewallusers $" href="/tutorial/view-all-users">view all users</a>-- <!-- |<a href="/market/">Marketplace</a>- |<a href="/market/sendmoney">Send Money Abroad</a> -->--+ $ menubarMenu $ </td>- <td width=500>$! td is for alignment only !$</td>- <td> $ userMenu $ </td>- -</tr></table>-+ <td width=250> $! td is for alignment only, an ugly hack, and it renders bad if you resize the window.+ how can I do this better? !$ </td> + <td align=right> $ userMenu $ </td>+</tr>+<tr> <td colsize=3> $mainUserMenu$ </td> $! colsize is wrong, google on correct attribute!$+</tr>+</table>
@@ -0,0 +1,4 @@+[("/tutorial/home","home"),+ ("/tutorial/consultants","happs developers"),+ ("/tutorial/consultantswanted","happs developers wanted"),+ ("/tutorial/jobs","happs jobs")]
@@ -0,0 +1,1 @@+<font color=gray>$anchortext$</font>
@@ -0,0 +1,1 @@+<a class=menuitemSelected href=$url$>$anchortext$</a>
@@ -0,0 +1,1 @@+<a class=menuitem href=$url$>$anchortext$</a>
+ templates/missinghappsdocumentation.st view
@@ -0,0 +1,45 @@+<h3>The missing HAppS documentation, and what to do about it</h3>++<p>Unfortunately, the documentation for HAppS is+<a href="http://forums.somethingawful.com/showthread.php?threadid=2947408">cringeworthy</a>.+So bad that honestly I wouldn't know where to start to fix it.+</p>++<p>+Instead of tackling the documentation probablem directly by doing the obvious thing+and writing patches for haddock, I decided to create an easy-to-install demo project+that included clear step-by-step instructions for getting from zero to final product. I figure what the HAppS+ecosystem needs most, after better documentation, is the opportunity for developers to make real money+doing real work by leveraging this technology. So the demo project is a job board.+It's full of dummy data at the moment, but feel free to post real jobs here if you have them on offer.++$!+Somewhat to my shame, I still haven't learned how HAppS data migrations work,+so every time I release a new version of the tutorial I lose all data -- however, if any real seeming jobs+get posted, I will make sure this doesn't happen. A good explanation of HAppS data migration is my top priority+for the next version anyway. !$+++$! There is a real job board, based on code from this tutorial, at <a href="http://www.fpjobs.com">fpjobs.com</a>. !$++<p>+By the way,+<a href="/tutorial/viewprofile?user=tphyahoo">I am currently available for haskell, HAppS, and startup consulting</a>. +</p>++<p>+My hope is that that this material will tempt people to try HAppS out.+Both curious developers, and investors that want a non-trivial website and are willing to+<a href="http://www.paulgraham.com/avg.html">gamble</a> on a new technology+if it can get the job better, and most importantly, faster.+With enough users, I believe the documentation and other "batteries not included" issues with+HAppS will matter less and less, as the gaps get plugged in a gradual way.++$!+I created this project, the Real +World HAppS Tutorial, to popularize the use of haskell, with HAppS, in web applications. +!$+</p> ++<p><a href="/tutorial/getting-started">Let's get started.</a></p>+
− templates/my-favorite-animal.st
@@ -1,10 +0,0 @@-<html>- My favorite animal is a: $ favoriteAnimal $ (set with setAttribute)- <p>- $ leastFavoriteAnimal() $- <p>- If I forget to set an attribute (favoriteMammal), it just doesn't display: $ favoriteMammal $- <p>- <p>You can comment out parts of a template: $! This Won't Display !$-</html>-
+ templates/myFavoriteAnimal.st view
@@ -0,0 +1,18 @@+ My favorite animal is a: $ favoriteAnimal $ (set with setAttribute)+ <p>+ $ leastFavoriteAnimal() $+ <p>+ If I forget to set an attribute (favoriteMammal), it just doesn't display: $ favoriteMammal $++ <p>This is what happens when an include fails: $ nonexistingTemplate() $++ <p>The next bit includes a template from a template that is already an included template.</p>+ $ favoritePlant() $++ <p>+ You can comment out parts of a template: $! This Won't Display !$+ <p>You can display lists: $ favoriteMinerals $+++ +
+ templates/myFavoriteAnimalBase.st view
@@ -0,0 +1,12 @@+<html>+ $! This is a comment. !$++ <p>The next line is an included template. Look at templates/my-favorite-animal.st</p>++ $ myFavoriteAnimal() $++ <p>The next line shows another strategy for including templates, generating them+ using let bindings in haskell, rather than using parenthesis to make StringTemplate do includes.+ Note that \$ fp2 \$ would be an illegal template var name, so we use fpTwo + $ fpTwo $ +</html>
+ templates/myjobposts.st view
@@ -0,0 +1,4 @@+<h3>My Job Posts</h3>+$ postnewjob() $+$ jobPostsTable $+
+ templates/paginationlinkselected.st view
@@ -0,0 +1,1 @@+<a class=menuitemSelected href=$baselink$?currentpage=$currentpage$&resultsPerPage=$resultsPerPage$> $from$ - $to$ </a>
+ templates/paginationlinkunselected.st view
@@ -0,0 +1,1 @@+<a class=menuitemUnSelected href=$baselink$?currentpage=$currentpage$&resultsPerPage=$resultsPerPage$> $from$ - $to$ </a>
+ templates/postnewjob.st view
@@ -0,0 +1,16 @@+$! <h3>Post New Job</h3> !$+ <form action="/tutorial/postnewjob" method="post">+ <table>+ <tr><td>Title:</td><td><input type="textfield" rows=5 name="jobtitle" value = $jobtitle$ ></td></tr>+ <tr><td>Budget:</td><td><input type="textfield" name="jobbudget" value=$budget$ ></td></tr>+ <tr><td>Description:</td><td><input type="textfield" name="jobdescription" value=$jobdescription$ ></td></tr>++ <tr><td></td>+ <td><input type="submit" name="editjobpostsaction" value="post new job">+ $! <input type="submit" name="editconsultantaction" value="preview">+ <input type="submit" name="editconsultantaction" value="cancel"> !$+ </td>+ <td></td>+ </tr>+ </table>+ </form>
templates/prerequisites.st view
@@ -5,8 +5,16 @@ <ul> <li>Basic knowledge of haskell and html.</li> <li>A somewhat modern computer. I have a PIII laptop with 512M of ram. </li>- <li>A modern operating system. You should be able to develop haskell applications using windows, mac, or linux. For the record, I work with the latest <a href="http://www.ubuntu.com">ubuntu</a> linux distribution, which is currently hardy heron.</li>- <li>If you want to create a public web site based on the materials here, I recommend getting either a private server (more expensive) or a virtual private server (less expensive) which gives you admin priviliges to install the packages and software you need. I use the cheapest virtual private server plan at <a href="http://www.linode.com">linode</a> to host this tutorial publicly. I wouldn't try hosting a HappS project publicly using a shared hoster like <a href="http://www.dreamhost.com">dreamhost</a> that doesn't give you root powers to administer your server. (Dreamhost is great for other things, like cheap storage for online images.)</li>+ <li>A modern operating system. You should be able to develop HAppS applications using windows, mac, or linux.+ <ul>+ <li>Linux Notes: I work with the latest <a href="http://www.ubuntu.com">ubuntu</a> linux distribution,+ which is currently hardy heron. Works for HAppS pretty much out of the box </li>+ <li>Win32 Notes: <a href="http://groups.google.com/group/fa.haskell/browse_thread/thread/e1f1d3bc65074b9c">+ You may have to darcs get HAppS-State head, and/or tweak the cabal file.</a>+ </li>+ </ul>+ + <li>If you want to create a public web site based on the materials here, I recommend getting either a private server (more expensive) or a virtual private server (less expensive) which gives you admin privileges to install the packages and software you need. I use the cheapest virtual private server plan at <a href="http://www.linode.com">linode</a> to host this tutorial publicly. I wouldn't try hosting a HappS project publicly using a shared hoster like <a href="http://www.dreamhost.com">dreamhost</a> that doesn't give you root powers to administer your server. (Dreamhost is great for other things, like cheap storage for online images.)</li> <li>More requirements are described in the instructions for <a href="/tutorial/run-tutorial-locally">installing and running this tutorial locally</a>. However, if you have the basics ingredients above you should be okay.
templates/register.st view
@@ -1,12 +1,13 @@- <form action="/tutorial/actions/newuser" method="post">- <label>Username:<input type="textfield" name="username"/></label>- <br/>- <label>Password:<input type="password" name="password"/></label>- <br/>- <label>Verify Password:<input type="password" name="password2"/></label>- <br/>- <input type="submit" name="create" value="Create Account">- </form>+<h3>Register</h3>+ <form action="/tutorial/actions/newuser" method="post"><table>+ <tr><td>Username:</td><td><input type="textfield" name="username"/></td></tr>+ + <tr><td>Password:</td><td><input type="password" name="password"/></td></tr>++ <tr><td>Verify Password:</td><td><input type="password" name="password2"/></td></tr>++ <tr><td><input type="submit" name="create" value="Create Account"></td></tr>+ </table></form> <font color=red> $ errormsgRegister $ </font>
− templates/run-tutorial-locally.st
@@ -1,36 +0,0 @@-<h3>Run This Tutorial Locally</h3>--<p> Before going further, you may want to inform yourself about the <a href=/tutorial/prerequisites>basic prerequisites</a>, both knowledge and equipment, you need to make the best use of this tutorial </p>--<p>This tutorial is cabalized. You can install and run it simply by doing -<p>cabal install happs-tutorial--<p>The cabal installation may take up to an hour, mainly because the-HAppS-Server installation is slow, but it should succeed in one-shot. This is a symptom of the <a href="/tutorial/happs-slow-linking-bug">HAppS slow linking bug</a>.--<p>If you've never used cabal install or need more detailed info....</p>--<ul>- <li>Haskell: You need at least ghc 6.8.2 to install HAppS. I installed this with with apt-get install haskell (works for ubuntu hardy heron), and then <a href="http://www.haskell.org/ghc/download.html">upgraded to ghc 6.8.3</a> as this is supposed to have fixed some bugs.</li> - <li>Dependency chasing haskell package installers: you should have the latest versions of cabal and cabal install from <a href="http://hackage.haskell.org/packages/archive/pkg-list.html">hackage</a>. These are already included in the latest version of ghc, or they will be soon. Another reason to upgrade to ghc 6.8.3.</li>- <li>If you want to check out the latest version of this tutorial, install <a href="http://www.darcs.net">Darcs</a> and check out the repo with darcs get http://code.haskell.org/happs-tutorial</li>-</ul>--<p>To run the app, either do ./hackInGhci.sh and then execute runInGhci inside Main.hs, or recompile- the executable using ./runServerWithCompileNLink.sh.- Really you only need to be inside ghci if you are experiencing- the <a href="/tutorial/happs-slow-linking-bug">slow link time issue</a>.- This isn't a problem at time of writing but seems to crop up from time to time.-<p>-Shutdown with ctrl-c.-<p>-You should now be able to browse this tutorial offline by running the executable, and opening http://localhost:5001 in your browser.-<p>-You may also want to <a href="start-happs-on-boot">start HAppS on boot</a>.--<p>Next up is the <a href="/tutorial/main-function">HAppS server main function</a>.</p>----
+ templates/runtutoriallocally.st view
@@ -0,0 +1,36 @@+<h3>Run This Tutorial Locally</h3>++<p> Before going further, you may want to inform yourself about the <a href=/tutorial/prerequisites>basic prerequisites</a>, both knowledge and equipment, you need to make the best use of this tutorial </p>++<p>This tutorial is cabalized. You can install and run it simply by doing +<p>cabal install happs-tutorial++<p>The cabal installation may take up to an hour, mainly because the+HAppS-Server installation is slow, but it should succeed in one+shot. This is a symptom of the <a href="/tutorial/happs-slow-linking-bug">HAppS slow linking bug</a>.++<p>If you've never used cabal install or need more detailed info....</p>++<ul>+ <li>Haskell: You need at least ghc 6.8.2 to install HAppS. I installed this with with apt-get install haskell (works for ubuntu hardy heron), and then <a href="http://www.haskell.org/ghc/download.html">upgraded to ghc 6.8.3</a> as this is supposed to have fixed some bugs.</li> + <li>Dependency chasing haskell package installers: you should have the latest versions of cabal and cabal install from <a href="http://hackage.haskell.org/packages/archive/pkg-list.html">hackage</a>. These are already included in the latest version of ghc, or they will be soon. Another reason to upgrade to ghc 6.8.3.</li>+ <li>If you want to check out the latest version of this tutorial, install <a href="http://www.darcs.net">Darcs</a> and check out the repo with darcs get http://code.haskell.org/happs-tutorial</li>+</ul>++<p>To run the app, either do ./hackInGhci.sh and then execute runInGhci inside Main.hs, or recompile+ the executable using ./runServerWithCompileNLink.sh.+ Really you only need to be inside ghci if you are experiencing+ the <a href="/tutorial/happs-slow-linking-bug">slow link time issue</a>.+ This isn't a problem at time of writing but seems to crop up from time to time.+<p>+Shutdown with ctrl-c.+<p>+You should now be able to browse this tutorial offline by running the executable, and opening http://localhost:5001 in your browser.+<p>+You may also want to <a href="start-happs-on-boot">start HAppS on boot</a>.++<p>Next up is the <a href="/tutorial/main-function">HAppS server main function</a>.</p>++++
+ templates/simplelink.st view
@@ -0,0 +1,1 @@+<a href="$url$">$anchortext$</a>
− templates/start-happs-on-boot.st
@@ -1,26 +0,0 @@-<h3>Start HAppS Automatically At Boot Time</h3>--<p>What happens if your HAppS deployment server experiences a power outage?</p>--<p>Or what if the HAppS process just dies for-<a href="http://code.google.com/p/happs/issues/detail?id=40">mysterious reasons?</a>--<p>The way I deal with this both these issues with a public-facing happs application is to have a cron job that runs every minute, that will start the happs application if it isn't running.</p>--<p>- thartman@thartman-laptop:~/happs-tutorial>crontab -l-<br>* * * * * /home/thartman/happs-tutorial/happs-tutorial.cron.sh-<br>-<br>thartman@thartman-laptop:~/happs-tutorial>cat happs-tutorial.cron.sh-<br># this is a workaround to a problem that my happs app dies for reasons described at-<br># http://code.google.com/p/happs/issues/detail?id=40-<br># generate the executable first by running runServer.sh-<br># then add this file to your crontab so you have something like-<br># thartman@thartman-laptop:~>crontab -l-<br># * * * * * /home/thartman/happs-tutorial/happs-tutorial.cron.sh-<br>-<br>if [ -z "`pgrep happs-tutorial`" ];-<br> then cd ~/happs-tutorial-<br> ./happs-tutorial >happs-tutorial.cron.out 2>happs-tutorial.cron.err-<br>fi-</p>
+ templates/starthappsonboot.st view
@@ -0,0 +1,26 @@+<h3>Start HAppS Automatically At Boot Time</h3>++<p>What happens if your HAppS deployment server experiences a power outage?</p>++<p>Or what if the HAppS process just dies for+<a href="http://code.google.com/p/happs/issues/detail?id=40">mysterious reasons?</a>++<p>The way I deal with this both these issues with a public-facing happs application is to have a cron job that runs every minute, that will start the happs application if it isn't running.</p>++<p>+ thartman@thartman-laptop:~/happs-tutorial>crontab -l+<br>* * * * * /home/thartman/happs-tutorial/happs-tutorial.cron.sh+<br>+<br>thartman@thartman-laptop:~/happs-tutorial>cat happs-tutorial.cron.sh+<br># this is a workaround to a problem that my happs app dies for reasons described at+<br># http://code.google.com/p/happs/issues/detail?id=40+<br># generate the executable first by running runServer.sh+<br># then add this file to your crontab so you have something like+<br># thartman@thartman-laptop:~>crontab -l+<br># * * * * * /home/thartman/happs-tutorial/happs-tutorial.cron.sh+<br>+<br>if [ -z "`pgrep happs-tutorial`" ];+<br> then cd ~/happs-tutorial+<br> ./happs-tutorial >happs-tutorial.cron.out 2>happs-tutorial.cron.err+<br>fi+</p>
− templates/stringtemplate-basics.st
@@ -1,44 +0,0 @@-<h3>StringTemplate Basics</h3>--<p>In the previous section we rendered a template in ghci using the following command--<p>*Main Misc View Text.StringTemplate> do templates <- directoryGroup "templates" ; writeFile "output.html" ( renderTemplateGroup templates [] "templates-dont-repeat-yourself" ) --<p>Let's look more carefully at these functions.--<ul>- <li>The directoryGroup function reads in all *.st type files in a directory,- and returns an IO STGroup value, which is basically a group- of StringTemplates.- <br>*Main Misc View Text.StringTemplate> :t (directoryGroup :: String -> IO (STGroup String))- <br>The actual type of directoryGroup is a little less concrete than the above, and uses type classes.- <br>Our :t command gives directoryGroup a concrete type, and since there's no error, we know it typechecks.- <li>renderTemplateGroup takes an STGroup, some template key/value pairs, and a named template, and renders- the template if it is found in the STGroup. If it is not found, an error is returned.- <br>*Main Misc View Text.StringTemplate> :t renderTemplateGroup- <br>renderTemplateGroup :: STGroup String -> [(String, String)] -> String -> String-</ul>--<p>Next, let's look at a slightly more involved example of StringTemplate usage than we've seen so far.--<ul>- <li>The controller: myFavoriteAnimal, in <a href="/src/ControllerBasic.hs">src/ControllerBasic.hs</a>- <br>a snip: <br> renderTemplateGroup templates- <br> [("favoriteAnimal", "Tyrannasaurus Rex")- , ("leastFavoriteAnimal","Bambi")]- \$ "my-favorite-animal" - <li>The rendered page: <a href="/usingtemplates/my-favorite-animal">my favorite animal</a>- <li>The template: <a href="/templates/my-favorite-animal.st">templates/my-favorite-animal.st</a>- <li>An included template: <a href="/templates/leastFavoriteAnimal.st">leastFavoriteAnimal()</a>-</ul>--<p> Try to gain an understanding of the most important features in the StringTemplate system- by getting a sense of how the my-favorite-animal page got generated. </p>--<p> When you're done doing that, you should have enough StringTemplate knowledge to shoot yourself in the foot :)--<p> For a more in depth look at StringTemplate, see the following:--<ul><li>blee- <li>bleh-</ul>
+ templates/stringtemplatebasics.st view
@@ -0,0 +1,48 @@+<h3>StringTemplate Basics</h3>++<p>In the previous section we rendered a template in ghci using the following command++<p>*Main Misc View Text.StringTemplate> do templates <- directoryGroup "templates" ; writeFile "output.html" ( renderTemplateGroup templates [] "templates-dont-repeat-yourself" ) ++<p>Let's look more carefully at these functions.++<ul>+ <li>The directoryGroup function reads in all *.st type files in a directory,+ and returns an IO STGroup value, which is basically a group+ of StringTemplates.+ <br>*Main Misc View Text.StringTemplate> :t (directoryGroup :: String -> IO (STGroup String))+ <br>The actual type of directoryGroup is a little less concrete than the above, and uses type classes.+ <br>Our :t command gives directoryGroup a concrete type, and since there's no error, we know it typechecks.+ <li>renderTemplateGroup takes an STGroup, some template key/value pairs, and a named template, and renders+ the template if it is found in the STGroup. If it is not found, an error is returned.+ <br>*Main Misc View Text.StringTemplate> :t renderTemplateGroup+ <br>renderTemplateGroup :: STGroup String -> [(String, String)] -> String -> String+</ul>++<p>Next, let's look at a slightly more involved example of StringTemplate usage than we've seen so far.++<ul>+ <li>The controller: myFavoriteAnimal, in <a href="/src/ControllerBasic.hs">src/ControllerBasic.hs</a>+ <br>a snip: <br> renderTemplateGroup templates+ <br> [("favoriteAnimal", "Tyrannasaurus Rex")+ , ("leastFavoriteAnimal","Bambi")]+ \$ "myFavoriteAnimalBase" + <li>The rendered page: <a href="/usingtemplates/my-favorite-animal">my favorite animal</a>+ <li>The template: <a href="/templates/myFavoriteAnimalBase.st">templates/myFavoriteAnimalBase.st</a>+ <li>A template included from inside an included templates:+ <a href="/templates/leastFavoriteAnimal.st">leastFavoriteAnimal()</a>+</ul>++<p> Try to gain an understanding of the most important features in the StringTemplate system+ by getting a sense of how the my-favorite-animal page got generated. </p>++<p> When you're done doing that, you should have enough StringTemplate knowledge to shoot yourself in the foot :)++<p> For a more in depth look at StringTemplate, see the following:++<ul><li><a href="http://www.stringtemplate.org/">stringtemplate.org</a>+ <li><a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HStringTemplate-0.2">+ HStringTemplate, a haskell port of StringTemplate on hackage</a>+ <li><a href="http://fmapfixreturn.wordpress.com/tag/hstringtemplate/">fmapfixreturn, Sterling Clover's blog</a>+</ul>+
− templates/tableofcontents.st
@@ -1,14 +0,0 @@--<ul>- <li><a class="$ menustyleHome $" href="/tutorial/home/">happs intro</a>- <li><a class="$ menustylePrerequisites$" href="/tutorial/prerequisites/">prerequisites</a>- <li><a class="$ menustyleRuntutoriallocally $" href="/tutorial/run-tutorial-locally">happs install</a>- <li><a class="$ menustyleMainfunction $" href="/tutorial/main-function">main</a>- <li><a class="$ menustyleBasicurlhandling $" href="/tutorial/basic-url-handling">happs url handling</a>- <li><a class="$ menustyleTemplatesdontrepeatyourself $"- href="/tutorial/templates-dont-repeat-yourself">happs templates</a>- <li><a class="$ menustyleStringtemplatebasics $" href="/tutorial/stringtemplate-basics">stringtemplate basics</a>-- <li><a class="$ menustyleStarthappsonboot $" href="/tutorial/start-happs-on-boot">start happs automatically</a-</ul>-
− templates/templates-dont-repeat-yourself.st
@@ -1,69 +0,0 @@-<h3>Templates -- So You Don't Repeat Yourself</h3>--<p>Every page in this tutorial has certain things in common -- the header and menu bar for example.-You wouldn't want to have have to change the menu bar on every single page if there was a new menu item.--<p>This is why you need a templating system.</p>--<p>HAppS doesn't care much what templating system you use. I use the-<a href="">TK HStringTemplate</a> package to get the job done, so-that's the syntax you'll be seeing in what follows. </p>--<p>-A templating system also helps you individualize output.-The way this works is by inserting variable text into placeholder templates.-For instance, the menu bar in this tutorial displays "logout your_username" if you are logged in,-rather than the login/register options. -The line below does this too, just for teaching purposes. If you are logged in, it will display your username.-</p>--<p> Logged In? Let's see: $ loggedInUser $ </p>--<p>Have a look at the <a href="/templates/templates-dont-repeat-yourself.st">template responsible for the content pane of this page</a>. It's pretty boring, except the line above reads as--<p> " Logged In? Let's see: \$ loggedInUser \$ "--<p>Now, if you are running this tutorial locally, load up ghci by running ./hackInGhci</p>--<p>You can see the effect of-rendering the current content pane by calling--<p> *Main> :m +Misc View Text.StringTemplate--<br>*Main Misc View Text.StringTemplate> do templates <- directoryGroup "templates" ; writeFile "output.html" \$ renderTemplateGroup templates [] "templates-dont-repeat-yourself" --<p>and then opening the file output.html in firefox. (On ubuntu, in ghci, I just do ":! firefox output.html &" and the file opens in a new tab in firefox.)--<p>To see how this page would look if you were logged in: --<p>*Main Misc View Text.StringTemplate> do templates <- directoryGroup "templates" ; writeFile "output.html" \$ renderTemplateGroup templates [("loggedInUser","DarthVader")] "templates-dont-repeat-yourself" --<p>and reopen output.html in your browser.--<p>As you may have noticed, the html written by the above command is only the current content pane, not the header or table of content links. To render the full page from ghci, as it would appear for a logged in user, you can do --<p>*Main Misc View Text.StringTemplate> do html <- tutlayout [("loggedInUser","DarthVader")] "templates-dont-repeat-yourself"; writeFile "output.html" html--<p>If you reload output.htlm, you'll see you are missing the header image and css because you're opening a plain html file-rather than a page being served by happs (which knows where to find the images and css),-but other than that the layout is complete.--<p>You can get a sense for how this all works by looking at the tutlayout function in <a href="/src/View.hs">src/View.hs</a>.--<p>It's not too much fun to develop a web page by outputting a string to a static file and then opening -it in a browser every time something changes, so the next thing you might want to try is actually-modifying the current template (in ./templates/templates-dont-repeat-yourself.st) with some random text,-reloading this actual page, and watching your changes appear.--$!-<p>You might have also noticed that the table of contents-style navigation links in the left pane-change colors depending on what page is selected. You could have a look at the the-<a href="/templates/tableofcontents.st">/templates/tableofcontents.st</a> to get another taste of how templating works.-Here, HAppS looks at each request to determine what the page was called. -If the page matches anything in a certain list, the link class gets set to an "active" value, otherwise it-gets a default value. -!$--<p> We'll learn some <a href="/tutorial/stringtemplate-basics">StringTemplate basics</a> next.</p>--
+ templates/templatesdontrepeatyourself.st view
@@ -0,0 +1,69 @@+<h3>Templates -- So You Don't Repeat Yourself</h3>++<p>Every page in this tutorial has certain things in common -- the header and menu bar for example.+You wouldn't want to have have to change the menu bar on every single page if there was a new menu item.++<p>This is why you need a templating system.</p>++<p>HAppS doesn't care much what templating system you use. I use the+<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HStringTemplate">HStringTemplate</a>+package to get the job done, so that's the syntax you'll be seeing in what follows. </p>++<p>+A templating system also helps you individualize output.+The way this works is by inserting variable text into placeholder templates.+For instance, the menu bar in this tutorial displays "logout your_username" if you are logged in,+rather than the login/register options. +The line below does this too, just for teaching purposes. If you are logged in, it will display your username.+</p>++<p> Logged In? Let's see: $ loggedInUser $ </p>++<p>Have a look at the <a href="/templates/templatesdontrepeatyourself.st">template responsible for the content pane of this page</a>. It's pretty boring, except the line above reads as++<p> " Logged In? Let's see: \$ loggedInUser \$ "++<p>Now, if you are running this tutorial locally, load up ghci by running ./hackInGhci</p>++<p>You can see the effect of+rendering the current content pane by calling++<p> *Main> :m +Misc View Text.StringTemplate++<br>*Main Misc View Text.StringTemplate> do templates <- directoryGroup "templates" ; writeFile "output.html" \$ renderTemplateGroup templates [] "templates-dont-repeat-yourself" ++<p>and then opening the file output.html in firefox. (On ubuntu, in ghci, I just do ":! firefox output.html &" and the file opens in a new tab in firefox.)++<p>To see how this page would look if you were logged in: ++<p>*Main Misc View Text.StringTemplate> do templates <- directoryGroup "templates" ; writeFile "output.html" \$ renderTemplateGroup templates [("loggedInUser","DarthVader")] "templates-dont-repeat-yourself" ++<p>and reopen output.html in your browser.++<p>As you may have noticed, the html written by the above command is only the current content pane, not the header or table of content links. To render the full page from ghci, as it would appear for a logged in user, you can do ++<p>*Main Misc View Text.StringTemplate> do html <- tutlayout [("loggedInUser","DarthVader")] "templates-dont-repeat-yourself"; writeFile "output.html" html++<p>If you reload output.htlm, you'll see you are missing the header image and css because you're opening a plain html file+rather than a page being served by happs (which knows where to find the images and css),+but other than that the layout is complete.++<p>You can get a sense for how this all works by looking at the tutlayout function in <a href="/src/View.hs">src/View.hs</a>.++<p>It's not too much fun to develop a web page by outputting a string to a static file and then opening +it in a browser every time something changes, so the next thing you might want to try is actually+modifying the current template (in ./templates/templates-dont-repeat-yourself.st) with some random text,+reloading this actual page, and watching your changes appear.++$!+<p>You might have also noticed that the table of contents-style navigation links in the left pane+change colors depending on what page is selected. You could have a look at the the+<a href="/templates/tableofcontents.st">/templates/tableofcontents.st</a> to get another taste of how templating works.+Here, HAppS looks at each request to determine what the page was called. +If the page matches anything in a certain list, the link class gets set to an "active" value, otherwise it+gets a default value. +!$++<p> We'll learn some <a href="/tutorial/stringtemplate-basics">StringTemplate basics</a> next.</p>++
+ templates/thanks.st view
@@ -0,0 +1,9 @@+<h3>Thanks to everybody who helped!</h3>++<p>+This tutorial was inspired, and partially based on, blog posts from+<a href="http://softwaresimply.blogspot.com/">mightybyte</a> and+<a href="http://www.dbpatterson.com/">D.B. Patterson</a>.++<p>+Justin Bailey contributed a patch for displaying haskell files colorized.
+ templates/toc.st view
@@ -0,0 +1,17 @@+[("/tutorial/home","happs intro")+ , ("/tutorial/missing-happs-documentation","the missing happs documentation")+ , ("/tutorial/getting-started","getting started with happs")+ , ("/tutorial/prerequisites","prerequisites")+ , ("/tutorial/run-tutorial-locally","cabal install me")+ , ("/tutorial/main-function","main")+ , ("/tutorial/basic-url-handling", "url handling")+ , ("/tutorial/templates-dont-repeat-yourself","templates")+ , ("/tutorial/stringtemplate-basics","stringtemplate basics") + , ("","form post data")+ , ("","querystring get data")+ , ("","macid data")+ , ("","changing the data model")+ , ("/tutorial/start-happs-on-boot","cron jobs")+ , ("/tutorial/thanks","thanks")+]+
− templates/understanding-happs-types.st
@@ -1,28 +0,0 @@--<p>I find it helpful to have ghci tell me about the types in the code I am reading. Here is a snip of ghci output.</p>--<p>-<br>*Main>:i simpleHTTP-<br>simpleHTTP :: (ToMessage a) => Conf -> [ServerPartT IO a] -> IO ()-<br> -- Defined in HAppS.Server.SimpleHTTP-<br>*Main>:i Conf-<br>data Conf = Conf {port :: Int}-<br> -- Defined in HAppS.Server.HTTP.Types-<br>*Main> :i ServerPartT-<br>newtype ServerPartT m a-<br> = ServerPartT {unServerPartT :: Request -> WebT m a}-<br> -- Defined in HAppS.Server.SimpleHTTP-<br>instance [overlap ok] (Monad m) => Monad (ServerPartT m)-<br> -- Defined in HAppS.Server.SimpleHTTP-<br>*Main> :i WebT-<br>newtype WebT m a = WebT {unWebT :: m (Result a)}-<br> -- Defined in HAppS.Server.SimpleHTTP-<br>instance [overlap ok] (Monad m) => Monad (WebT m)-<br> -- Defined in HAppS.Server.SimpleHTTP-</p>--<p>So basically what this tells you is that the meat of a HAppS application is a list of ServerParts, which themselves are a wrapper over a function that takes an HTTP request to a response.</p>--<p>I use ghci info a lot, and you should too as you are learning HAppS. This kind of comfort with the HAppS type system is particularly important at the present time, when the HAppS documentation is relatively sparse</p>--<p>... also read read TK happs-tutorial2 for a more in-depth look at HAppS and the HAppS type system. </p>
+ templates/understandinghappstypes.st view
@@ -0,0 +1,29 @@++<p>I find it helpful to have ghci tell me about the types in the code I am reading. Here is a snip of ghci output.</p>++<p>+<br>*Main>:i simpleHTTP+<br>simpleHTTP :: (ToMessage a) => Conf -> [ServerPartT IO a] -> IO ()+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>*Main>:i Conf+<br>data Conf = Conf {port :: Int}+<br> -- Defined in HAppS.Server.HTTP.Types+<br>*Main> :i ServerPartT+<br>newtype ServerPartT m a+<br> = ServerPartT {unServerPartT :: Request -> WebT m a}+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => Monad (ServerPartT m)+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>*Main> :i WebT+<br>newtype WebT m a = WebT {unWebT :: m (Result a)}+<br> -- Defined in HAppS.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => Monad (WebT m)+<br> -- Defined in HAppS.Server.SimpleHTTP+</p>++<p>So basically what this tells you is that the meat of a HAppS application is a list of ServerParts, which themselves are a wrapper over a function that takes an HTTP request to a response.</p>++<p>I use ghci info a lot, and you should too as you are learning HAppS. This kind of comfort with the HAppS type system is particularly important at the present time, when the HAppS documentation is relatively sparse</p>++<p><a href="http://www.haskell.org/haskellwiki/HAppS_tutorial">HAppsTutorial2</a> at the haskell wiki has a more in-depth+look at thinking behind HAppS and the HAppS type system. </p>
− templates/view-all-users.st
@@ -1,1 +0,0 @@-Users: $ userList $
+ templates/viewconsultantprofile.st view
@@ -0,0 +1,1 @@+$ cp $
+ templates/viewjob.st view
@@ -0,0 +1,1 @@+$ job $