packages feed

happs-tutorial 0.4.3 → 0.4.4

raw patch · 67 files changed

+2101/−1250 lines, 67 filesdep +HAppSHelpersdep +HStringTemplateHelpersdep +old-timedep ~basedep ~hscolourbinary-added

Dependencies added: HAppSHelpers, HStringTemplateHelpers, old-time, parsec, safe

Dependency ranges changed: base, hscolour

Files

hackInGhci.sh view
@@ -1,4 +1,4 @@-ghci -iDataGraphInductive -isrc src/Main.hs+ghci -isrc src/Main.hs  #ghci -iDataGraphInductive -isrc \ #  -hide-package HAppS-Server-0.9.2.1 -i/home/thartman/haskellInstalls/smallInstalls/HAppS-Server-0.9.2.1/src \
happs-tutorial.cabal view
@@ -1,5 +1,5 @@ Name:                happs-tutorial-Version:             0.4.3+Version:             0.4.4 Synopsis:            A HAppS Tutorial that is is own demo Description:         A nice way to learn how to build web sites with HAppS @@ -25,66 +25,11 @@ -- 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+    recompile-and-kill-head.sh     hackInGhci.sh---    static/tutorial.css-    static/HAppSTutorialLogo.png--    -- templates/*.st-    templates/accountsettingschanged.st-    templates/base.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/happsslowlinkingbug.st-    templates/header.st-    templates/home.st-    templates/jobs.st-    templates/job.st-    templates/leastFavoriteAnimal.st-    templates/login.st-    templates/mainfunction.st-    templates/mainusermenu.st-    templates/menubarmenu.st-    templates/menubar.st-    templates/menulinkgray.st-    templates/menulinkselected.st-    templates/menulinkunselected.st-    templates/missinghappsdocumentation.st-    templates/moreFavoriteAnimals.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/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--+    static/*.png+    static/*.css+    templates/*.st  Cabal-Version:       >= 1.2 @@ -93,27 +38,25 @@     hs-source-dirs:         src     Other-Modules:-        AppStateGraphBased         AppStateSetBased         ControllerBasic         ControllerGetActions         Controller         ControllerMisc         ControllerPostActions-        Debugging-        Main         Misc         SerializeableSessions-        SerializeableSocialGraph         SerializeableUsers+        SerializeableJobs+        SerializeableUserInfos+        MiscMap+        ControllerStressTests         StateStuff-        UniqueLabelsGraph         View-        ViewPagination-        ViewStuff-    Build-Depends:   base >= 3, HStringTemplate, mtl, bytestring,+    Build-Depends:   base>=3.0.3.0, HStringTemplate, HStringTemplateHelpers, mtl, bytestring,                      HAppS-Server, HAppS-Data, HAppS-State,-                     containers, pretty, pureMD5, directory, filepath, hscolour, HTTP+                     containers, pretty, pureMD5, directory, filepath, hscolour >= 1.10.1, HTTP, safe,+                     old-time, parsec, HAppSHelpers
+ recompile-and-kill-head.sh view
@@ -0,0 +1,4 @@+# if you run this, the app gets recompiled and killed+# when cron detects the process is gone and restarts, you should have the new app +time ghc -iDataGraphInductive -isrc --make src/Main.hs -o happs-tutorial+sudo pkill -f happs-tutorial-head
− runServerWithCompileNLink.sh 
@@ -1,14 +0,0 @@--# delete this later, this is only for diagnosing slow link times-# at one point, we had almost 10 minute link times, and now it's down to 10 seconds-# So we should do binary cuts on the repo and try to figure out exactly what changed and why-# rm happs-tutorial src/*.hi  src/*.o --# time ghc -fwarn-missing-signatures -isrc --make src/Main.hs -o happs-tutorial-time ghc -iDataGraphInductive -isrc --make src/Main.hs -o happs-tutorial--beep -r 5--./happs-tutorial 5001--
− src/AppStateGraphBased.hs 
@@ -1,161 +0,0 @@-{-# 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
@@ -1,19 +1,24 @@ {-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts,               MultiParamTypeClasses, DeriveDataTypeable, TypeFamilies,-             TypeSynonymInstances, PatternSignatures #-}+             TypeSynonymInstances, ScopedTypeVariables #-}  module AppStateSetBased where   -import qualified Data.Map as M-import qualified Data.Set as S+import qualified MiscMap as M+-- import qualified Data.Set as S+import Data.Maybe  import Data.List -import Control.Monad.Reader+import Control.Monad (liftM)+import Control.Monad.Reader (ask) import Control.Monad.State (modify,put,get,gets) import Data.Generics import HAppS.State+import qualified Data.ByteString.Char8 as B import SerializeableSessions import SerializeableUsers+import SerializeableUserInfos (UserProfile (..), UserInfos (..), add_job, del_job, set_userprofile, set_job )+import SerializeableJobs (Jobs (..), Job (..), JobName(..) ) import Misc --import Data.Graph.Inductive @@ -23,9 +28,17 @@ -- 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.++-- to do: appdatastore should be :: Map UserName User+-- User :: Password ConsultantProfile Jobs+-- Jobs :: Map JobName Job+-- Job :: JobBudget JobBlurb+-- thereafter.......... ++ data AppState = AppState {   appsessions :: Sessions SessionData,  -  appdatastore :: S.Set User+  appdatastore :: Users } deriving (Show,Read,Typeable,Data)                                                          instance Version AppState@@ -35,10 +48,12 @@ instance Component AppState where    type Dependencies AppState = End    initialValue = AppState { appsessions = (Sessions M.empty),-                         appdatastore = S.empty }+                         appdatastore = Users M.empty }  -askDatastore :: Query AppState (S.Set User)                                    +-- myupdate field newval record = record { field = newval }++askDatastore :: Query AppState Users askDatastore = do   (s :: AppState ) <- ask   return . appdatastore $ s@@ -47,127 +62,154 @@ askSessions :: Query AppState (Sessions SessionData) askSessions = return . appsessions =<< ask +setUserProfile :: UserName -> UserProfile -> Update AppState ()+setUserProfile uname newprofile = modUserInfos uname $ set_userprofile newprofile +-- addJob :: UserName -> JobName -> Job -> Update AppState (Either String ())+addJob uname jn j = modUserInfosM uname $ add_job jn j -modUsers :: ( S.Set User -> S.Set User ) -> Update AppState ()-modUsers f = modify (\s -> (AppState (appsessions s) (f $ appdatastore s)))                               +-- delJob :: UserName -> JobName -> Update AppState (Either String ())+delJob uname jn = modUserInfosM uname $ del_job jn +++setJob uname jn j = modUserInfosM uname $ set_job j jn++modUserInfosM :: UserName -> (UserInfos -> Either String UserInfos) -> Update AppState (Either String ())+modUserInfosM un mf = do+  (AppState sessions (Users users)) <- get+  case (M.adjustMM un mf users) of+    Left err -> return . Left $ err+    Right um -> do put $ AppState sessions (Users um)+                   return . Right $ ()++modUserInfos :: UserName -> ( UserInfos -> UserInfos ) -> Update AppState ()+modUserInfos un f = do +  (AppState sessions (Users users)) <- get+  case (M.adjustM un f users) of+    Left err -> fail err+    Right um -> put $ AppState sessions (Users um)++++++--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+-- yecchh.+-- the way setmap is being used seems kludgy+-- should probably either be using HAppS IndexSet, or a Map instead of Set. --- I tried to declare a functor instance for Set a but got blocked.-setmap f = S.fromList . map f . S.toList+isUser :: UserName -> Query AppState Bool+isUser name = do+  (Users us ) <- return . appdatastore =<< ask+  if (isJust $ M.lookup name us)+    then return True+    else return False -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 :: UserName -> B.ByteString -> Update AppState ()+addUser un@(UserName name) hashedpass = do+  AppState s us <- get+  case ( add_user un hashedpass us :: Either String Users) of+    Left err -> fail $ "addUser, name: " ++ (B.unpack name)+    Right newus -> put $ AppState s newus -} -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+addUser :: UserName -> B.ByteString -> Update AppState (Either String ())+addUser un@(UserName name) hashedpass = do+  AppState s us <- get+  case ( add_user un hashedpass us :: Either String Users) of+    Left err -> if isInfixOf "duplicate key" err+                  then return . Left $ "username taken"+                  else return . Left $ "error: " ++ err+    Right newus -> do put $ AppState s newus+                      return $ Right ()  +changePassword :: UserName -> B.ByteString -> B.ByteString -> Update AppState ()+changePassword un oldpass newpass = do+  AppState s us <- get+  case ( set_user_password un (B.pack hashedoldpass) (B.pack hashednewpass) us :: Either String Users) of+    Left err -> fail $ "changePassword"+    Right newus -> put $ AppState s us+  where hashedoldpass = scramblepass (B.unpack oldpass)+        hashednewpass = scramblepass (B.unpack 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+-- was getUser+getUserInfos :: UserName -> Query AppState (Maybe UserInfos)+getUserInfos u = ( return . M.lookup u . users ) =<< askDatastore -lookupUserByName :: String -> S.Set User -> Maybe User-lookupUserByName u users = lookupUser ((==u) . username) users+getUserProfile u = do+  mbUI <- getUserInfos u+  case mbUI of +    Nothing -> return Nothing+    Just (UserInfos pass profile jobs) -> return $ Just profile --- 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 -  +-- list all jobs along with the username who posted each job+-- listAllJobs :: Query AppState (M.Map UserName Jobs)+listAllJobs = return .+                  concat . M.elems+                    . M.mapWithKey g                 +                       . M.map (unjobs . jobs) . users +                           =<< askDatastore +  where g uname jobs = map ( \(jobname,job) -> (jobname,job,uname) ) . M.toList $ jobs -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+-- lookupUser f users = find f . S.toList $ users+listUsers :: Query AppState [UserName]+listUsers = ( return . M.keys . users ) =<< askDatastore +listUsersWantingDevelopers =  (return . M.keys . M.filter wantingDeveloper . users) =<< askDatastore+  where wantingDeveloper uis = not . M.null . unjobs . jobs $ uis+++ newSession :: SessionData -> Update AppState SessionKey-newSession u = do-  key <- getRandom-  modSessions $ Sessions . (M.insert key u) . unsession-  return key+newSession u = do  +  AppState (Sessions ss) us <- get+  (newss,k) <- inssess u ss  +  -- check that random session key is really unique+  --modSessions $ Sessions . (M.insert key u) . unsession+  put $ AppState (Sessions newss) us+  return k+  where+    inssess u sessions = do+      key <- getRandom+      case (M.insertUqM key u sessions) of+        Nothing -> inssess u sessions+        Just m -> return (m,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]+-- initializeDummyData dd = modUsers (const dd)+initializeDummyData dd = do+  AppState ss (Users us) <- get+  if M.null us +    then fail "initializeDummyData, users not empty"+    else put $ AppState ss (Users dd) --- create dummy data+-- bad performance for large unumbers of users (>1000, with 200 jobs/dummy user)+-- maybe macid doesn't like serializing large quantities of data at once+addDummyData dd = do+  AppState ss (Users us) <- get+  put $ AppState ss (Users (M.union us dd) ) -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."+addDummyUser (un,uis) = do+  AppState ss (Users us) <- get+  us' <- M.insertUqM un uis us+  put $ AppState ss (Users us' )   -- define types which are upper case of methods below, eg AddUser, AuthUser...@@ -175,10 +217,12 @@ -- in ghci, try :i AddUser $(mkMethods ''AppState     ['askDatastore-     , 'getUser        +     , 'getUserInfos+     , 'getUserProfile      , 'addUser-     , 'changePassword     -     , 'updateUser+     , 'changePassword +     , 'setUserProfile+     -- , 'updateUser      , 'isUser      , 'listUsers           , 'listAllJobs@@ -186,7 +230,13 @@      , 'newSession      , 'delSession      , 'numSessions-     , 'initializeDummyData]+     , 'initializeDummyData+     , 'addDummyData+     , 'addDummyUser+     , 'addJob+     , 'delJob+     , 'setJob ]  )+
src/Controller.hs view
@@ -1,4 +1,5 @@-{-# options_ghc -XPatternSignatures -fno-monomorphism-restriction #-}+{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}+ module Controller where  import Control.Monad@@ -7,158 +8,108 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe - import HAppS.Server--import Misc -import ControllerMisc- import Text.StringTemplate- import System.FilePath---- 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 View  import ControllerBasic import ControllerPostActions import ControllerGetActions+import ControllerMisc+import ControllerStressTests +import HAppS.Helpers.DirBrowse+import Misc  import Debug.Trace --import Data.ByteString (pack,unpack) import Data.ByteString.Internal +import HAppS.Server.CookieFixer -- SPs: ServerParts  -- main controller-controller :: [ServerPartT IO Response]-controller = {- debugFilter $ -} -    tutorial ++ simpleHandlers ++ [ myFavoriteAnimal ] ++ staticfiles +controller :: Bool -> [ServerPartT IO Response]+controller allowStressTests = {- debugFilter $ -} map cookieFixer $ +    ( tutorial allowStressTests ) ++ simpleHandlers ++ [ myFavoriteAnimal ] ++ staticfiles        ++ [ msgToSp "Quoth this server... 404." ] ----fileservedir d = dir d [ fileServe [] d ]---tutorial :: [ServerPartT IO Response]-tutorial = [ ServerPartT $ \rq -> do+tutorial :: Bool -> [ServerPartT IO Response]+tutorial allowStressTests = [ ServerPartT $ \rq -> do   ts <- liftIO getTemplates-  mbUName <- liftIO . getmbLoggedInUser $ rq-  mbU <- case mbUName of+  mbSess <- liftIO $ getmbSession rq+  let mbUName = return . sesUser =<< mbSess+  mbUis <- case mbUName of            Nothing -> return Nothing-           Just un -> query . GetUser $ un-                         -  unServerPartT ( multi . tutorialCommon  $ RenderGlobals ts mbU ) rq+           Just un -> query . GetUserInfos $ un+  unServerPartT ( multi . (tutorialCommon allowStressTests ) $ RenderGlobals rq ts mbSess ) rq   ]    -tutorialCommon :: RenderGlobals -> [ServerPartT IO Response]-tutorialCommon rglobs =+tutorialCommon :: Bool -> RenderGlobals -> [ServerPartT IO Response]+tutorialCommon allowStressTests rglobs =    [ exactdir "/" [ ServerPartT $ \_ -> ( return . tutlayoutU rglobs [] ) "home"  ]      , dir "tutorial" [-           dir "consultants" $ viewConsultants rglobs -         , dir "consultantswanted" $ viewConsultantsWanted rglobs -         , dir "jobs"   [ methodSP GET . viewJobs $ rglobs]+           dir "consultants" [ methodSP GET $ viewConsultants rglobs]+         , dir "consultantswanted" [ methodSP GET $ viewConsultantsWanted rglobs ]+         , dir "jobs"   [ methodSP GET $ viewJobs rglobs]          , dir "logout" [ (logoutPage rglobs)]           , dir "changepassword" [ methodSP POST $ changePasswordSP rglobs ] -         , dir "editconsultantprofile" [ methodSP GET . viewEditConsultantProfile $ rglobs ]         -         , dir "editconsultantprofile" [ methodSP POST . processformEditConsultantProfile $ rglobs ]+         , dir "editconsultantprofile" [ methodSP GET $ viewEditConsultantProfile rglobs ]         +         , dir "editconsultantprofile" [ methodSP POST $ processformEditConsultantProfile rglobs ] -         , dir "editjob" [ methodSP GET . viewEditJobWD $ rglobs ]-         , dir "deletejob" [ methodSP GET . deleteJobWD $ rglobs ]-         , dir "editjob" [ methodSP POST . processformEditJob $ rglobs ]+         , dir "editjob" [ methodSP GET $ viewEditJobWD rglobs ]+         , dir "deletejob" [ methodSP GET $ deleteJobWD rglobs ]+         , dir "editjob" [ methodSP POST $ processformEditJob rglobs ] -         , 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 "postnewjob" [ methodSP POST $ processformNewJob rglobs ]+         , dir "myjobposts" [ methodSP GET $ pageMyJobPosts rglobs ]+         , dir "viewprofile" [ methodSP GET $ userProfile rglobs ]+         , dir "viewjob" [ methodSP GET $ viewJob rglobs ]           , dir "actions" $-             [ dir "login" [ methodSP POST . loginPage $ rglobs ]-               , dir "newuser" [ methodSP POST . newUserPage $ rglobs ]+                 [ dir "login" [ methodSP POST $ loginPage rglobs ]+                   , dir "newuser" [ methodSP POST $ newUserPage rglobs ]+                   -- , dir "upload" [ methodSP POST $ uploadFilePage rglobs ]+                 ]+         , dir "initializedummydata" [ spAddDummyData rglobs ]+         , dir "stresstest"+             [ -- more realistic, higher stress+               dir "atomicinserts" [ spStressTest  allowStressTests ("atomic inserts",atomic_inserts) rglobs] +               -- faster, insert all users and all jobs in one transaction+               -- fast for small numbers of users, but slow for >1000+               , dir "onebiginsert" [ spStressTest allowStressTests ("one big insert",insertus) rglobs]+               , dir "atomicinsertsalljobs" [ spStressTest allowStressTests ("atomic inserts, all jobs at once",insertusAllJobs) rglobs]               ]-         , lastPathPartSp0 (\rq tmpl -> ( return . tutlayoutU rglobs []) tmpl ) -     ]-   ]             +         , spJustShowTemplate rglobs+     +   ] ]             -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"-  ]+spJustShowTemplate rglobs = lastPathPartSp0 (\_ tmpl -> return $ tutlayoutU rglobs [] tmpl )  -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"-  ]+spStressTest allowStressTest insertf rglobs = +  if allowStressTest +    then lastPathPartSp0 $ \_ numusers -> do+         n <- safeRead numusers+         stressTest' insertf n rglobs+    else return $ tutlayoutU rglobs [("errormsg", failmsgStressTest)] "errortemplate" ---logoutPage :: RenderGlobals -> ServerPartT IO Response-logoutPage rglobs@(RenderGlobals ts mbU) = -  withRequest $ \rq -> do-    let mbSk = getMbSessKey rq-    newRGlobs <--      maybe -         ( return rglobs )-         ( \sk -> do update . DelSession $ sk-                     return (RenderGlobals ts Nothing)-         )-         mbSk-    ( return . tutlayoutU newRGlobs [] ) "home" +failmsgStressTest = "<br>-- Stress is blocked from happening on this happs server.\+     \<br>-- For your own stress testinr, run like ./happs-tutorial 5001 True (the second arg controls the stress test)"  -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 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"+staticfiles = [ staticserve "static"+                , staticserve "userdata"+                , browsedirHS "projectroot" "."+                , browsedirHS "templates" "templates"+                , browsedirHS "src" "src" +              ] ++staticserve d = dir d [ fileServe [] d ]+
src/ControllerBasic.hs view
@@ -1,9 +1,9 @@-{-# OPTIONS -XPatternSignatures #-} module ControllerBasic where   import HAppS.Server import Misc import Data.Monoid+import Text.StringTemplate.Helpers import Control.Monad.Trans import Text.StringTemplate  @@ -101,10 +101,13 @@    , (exactdir "/htmlAttemptWrong"                   [msgToSp "first try at displaying <font color=\"red\">red formatted</font> html (wrong)"])+   , (exactdir "/htmlAttemptRight"                   [ ( msgToSp . HtmlString ) "second attempt at displaying <font color=\"red\">red formatted</font> html (right)"]) -  , dir "templates" [fileServe [] "templates"]+  , (exactdir "/htmlAttemptForeignChars"+                  [ ( msgToSp . HtmlString ) $ +                      "<html><head></head><body><font color=red>some foreign chars: ä ö ü</font></body></html>"])    , dir "dirdemo" [ msgToSp "dir match. subpages will work" ] @@ -131,7 +134,7 @@ myFavoriteAnimal =    exactdir "/usingtemplates/my-favorite-animal"             [ ServerPartT $ \rq ->-            liftIO $ do templates <- directoryGroup "templates"+            liftIO $ do templates <- directoryGroupSafer "templates"                         let fp2 :: String                             fp2 = renderTemplateGroup templates [("favoritePlantTwo","Venus Fly Trap")] "favoritePlant"                             r = renderTemplateGroup templates [("favoriteAnimal", "Tyrannasaurus Rex")
src/ControllerGetActions.hs view
@@ -1,100 +1,198 @@-{-# LANGUAGE PatternSignatures, NoMonomorphismRestriction #-} module ControllerGetActions where  import Control.Monad import Control.Monad.Reader- import HAppS.Server-+import Data.List+import HAppS.Helpers.HtmlOutput+import qualified Data.ByteString.Char8 as B+import Text.StringTemplate.Helpers import ControllerMisc- import StateStuff-import ViewStuff-import Data.List-import qualified Data.Set as S+import View+import FromDataInstances  import Misc+import qualified MiscMap as M  --- This could be a lot less verbose, and use shorter variable names,--- but it's the tutorial instructional example for using FromData to deal with forms, so no harm.-data JobsPaginationUrlData = JobsPaginationUrlData { jpCurrPage :: Int, jpResultsPerPage :: Int }-instance FromData JobsPaginationUrlData where-    fromData =-        let readerCurrpage,readerResultsPerPage :: ReaderT ([(String, Input)], [(String, Cookie)]) Maybe Int-            readerCurrpage = return . read -- convert string to int-                               =<< look "currentpage" `mplus` return "1" -- get string from urlencoded get string-            readerResultsPerPage = return . read =<< look "resultsPerPage" `mplus` return "10"               +viewConsultants :: RenderGlobals -> ServerPartT IO Response+viewConsultants rglobs = withData $ \(PaginationUrlData currB resPB currP resPP) -> [ ServerPartT $ \rq -> do+  consultants <- return . map unusername+                               =<< return . M.keys . M.filter (consultant . userprofile) . users+                                  =<< query AskDatastore+  let p = Pagination { currentbar = currB+                       , resultsPerBar = resPB+                       , currentpage = currP+                       , resultsPerPage = resPP+                       , baselink = "tutorial/consultants"+                       , paginationtitle = ""}  -            readerJobsPaginationUrlData :: ReaderT ([(String,Input)], [(String,Cookie)]) Maybe JobsPaginationUrlData-            readerJobsPaginationUrlData = liftM2 JobsPaginationUrlData readerCurrpage readerResultsPerPage-        in  readerJobsPaginationUrlData    +      -- 1-column table+      consultantCells = map ( (:[]) . userlink ) $ consultants+      consultantTable = paintTable Nothing consultantCells (Just p)+       +      -- 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 )+                        (return . sesUser =<< mbSession rglobs)+        where def = [("consultantList", consultantTable)]+  return . tutlayoutU rglobs tmplattrs $ "consultants"+  ] ---viewJobs :: RenderGlobals -> Pagination -> [ServerPartT IO Response]-viewJobs rglobs  = withData $ \(JobsPaginationUrlData currP resPP) -> +viewConsultantsWanted :: RenderGlobals -> ServerPartT IO Response+viewConsultantsWanted rglobs = withData $ \(PaginationUrlData currB resPB currP resPP) -> [ ServerPartT $ \rq -> do+  consultantswanted <- return . map unusername . M.keys+                                     =<< return . M.filter (not . M.null . unjobs . jobs ) . users +                                       =<< query AskDatastore+  let p = Pagination { currentbar = currB+                       ,resultsPerBar = resPB+                       , currentpage = currP+                       , resultsPerPage = resPP+                       , baselink = "tutorial/consultantswanted"+                       , paginationtitle = ""} ++      consultantCells = map ( (:[]) . userlink  ) $ consultantswanted+      consultantTable = paintTable Nothing consultantCells (Just p)+      +      -- an incentive to register+      tmplattrs = maybe (def ++ [("postJob","post a HAppS job")])+                        (\_ -> def )+                        (return . sesUser =<< mbSession rglobs)+        where def = [("ulist", consultantTable)]+  return . tutlayoutU rglobs tmplattrs $ "consultantswanted"+  ]++viewJobs :: RenderGlobals -> ServerPartT IO Response+viewJobs rglobs  = withData $ \(PaginationUrlData currB resPB currP resPP) ->    [ ServerPartT $ \rq -> do    rsListAllJobs <- query ListAllJobs  -  let jobTable = paintAllJobsTable rglobs rsListAllJobs currP resPP+  let pag = Pagination { currentbar = currB+                       , resultsPerBar = resPB+                       , currentpage = currP+                       , resultsPerPage = resPP+                       , baselink = "tutorial/jobs"+                       , paginationtitle = "Job Results: "}+      jobCells = map f rsListAllJobs+        where f (JobName j', (Job budget blurb), UserName postedBy) = let j = B.unpack j' in +                [ joblink postedBy j+                  , B.unpack budget+                  , userlink postedBy+                ]+      paintAllJobsTable rglobs jobCells p = +        paintTable (Just ["<b>project</b>","<b>budget</b>","<b>posted by</b>"])+                   jobCells+                   (Just p)+      jobTable = paintAllJobsTable rglobs jobCells pag       -- if not logged in, you get invited to post a job,       -- basically an incentive to register        -- this next line should be coming from a template, and it's duplicated elsewhere, slightly bad.-      tmplattrs = maybe (def++[("postJob","post a HAppS job")]) (\_ -> def) (mbUser rglobs)+      tmplattrs = maybe (def++[("postJob","post a HAppS job")]) (\_ -> def) (return . sesUser =<< mbSession rglobs)         where def = [("jobTable",  jobTable)]   return . tutlayoutU rglobs tmplattrs $ "jobs"   ] +-- better name would be just viewEditProfile, since everyone gets a profile, not just consultants.+viewEditConsultantProfile :: RenderGlobals -> ServerPartT IO Response        +viewEditConsultantProfile rglobs = ServerPartT $ \rq -> do        +   case (return . sesUser =<< mbSession rglobs) of+    Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate"+    Just currU -> do      +      mbUis <- query $ GetUserInfos currU +      case mbUis of+        Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user infos")] $ "errortemplate"+        Just uis -> do+          let cp = userprofile uis              +               +          uimage <- liftIO $ avatarimage currU +              -- use show below to properly escape quotes+          let showPr = paintProfile rglobs (B.unpack . unusername $ currU) cp uimage+              attrs = [ ("username", B.unpack . unusername $ currU)+                        , ("userimage", uimage)         +                        , ("blurb", {-quote . -} B.unpack . blurb $ cp)+                        -- , ("jobsPosted",jobsPosted)+                        , ("contact", {-quote . -} B.unpack . contact $ cp)+                        , ("listAsConsultantChecked", checkedStringIfTrue $ consultant cp )+                        , ("profile",showPr)+                          ]+          return $ tutlayoutU rglobs attrs "editconsultantprofile" -data JobLookup = JobLookup {postedBy:: String, jobName :: String}-instance FromData JobLookup where-    fromData = liftM2 JobLookup (look "user")-                                (look "job")+viewEditJob :: UserName -> JobName -> RenderGlobals -> ServerPartT IO Response+viewEditJob pBy jN rglobs = ServerPartT $ \_ -> do        +    case ( return . sesUser =<< mbSession rglobs )of+      Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"+      Just currU -> do+        if currU /= pBy+           then return $ tutlayoutU rglobs+                  [("errormsg", "error: " ++ (B.unpack . unjobname $ jN) ++ " not posted by " ++ (B.unpack . unusername $ currU) )]+                    "errortemplate"+           else do+             mbJ <- lookupJob pBy jN +             case mbJ of+               Nothing -> return $ tutlayoutU rglobs+                            [ ( "errormsg", "error, bad job: " ++ (show $ (pBy,jN) ) ) ] "errortemplate"+               Just j -> do let attrs = [ ("jobname", quote . B.unpack . unjobname $ jN)+                                        , ("budget", quote . B.unpack . jobbudget $ j)+                                        , ("jobblurb", quote . B.unpack . jobblurb $ j)+                                        , ("showJob",paintjob rglobs pBy (jN,j) )+                                      ]+                            return $ tutlayoutU rglobs attrs "editjob" ++lookupJob pBy jN = do+  mbUis <- ( query . GetUserInfos ) pBy +  case mbUis of+    Nothing -> return Nothing+    Just uis -> return $ M.lookup jN $ (unjobs . jobs $ uis)++pageMyJobPosts :: RenderGlobals -> ServerPartT IO Response+pageMyJobPosts rglobs = ServerPartT $ \rq -> do        +  mbUis <- getGlobsUserInfos rglobs -- (query . GetUserInfos) =<< ( return . mbUser $ rglobs )+  case (mbUis :: Either String (UserName,UserInfos)) of+    Left err -> return . tutlayoutU rglobs [("errormsg", err)] $ "errortemplate"+    Right  (currU,uis) -> do+          let jobPostsTable = paintUserJobsTable rglobs (unusername $ currU) (M.toList . unjobs . jobs $ uis) 1 20+          return $ tutlayoutU rglobs [("jobPostsTable",jobPostsTable)] "myjobposts"++getGlobsUserInfos :: Monad m => RenderGlobals -> WebT IO (m ( UserName,UserInfos) )+getGlobsUserInfos rglobs = do+  case (return . sesUser =<< mbSession rglobs) of+    Nothing -> fail "getUserInfos, no user in globals"+    Just un -> do+      mbUis <- query $ GetUserInfos un+      case mbUis of+        Nothing -> return $ fail "getUserInfos, no user infos"+        Just uis -> return $ return (un,uis)+ viewJob rglobs  =   withData $ \(JobLookup pBy jN) ->     [ ServerPartT $ \rq -> do         mbJ <- lookupJob pBy jN          case mbJ of           Nothing -> return $ tutlayoutU rglobs [("errmsg", "no job found")] "errortemplate"-          Just j -> return $ tutlayoutU rglobs [("job",paintjob rglobs pBy j)] "viewjob"+          Just j -> return $ tutlayoutU rglobs [("job",paintjob rglobs pBy (jN,j) )] "viewjob"           ] -lookupJob pBy jN = do-  appUsers <- query AskDatastore-  return $ do u <- find ( (==pBy) . username) . S.toList $ appUsers-              find ( (==jN) . jobname) $ jobs u----data UserNameUrlString = UserNameUrlString {profilename :: String}-instance FromData UserNameUrlString where-    fromData = liftM UserNameUrlString (look "user")- userProfile rglobs =    withData $ \(UserNameUrlString user) ->     [ ServerPartT $ \rq -> do -        mbCP <- do mbU <- query (GetUser user)  -                   return $ do u <- mbU-                               return . consultantprofile $ u+        mbCP <- do mbUis <- query (GetUserInfos user)  +                   return $ do uis <- mbUis+                               return . userprofile $ uis          case mbCP of-          Nothing -> return $ tutlayoutU rglobs [("errormsgProfile", "bad user: " ++ user)] "viewconsultantprofile"-          Just cp  -> return . tutlayoutU rglobs [("cp",paintProfile rglobs user cp)] $ "viewconsultantprofile"+          Nothing -> return $ tutlayoutU rglobs [("errormsgProfile", "bad user: " ++ (B.unpack . unusername $ user) )] "viewconsultantprofile"+          Just cp  -> do+            userimg <- liftIO $ avatarimage user+            return $ tutlayoutU rglobs [("cp", paintProfile rglobs (B.unpack . unusername $ user) cp userimg)] +                       "viewconsultantprofile"     ] ---pageMyJobPosts rglobs = ServerPartT $ \rq -> do        -  let r = renderTemplateGroup (templates rglobs)-  case mbUser rglobs of-    Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate"-    Just currU -> do-          let jobPostsTable = paintUserJobsTable rglobs (username currU) (jobs currU) 1 20-          return $ tutlayoutU rglobs [("jobPostsTable",jobPostsTable)] "myjobposts"- -- viewEditJob :: RenderGlobals -> ServerPartT IO Response         viewEditJobWD rglobs = withData $ \(JobLookup pBy jN) -> [viewEditJob pBy jN rglobs] deleteJobWD rglobs = withData $ \(JobLookup pBy jN) -> [deleteJob pBy jN rglobs]@@ -102,66 +200,13 @@ -- there's a lot of repeated code for viewEdit and Delete of jobs.  -- maybe can consolidate deleteJob pBy jN rglobs = ServerPartT $ \rq -> do        -    case mbUser rglobs of-      Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"-      Just currU@(User n p cp js) -> do-        if (username currU) /= pBy-           then return $ tutlayoutU rglobs [("errormsg", "error: " ++ jN ++ " not posted by " ++ (username currU) )]-                           "errortemplate"-           else do-             mbJ <- lookupJob pBy jN -             case mbJ of-               Nothing -> return $ tutlayoutU rglobs-                            [ ( "errormsg", "error, bad job: " ++ (show $ (pBy,jN) ) ) ] "errortemplate"-               Just j -> do -- deleting a job by filtering a list seems wrong.-                            -- probably should have used a Set rather than a list.-                            -- but whatever, it works.-                            let newjobs = filter (not . (==jN) . jobname) js-                                newuser = User n p cp newjobs-                            updateUserSp rglobs newuser pageMyJobPosts rq--viewEditJob pBy jN rglobs = ServerPartT $ \_ -> do        -    case mbUser rglobs of+    case (return . sesUser =<< mbSession rglobs) of       Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"       Just currU -> do-        if (username currU) /= pBy-           then return $ tutlayoutU rglobs [("errormsg", "error: " ++ jN ++ " not posted by " ++ (username currU) )]-                           "errortemplate"-           else do-             mbJ <- lookupJob pBy jN -             case mbJ of-               Nothing -> return $ tutlayoutU rglobs-                            [ ( "errormsg", "error, bad job: " ++ (show $ (pBy,jN) ) ) ] "errortemplate"-               Just j -> do let -- use show below to properly escape quotes-                                attrs = [ ("oldJobname", show . jobname $ j)-                                        , ("newJobname", show . jobname $ j)-                                        , ("budget", show . jobbudget $ j)-                                        , ("jobblurb", show . jobblurb $ j)-                                        , ("showJob",paintjob rglobs pBy j)-                                      ]-                            return $ tutlayoutU rglobs attrs "editjob" ----viewEditConsultantProfile :: RenderGlobals -> ServerPartT IO Response        -viewEditConsultantProfile rglobs = ServerPartT $ \rq -> do        -  case mbUser rglobs of-    Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate"-    Just currU -> do-      let cp = consultantprofile currU -      let showPr = paintProfile rglobs (username currU) cp -          listAsConsultantChecked = if consultant cp-                                      then "checked"-                                      else ""-          -- use show below to properly escape quotes-          attrs = [ ("blurb", show . blurb $ cp)-                        -- , ("jobsPosted",jobsPosted)-                        , ("contact",show . contact $ cp)-                        , ("listAsConsultantChecked", listAsConsultantChecked)-                        , ("profile",showPr)-                      ]-      return $ tutlayoutU rglobs attrs "editconsultantprofile"---+        if currU /= pBy+           then return $ tutlayoutU rglobs+                  [("errormsg", "error: " ++ (B.unpack . unjobname $ jN) ++ " not posted by " ++ (B.unpack . unusername $ currU) )]+                    "errortemplate"+           else do update $ DelJob currU jN+                   unServerPartT (pageMyJobPosts rglobs ) rq
src/ControllerMisc.hs view
@@ -3,35 +3,116 @@ import HAppS.Server  import Misc-import ViewStuff-import StateStuff +import View+import StateStuff+import Text.StringTemplate+import SerializeableJobs+import SerializeableUsers+import Control.Monad+import Control.Monad.Error+import HAppS.Helpers+import qualified Data.ByteString.Char8 as B+import Text.StringTemplate.Helpers+-- import SerializeableUsers (User(..)) -- 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 tutlayoutU rglobs attrs tmpl = ( toResponse . HtmlString . tutlayout rglobs attrs ) tmpl --- getMbSessKey rq = readData (readCookieValue "sid") rq-getMbSessKey :: Request -> Maybe SessionKey-getMbSessKey rq = readData (readCookieValue "sid") rq--getmbLoggedInUser :: Request -> IO (Maybe String)+{-+getmbLoggedInUser :: Request -> IO (Maybe UserName) getmbLoggedInUser rq = do-  mbSd <- getMbSessData rq+  mbSd <- maybe ( return Nothing )+            ( query . GetSession )+            ( getMbSessKey rq )   return $ do     sd <- mbSd     return . sesUser $ sd+  where +-}+getmbSession :: Request -> IO (Maybe SessionData)+getmbSession rq = maybe ( return Nothing ) ( query . GetSession ) ( getMbSessKey rq ) -getMbSessData :: Request -> IO (Maybe SessionData)                          -getMbSessData rq = do-  maybe ( return Nothing )-        ( query . GetSession )-        ( getMbSessKey rq ) --- updateUserSp :: RenderGlobals -> User -> User -> (RenderGlobals -> ServerPartT IO Response) -> WebT IO Response-updateUserSp rglobs newuser withrgSp rq = do+-- to do: make it so keeps your current page if you login/logout+-- probably modify RenderGlobals to keep track of that bit of state+--startsess' :: RenderGlobals -> UserName -> WebT IO Response++-- The user argument could be bytestring rather than say, UserName, to keep things generic+-- This way we could have different types of users, say UserName users and AdminUserName users.+-- But for now, keep UserName.+startsess' ::+  --(HAppS.Server.SURI.ToSURI uri) =>+  (Request -> String) -> RenderGlobals -> UserName -> WebT IO Response+startsess' getLandingpage (RenderGlobals origRq ts _) user = do+  let sd = SessionData user+  key <- update $ NewSession sd+  addCookie (3600) (mkCookie "sid" (show key))+  let newRGlobs = RenderGlobals origRq ts (Just sd) +  let lp = getLandingpage origRq+  redirectToUrl lp ++getLoggedInUserInfos :: RenderGlobals -> ErrorT String (WebT IO) (UserName,UserInfos)+getLoggedInUserInfos (RenderGlobals _ _ Nothing) = fail "getLoggedInUserInfos, not logged in"+getLoggedInUserInfos (RenderGlobals _ _ (Just (SessionData uN))) = do+  loggedInUserInfos <- ErrorT . return .+                               maybe (Left $ "bad user" ++ (B.unpack . unusername $ uN)) Right+                                 =<< (query $ GetUserInfos uN)+  return (uN,loggedInUserInfos)+++-- getMbSessKey rq = readData (readCookieValue "sid") rq+getMbSessKey :: Request -> Maybe SessionKey+getMbSessKey rq = readData (readCookieValue "sid") rq++-- updateUserSp :: RenderGlobals -> UserName -> (RenderGlobals -> ServerPartT IO Response) -> Request -> WebT IO Response+-- take the current user and replace him with newuser. +-- and what to do in the sp after the update.+-- ugh! rewrite!+-- updateUserSp rglobs newuser withrgSp rq = do+{-+updateUserSp rglobs action withrgSp rq = do   case mbUser rglobs of       Nothing -> return $ tutlayoutU rglobs [("errormsg", "updateUserSp: no user")] "errortemplate"-      Just olduser -> do update (UpdateUser olduser newuser)+      Just uname -> do+        mbUis <- query $ GetUser uname+        case mbUis of+          Nothing -> return $ tutlayoutU rglobs [("errormsg", "updateUserSp: no user infos")] "errortemplate"+          Just uis -> + updateuser olduser newuser                          let newrglobs = RenderGlobals (templates rglobs) (Just newuser)                          unServerPartT ( withrgSp newrglobs ) rq +-}+++updateuser olduser newuser = do+  --update (UpdateUser olduser newuser)+  undefined+  return newuser+++-- IO action: templates are loaded from templates dir for every handle.+-- Alternative is to read templates once at application start time,+-- but then if you make changes in the templates dir they won't be reflected unless you stop/start the server+-- Option b might be appropriate for situations where there is high traffic and changes to templates rarely happen+-- and it's ok to stop/start server if necessary.+getTemplates :: IO (STGroup String)+getTemplates = directoryGroupSafer "templates"+++--very, VERY hackish way of reading a checkbox+readcheckbox :: String -> RqData Bool+readcheckbox checkboxname = return . not . (=="noval") =<< look checkboxname `mplus` return "noval"++logoutPage :: RenderGlobals -> ServerPartT IO Response+logoutPage rglobs@(RenderGlobals origRq ts mbU) =+  withRequest $ \rq -> do+    newRGlobs <-+      maybe+         ( return rglobs )+         ( \sk -> do update . DelSession $ sk+                     return (RenderGlobals origRq ts Nothing)+         )+         (getMbSessKey rq)+    ( return . tutlayoutU newRGlobs [] ) "home"
src/ControllerPostActions.hs view
@@ -1,169 +1,232 @@+{-# LANGUAGE ScopedTypeVariables #-} module ControllerPostActions where  import Control.Monad import Control.Monad.Trans+import Data.List (isInfixOf)+import qualified Data.ByteString.Char8 as B+import Control.Monad.Error ++import System.FilePath (takeFileName) import HAppS.Server+import HAppS.Helpers  import StateStuff-import ViewStuff-+import View import Misc import ControllerMisc import ControllerGetActions+import FromDataInstances -data UserAuthInfo = UserAuthInfo String String-instance FromData UserAuthInfo where-    fromData = liftM2 UserAuthInfo (look "username")-                                   (look "password" `mplus` return "nopassword")-loginPage rglobs  =+loginPage = loginPage' authUser (startsess' getLoginReferer)+  where authUser = authUser' getUserPassword+        getUserPassword name = return . maybe Nothing (Just . B.unpack . password)+                                 =<< query (GetUserInfos name)+        -- after login, just redirect to the last page we were on.+        +        -- try to return the referral, if can't parse it from headers, return home page+        getLoginReferer :: Request -> String+        getLoginReferer rq = +          let homepage = getAppUrl "" rq+              etRef = getHeaderVal "referer" rq+          in  case etRef of +                Left _ -> homepage+                Right rf -> if isInfixOf "logout" rf+                  then homepage+                  else rf++loginPage' :: (UserName -> B.ByteString -> WebT IO Bool)+                -> (RenderGlobals -> UserName -> WebT IO Response) +              -> RenderGlobals -> ServerPartT IO Response+loginPage' auth sessW' rglobs =   withData $ \(UserAuthInfo user pass) -> -    [ ServerPartT $ \rq -> do-      mbUser <- authUser user pass+    [ ServerPartT $ \_ -> do+        loginOk <- auth user pass+        if loginOk+          then sessW' rglobs user+          else errW "login error: invalid username or password"+    ]             +  where errW msg = return $ tutlayoutU rglobs [("loginerrormsg",msg)] "home" -      case mbUser of -        Nothing -> ( return . tutlayoutU rglobs [("errormsg","login error: invalid username or password")] ) "home"-        Just u ->  startsess rglobs u-        -    ]+{-+-- check if a username and password is valid. If it is, return the user as successful monadic value+-- otherwise fail monadically+authUser :: Monad m => UserName -> B.ByteString -> WebT IO (m UserInfos)+authUser name pass = do+  mbUser <- query (GetUserInfos name)+  case mbUser of+    Nothing -> return . fail $ "login failed"+    (Just u) -> do+       p <- return . password $ u+       -- scramblepass works with lazy bytestrings, maybe that's by design. meh, leave it for now+       if p == scramblepass pass +         then return . return $ u+         else return . fail $ "login failed"+-} -data ChangeUserInfo = ChangeUserInfo String String String -instance FromData ChangeUserInfo where-    fromData = liftM3 ChangeUserInfo ( (look "oldpass") `mplus` (return "no old password") )-                                     (look "password" `mplus` return "no password")-                                     (look "password2" `mplus` return "no password2")+-- to do: make it so keeps your current page if you login/logout+-- probably modify RenderGlobals to keep track of that bit of state+{-+startsess :: RenderGlobals -> UserName -> WebT IO Response+startsess (RenderGlobals ts _) user = do+  key <- update $ NewSession (SessionData user)+  addCookie (3600) (mkCookie "sid" (show key))+  let newRGlobs = RenderGlobals ts (Just user) +  (return . tutlayoutU newRGlobs [] ) "home"+-} ++-- check if a username and password is valid. If it is, return the user as successful monadic value+-- otherwise fail monadically+authUser' :: (UserName -> WebT IO (Maybe String) ) -> UserName -> B.ByteString -> WebT IO Bool+authUser' getpwd name pass = do+  mbP <- getpwd name+  -- scramblepass works with lazy bytestrings, maybe that's by design. meh, leave it for now+  -- to do: we need to use a seed, there was a discussion about this on haskell cafe.+  return $ maybe False ( == scramblepass (B.unpack pass) ) mbP+++{- changePasswordSP rglobs = withData $ \(ChangeUserInfo oldpass newpass1 newpass2) -> [ ServerPartT $ \rq -> do     if newpass1 == newpass2         then do mbL <- liftIO $ getmbLoggedInUser rq                maybe                  (errW "Not logged in" rq)-                 (\u -> do mbU <- query (GetUser u)-                           case mbU of-                             Nothing -> errW ("bad username: " ++ u) rq -                             Just user -> do update $ ChangePassword user oldpass newpass1+                 (\u -> do mbUis <- query (GetUserInfos u)+                           case mbUis of+                             Nothing -> errW ("bad username: " ++ (B.unpack . unusername $ u)) rq +                             Just uis  -> do update $ ChangePassword u oldpass newpass1                                              return $ tutlayoutU rglobs [] "accountsettings-changed" )-                 mbL+                 (mbL :: Maybe UserName)        else errW "new passwords did not match" rq   ]   where errW msg rq = ( return . tutlayoutU rglobs [("errormsgAccountSettings", msg)] ) "changepassword" +-}+changePasswordSP rglobs = withData $ \(ChangeUserInfo oldpass newpass1 newpass2) -> [ ServerPartT $ \rq -> do+    etRes <- runErrorT $ getLoggedInUserInfos rglobs+    case etRes of+      Left e -> errW e+      Right (u,_) -> do+        if newpass1 /= newpass2+           then errW "new passwords did not match"+           else do update $ ChangePassword u oldpass newpass1+                   return $ tutlayoutU rglobs [] "accountsettings-changed"+  ]+  where errW msg = ( return . tutlayoutU rglobs [("errormsgAccountSettings", msg)] ) "changepassword"  -instance FromData ConsultantProfile where-    fromData = liftM3 ConsultantProfile ( (look "contact") `mplus` (return "") )-                                                (look "consultantblurb")-                                                --very, VERY hackish way of reading a checkbox-                                                ( return . not . (=="noval")-                                                    =<< look "listasconsultant" `mplus` return "noval" )- -                                                 --- should reuse auth code from change password processformEditConsultantProfile rglobs =-  withData $ \fd@(ConsultantProfile pContact pBlurb listAsC) -> [ ServerPartT $ \rq -> do- case (mbUser rglobs) of-   Nothing -> errW "Not logged in" rq-   Just olduser@(User uname p cp js) -> do-     let newuser = User uname p (ConsultantProfile pContact pBlurb listAsC) js-     updateUserSp rglobs newuser viewEditConsultantProfile rq+  withData $ \fd@(EditUserProfileFormData fdContact fdBlurb fdlistAsC fdimagecontents) -> [ ServerPartT $ \rq -> do+ case (return . sesUser =<< mbSession rglobs) of+   Nothing -> errW "Not logged in"+   Just unB -> do+     mbUP <- query $ GetUserProfile unB+     case mbUP of+       Nothing -> errW "error retrieving user infos"+       Just (UserProfile pContact pBlurb listasC pAvatar) -> do+         up <- if B.null (fdimagecontents)+           then return $ UserProfile fdContact fdBlurb fdlistAsC pAvatar+           else do+             let avatarpath = writeavatarpath unB+             -- to do: verify this handles errors, eg try writing to someplace we don't have permission,+             -- or a filename with spaces, whatever+             liftIO $ writeFileForce avatarpath fdimagecontents+             return $ UserProfile fdContact fdBlurb fdlistAsC (B.pack avatarpath)             +         update $ SetUserProfile unB up+         unServerPartT ( viewEditConsultantProfile rglobs) rq   ]-  where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"---data EditJob = EditJob {oldjobname::String,jobtitle::String,jobbudget::String,jobdescription::String}---- Recommendation: ALWAYS give a default value via mplus, otherwise debugging can be hell.-instance FromData EditJob where-    fromData = liftM4 EditJob (look "oldjobname" `mplus` return "bad old job name")-                          (look "jobtitle" `mplus` return "bad job title")-                          (look "jobbudget" `mplus` return "bad budget")-                          (look "jobdescription" `mplus` return "bad job description")-+  where errW msg = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate" -   processformEditJob :: RenderGlobals -> ServerPartT IO Response-processformEditJob rglobs@(RenderGlobals ts mbU) =-  withData $ \(EditJob ojn jn jbud jblu) -> [ ServerPartT $ \rq -> do- case mbU of-   Nothing -> errW "Not logged in" rq-   Just olduser@(User uname p cp js) -> do-     let -- update the jobs list with the new info-         -- it feels kludgy to use map, because it would seem that you could have jobs with duplicate names-         -- probably the jobs collection could be a set, maybe fix later. it's just a demo.-         newjob = Job jn jbud jblu-         newjobs = map f js-           where f j | jobname j == ojn = newjob-                     | otherwise = j-         newuser = User uname p cp newjobs-     updateUserSp rglobs newuser (viewEditJob uname jn) rq--  ]-  where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"---instance FromData Job where-    fromData = liftM3 Job (look "jobtitle" `mplus` return "bad job title")-                          (look "jobbudget" `mplus` return "bad budget")-                          (look "jobdescription" `mplus` return "bad job description")--processformNewJob rglobs@(RenderGlobals ts mbU) =-  withData $ \newjob@(Job n budget blurb) -> [ ServerPartT $ \rq -> do- case mbU of-   Nothing -> errW "Not logged in" rq-   Just olduser@(User uname p cp js) -> do-     let newuser = User uname p cp (newjob:js)-     update (UpdateUser olduser newuser)-     let newrglobs = RenderGlobals ts (Just $ User uname p cp (newjob:js) )-     unServerPartT ( pageMyJobPosts newrglobs ) rq +processformEditJob rglobs@(RenderGlobals rq ts mbSess) =+  withData $ \(EditJob jn jbud jblu) -> [ ServerPartT $ \rq -> do+  case (return . sesUser =<< mbSess) of+    Nothing -> errW "Not logged in" +    -- Just olduser@(User uname p cp js) -> do+    Just uname -> do+      if null (B.unpack . unjobname $ jn)+        then errW "error, blank job name"+        else do +          update $ SetJob uname jn (Job (B.pack jbud) (B.pack jblu))+          unServerPartT ( viewEditJob uname jn rglobs) rq +   ]+   where errW msg = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"+        +      +processformNewJob rglobs@(RenderGlobals rq ts mbSess) =+  withData $ \(NewJobFormData jn newjob) -> [ ServerPartT $ \rq -> do+ case (return . sesUser =<< mbSess) of+   Nothing -> errW "Not logged in"+   Just user -> do+     if null (B.unpack . unjobname $ jn)+        then errW "error, blank job name"+        else do +         res <- update (AddJob user jn newjob)+         case res of +           Left err -> case isInfixOf "duplicate key" (lc err) of+                              True -> errW "duplicate job name"+                              otherwise -> errW "error inserting job"+           Right () -> unServerPartT ( pageMyJobPosts rglobs ) rq    ]-  where errW msg rq = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"--data NewUserInfo = NewUserInfo String String String-instance FromData NewUserInfo where-    fromData = liftM3 NewUserInfo (look "username")-                                  (look "password" `mplus` return "nopassword")-                                  (look "password2" `mplus` return "nopassword2")-+  where errW msg = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate" --- newUserPage :: RenderGlobals -> ServerPartT IO Response+{-+newUserPage :: RenderGlobals -> ServerPartT IO Response newUserPage rglobs =   withData $ \(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 pass1 )-                              mbU <- query (GetUser user)-                              case mbU of-                                Nothing -> errW "newUserPage, update failed" rq-                                Just u -> startsess rglobs u-               else errW "passwords did not match" rq+    [ ServerPartT $ \_ ->+         do userExists <- query $ IsUser user+            newuser user pass1 pass2 userExists     ]-    where errW msg rq = ( return . tutlayoutU rglobs [("errormsgRegister", msg)] ) "register" --+    where errW msg = ( return . tutlayoutU rglobs [("errormsgRegister", msg)] ) "register" +          newuser :: UserName -> B.ByteString -> B.ByteString -> Bool -> WebT IO Response+          newuser u@(UserName us) pass1 pass2 userExists+              | pass1 /= pass2 = errW "passwords did not match"+              | null . B.unpack $ pass1 = errW "bad password"+              | null . B.unpack $ us = errW "bad username"+              | userExists = errW "User already exists"+              | otherwise =  do update $ AddUser u $ scramblepass pass1+                                mbUis <- query $ GetUserInfos u+                                case mbUis of+                                  Nothing -> errW "newUserPage, update failed"+                                  Just uis -> startsess rglobs u+-} +newUserPage :: RenderGlobals -> ServerPartT IO Response+newUserPage rglobs =+  withData $ \(NewUserInfo user (pass1 :: B.ByteString) pass2) ->+    [ ServerPartT $ \rq -> do+  etRes <- runErrorT $ do+    setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) +  case etRes of+    Left err -> return $ tutlayoutU rglobs [("errormsgRegister", err)] "register"+    Right () -> startsess' (getAppUrl "tutorial/registered") rglobs user+        ]+  where+    setupNewUser :: NewUserInfo -> ErrorT [Char] (WebT IO) ()+    setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) = do+        if B.null pass1 || B.null pass2+          then throwError "blank password"+          else return ()+        if pass1 /= pass2+          -- TITS: can return . Left be replaced with throwError?+          --  A: no. But you can return just plain Left with throwError.+          then throwError "passwords don't match"+          else return ()+        nameTakenHAppSState <- query $ IsUser user+        if nameTakenHAppSState+          then throwError "name taken"+          else return ()+        addUserVerifiedPass user pass1 pass2 --- check if a username and password is valid. If it is, return the user as successful monadic value--- otherwise fail monadically-authUser :: Monad m => String -> String -> WebT IO (m User)-authUser name pass = do-  mbUser <- query (GetUser name)-  case mbUser of-    Nothing -> return . fail $ "login failed"-    (Just u) -> do-       p <- return . password $ u-       if p == (scramblepass pass)-         then return . return $ u-         else return . fail $ "login failed"+addUserVerifiedPass :: UserName -> B.ByteString -> B.ByteString -> ErrorT String (WebT IO) ()+addUserVerifiedPass user pass1 pass2 = do+  ErrorT $ newuser user pass1 pass2+  where+    newuser :: UserName -> B.ByteString -> B.ByteString -> WebT IO (Either String ())+    newuser u@(UserName us) pass1 pass2 -- userExists+      | pass1 /= pass2 = return . Left $  "passwords did not match"+      | otherwise = update $ AddUser u $ B.pack $ scramblepass (B.unpack pass1) --- to do: make it so keeps your current page if you login/logout--- probably modify RenderGlobals to keep track of that bit of state-startsess :: RenderGlobals -> User -> WebT IO Response-startsess (RenderGlobals ts _) user = do-  key <- update $ NewSession (SessionData $ username user)-  addCookie (3600) (mkCookie "sid" (show key))-  let newRGlobs = RenderGlobals ts (Just user) -  (return . tutlayoutU newRGlobs [] ) "home"
+ src/ControllerStressTests.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+module ControllerStressTests where++import HAppS.Server+import Data.List+import Misc+import qualified MiscMap as M +import Control.Monad+import Control.Monad.Trans+import Data.Maybe+import Text.ParserCombinators.Parsec+import qualified Data.ByteString.Char8 as B++import StateStuff+import ControllerMisc+import System.IO+import View+import System.Time++-- insert a lot of data unrealistically+-- the datastore set gets set in one huge macid transaction+spAddDummyData rglobs = +  withRequest $ \_ -> do+    us <- query AskDatastore+    if M.null (users us)+       then do insertus ddDemo+               return $ tutlayoutU rglobs [] "dummydatainitialized"   +       else return $ tutlayoutU rglobs [("errormsg", failmsg)] "errortemplate"+  where 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." ++-- insert a lot of data, faster, but less realistically -- all the users are inserted at once+--stressTestOneBigInsert = stressTest' insertus++-- insert a lot of data more realistically+-- lots of little macid actions build up to the final datastore.+-- stressTest :: Int -> RenderGlobals -> WebT IO Response+--stressTest = stressTest' $ atomic_inserts+stressTest' (fname,f) n rglobs = do+    startTime <- liftIO $ getClockTime+    (userRange,us) <- getUsers 10 n+    f us+    stressTestTime <- liftIO $ return . timeDiffToString =<< timeSince startTime+    liftIO $ putStrLn $ fname ++ " stresstest, " ++ (show n) ++ " users, elapsedtime: " ++ stressTestTime+    return $ tutlayoutU rglobs [("first",show . head $ userRange)+                                , ("last",show . last $ userRange)+                                , ("stressTestName",fname)+                                , ("testTime",stressTestTime)]+                                  "stresstestcompleted"+++--getUsers :: (MonadIO m) => Int -> m ([Int], Users)+getUsers jobsPerU n = do+        us <- return . M.toList . users =<< query AskDatastore+        -- something around here seems kinda slow+        let startNum = case ( mapMaybe ( getDummyNumber . B.unpack . unusername . fst ) us ) of+               [] -> 1+               xs -> (+1) . last . sort $ xs +            userRange = [startNum..(startNum+n-1)]            +        return $ (userRange, (stresstestdata jobsPerU) userRange)+++getDummyNumber :: String -> Maybe Int+getDummyNumber s = do+  let i = parse parseDummyNumber "parseDummyNumber" s+  case i of+    Left err -> Nothing+    Right i -> Just i++++parseDummyNumber :: Parser Int+parseDummyNumber = do+  string "user"+  i <- safeRead =<< many digit+  eof+  return i++-- insert a whole mess of users -- less realistic, but maybe faster way+-- to see how website stands up with a large amount of macid data (does it work with 100000 users... let's see...)++insertus :: (MonadIO m) => Users -> m ()+insertus us = update . ( AddDummyData . users ) $ us++--insertuAllJobs :: (MonadIO m) => (UserName, UserInfos) -> Users -> m ()+insertusAllJobs = mapM_ insertuAllJobs . M.toList . users +insertuAllJobs (u, uis) = do+  update $ ( (AddDummyUser (u,uis)) ) +  liftIO $ putStrLn $ "insertuAllJobs, added user: " ++ ( B.unpack . unusername $ u)+-- insert a user realistically +-- follow the same macid steps that would occur when data is added by a human+atomic_inserts = mapM_ insertu . M.toList . users+insertu :: (MonadIO m) => (UserName, UserInfos) -> m ()+insertu (u, UserInfos pass pr (Jobs js) ) = do+  update $ AddUser u (B.pack . scramblepass . B.unpack $ pass)+  update $ SetUserProfile u pr+  sequence_ $ map (\(jn,j) -> update $ AddJob u jn j) ( M.toList js )+  liftIO $ putStrLn $ "insertu, added user: " ++ ( B.unpack . unusername $ u)+    where addj u j = do+            -- liftIO $ putStrLn $ show ("adding job",username u,jobname j)+            addJob u j++                    +--------------dummy data+-- create arbitrarily large numbers of users to attempt insertion+--stresstestdata :: (Integral a) => [a] -> Users+stresstestdata jobsperU users = Users $ M.fromList $ map (stresstestUser jobsperU) users+stresstestUser jobsperU i = ( UserName . B.pack $ ("user"++(show i))  +                     , UserInfos +                        ( B.pack $ "password" ++ (show i))+                        (stresstestprofile i)+                        (Jobs $ M.fromList $ map (stresstestjob i) [1..jobsperU]) )+  where stresstestprofile i = UserProfile { contact = B.pack $ "someone" ++ (show i) ++ "@somewhere.com"+                                                  , blurb = B.pack $ "la la la"+                                                  , consultant = if even i then True else False+                                                  , avatar = B.pack ""}+        stresstestjob i j = ( JobName . B.pack $ "make something " ++ (show (i,j)) ,+                              Job { jobbudget = B.pack . show $ (i,j)+                                  , jobblurb = B.pack . ("blurb " ++) . show $ (i,j) } ) +                            ++-- dummy data appropriate for a job site demo and testing+-- tphyahoo is consultant type user (wants to find work)+-- zzz posted a lot of test jobs+ddDemo :: Users+ddDemo = Users $ M.fromList [+  ( UserName . B.pack $ "tphyahoo", UserInfos (B.pack . scramblepass $ "password") tphyahooProfile tphyahooJobs )+  , ( UserName . B.pack $ "zzz", UserInfos (B.pack . scramblepass $ "password")+                                         (UserProfile ( B.pack "") ( B.pack "") False ( B.pack "")) serpinskiJobs )+  ] ++tphyahooProfile = UserProfile {+  --billing_rate = "it depends on the project"+  contact = B.pack $ "thomashartman1 at gmail, +48 51 365 3957"+  -- tell something about yourself. Edited via a text area. should replace newlines with <br> when displayed.+  , blurb = B.pack $ "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 +  , avatar = B.pack ""+}+++-- can't use dummy data with foreign chars+-- app seems to accept them when entered through form though.+--               , ("Umläute in Happs benutzen können", "umsonst?")+tphyahooJobs =+  Jobs $ M.fromList $ map (\(j,b)-> ( JobName . B.pack $ j, Job { jobbudget = B.pack b, jobblurb = B.pack $ "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 =  Jobs $ M.fromList $ map (\num -> ( JobName . B.pack $ "job" ++ (show num), Job ( B.pack "$0") ( B.pack "")) ) [10..203]+
− src/Debugging.hs 
@@ -1,18 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}--import HAppS.Server-import HAppS.State-import Misc-import Session -import SessionState--req1 :: Request-req1 = read "Request {rqMethod = GET, rqPaths = [], rqQuery = \"\", rqInputs = [], rqCookies = [], rqVersion = Version 1 1, rqHeaders = fromList [(\"accept\",HeaderPair {hName = \"accept\", hValue = [\"text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\"]}),(\"accept-charset\",HeaderPair {hName = \"accept-charset\", hValue = [\"ISO-8859-1,utf-8;q=0.7,*;q=0.7\"]}),(\"accept-encoding\",HeaderPair {hName = \"accept-encoding\", hValue = [\"gzip,deflate\"]}),(\"accept-language\",HeaderPair {hName = \"accept-language\", hValue = [\"en-us,en;q=0.5\"]}),(\"connection\",HeaderPair {hName = \"connection\", hValue = [\"keep-alive\"]}),(\"host\",HeaderPair {hName = \"host\", hValue = [\"localhost:5001\"]}),(\"keep-alive\",HeaderPair {hName = \"keep-alive\", hValue = [\"300\"]}),(\"user-agent\",HeaderPair {hName = \"user-agent\", hValue = [\"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.16) Gecko/20080718 Ubuntu/8.04 (hardy) Firefox/2.0.0.16\"]})], rqBody = Body Empty, rqPeer = (\"localhost\",50453)}"--req2 = read "Request {rqMethod = GET, rqPaths = [\"start-happs-on-boot\"], rqQuery = \"\", rqInputs = [], rqCookies = [(\"sid\",Cookie {cookieVersion = \"\", cookiePath = \"\", cookieDomain = \"\", cookieName = \"sid\", cookieValue = \"-1184419469\"})], rqVersion = Version 1 1, rqHeaders = fromList [(\"accept\",HeaderPair {hName = \"accept\", hValue = [\"text/xml,application/xml,application/xhtml+xml,text/html;q=0.9,text/plain;q=0.8,image/png,*/*;q=0.5\"]}),(\"accept-charset\",HeaderPair {hName = \"accept-charset\", hValue = [\"ISO-8859-1,utf-8;q=0.7,*;q=0.7\"]}),(\"accept-encoding\",HeaderPair {hName = \"accept-encoding\", hValue = [\"gzip,deflate\"]}),(\"accept-language\",HeaderPair {hName = \"accept-language\", hValue = [\"en-us,en;q=0.5\"]}),(\"connection\",HeaderPair {hName = \"connection\", hValue = [\"keep-alive\"]}),(\"cookie\",HeaderPair {hName = \"cookie\", hValue = [\"sid=\\\"-1184419469\\\"\"]}),(\"host\",HeaderPair {hName = \"host\", hValue = [\"localhost:5001\"]}),(\"keep-alive\",HeaderPair {hName = \"keep-alive\", hValue = [\"300\"]}),(\"referer\",HeaderPair {hName = \"referer\", hValue = [\"http://localhost:5001/tutorial/stringtemplate-basics\"]}),(\"user-agent\",HeaderPair {hName = \"user-agent\", hValue = [\"Mozilla/5.0 (X11; U; Linux i686; en-US; rv:1.8.1.16) Gecko/20080718 Ubuntu/8.04 (hardy) Firefox/2.0.0.16\"]})], rqBody = Body Empty, rqPeer = (\"localhost\",42390)}"--t1 :: Maybe SessionKey-t1 = readData (readCookieValue "sid" ) req1--t2 :: Maybe SessionKey-t2 = readData (readCookieValue "sid" ) req2
src/Main.hs view
@@ -6,31 +6,31 @@ import Controller import Misc import System.Environment-+import Control.Concurrent import StateStuff+import System.Time+import HAppS.Server.Helpers  main = do   -- let p = 5001 -  let usageMessage = "usage example: happs-tutorial 5001 (starts the app on port 5001)"+  let usageMessage = "usage example: happs-tutorial 5001 True (starts the app on port 5001, allows stress tests)"   args <- getArgs   case args of-    [port] -> runserver (read port)+    [port, allowStressTests] -> do+       p <- safeRead port+       allowStressTests <- safeRead allowStressTests+       smartserver (Conf p Nothing) "happs-tutorial" (controller allowStressTests) stateProxy     otherwise -> do               putStrLn usageMessage-               --- run the happs server on some port-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 AppState-        entryPoint = Proxy- runInGhci = do-    putStrLn $ "happs tutorial running ins ghci. \n" +++    putStrLn $ "happs tutorial running in ghci. \n" ++              "exit :q ghci completely and reenter ghci, before restarting."-    runserver 5001+    smartserver (Conf 5001 Nothing) "happs-tutorial" (controller True) stateProxy+++stateProxy :: Proxy AppState+stateProxy = Proxy++
src/Misc.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS -fglasgow-exts -fno-monomorphism-restriction #-} module Misc where   import HAppS.Server @@ -10,14 +9,16 @@ import Data.Digest.Pure.MD5 import Debug.Trace import Text.PrettyPrint as PP-import Control.Applicative -import System.Directory-import System.FilePath+import System.FilePath (pathSeparator, takeDirectory)+import System.Directory (createDirectoryIfMissing)+import Safe (readMay)+import System.Time+import Data.Char (isAlphaNum) -import Text.StringTemplate+-- import Text.StringTemplate import Data.Monoid import Control.Monad.Reader-import Data.Char -- for rot13, which we shouldn't be using anyway+import Data.Char (toLower)  newtype HtmlString = HtmlString String instance ToMessage HtmlString where@@ -32,65 +33,13 @@     then unServerPartT (mconcat sps) rq     else mempty -traceTrue x = trace (show x ++ "\n\n") True-traceIt x = trace (show x ++ "\n\n") x-traceMsg msg x = trace ( "\n\n" ++ msg ++ (show x) ++ "\n\n") x-traceReadableMsg msg x = trace ( "\n\n" ++ msg ++ (show . show $ x) ++ "\n\n") x- pp[] = ( PP.render . vcat . map text . map show )-traceWith f v = trace (f v) v  -instance (Monad m) => Monoid (ServerPartT m a)-  where mempty = ServerPartT $ \rq -> noHandle-        mappend a b = ServerPartT $ \rq -> (unServerPartT a rq) `mappend` (unServerPartT b rq) -instance (Monad m) => Monoid (WebT m a) where-  mempty = noHandle-  mappend a b = WebT $ do a' <- unWebT a-                          case a' of-                              NoHandle -> unWebT b-                              _        -> return a'---- 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 = -       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)  -readDataDef :: b -> (a -> b) -> RqData a -> Request -> b-readDataDef def f rqDataReader rq = maybe def f . readData rqDataReader $ rq -dataReaderToWeb :: RqData a -> Request -> WebT IO (Maybe a)-dataReaderToWeb rqDataReader rq = return . readData rqDataReader $ rq-dataReaderToWebDef :: b -> (a -> b) -> RqData a -> Request -> WebT IO b-dataReaderToWebDef def f rqDataReader rq = return . readDataDef def f rqDataReader $ rq--dataReaderToSp :: RqData a -> ServerPartT IO (Maybe a)-dataReaderToSp rqDataReader = withRequest $ \rq -> dataReaderToWeb rqDataReader rq-dataReaderToSpDef :: b -> (a->b) -> RqData a -> ServerPartT IO b-dataReaderToSpDef def f rqDataReader = withRequest $ \rq -> dataReaderToWebDef def f rqDataReader rq--alltrue ps x = foldr g True ps-  where g p b = b && p x-nonetrue ps x = alltrue (map ( not . ) ps) x- pathPartsSp pps f = ServerPartT $ \rq ->   if rqPaths rq == pps     then f rq @@ -110,44 +59,70 @@             _ -> 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 )-+-- store passwords as md5 hash, as a security measure+scramblepass :: String -> String+scramblepass = show . md5 . L.pack  -- 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+tFromTo = fromTo 10 20 [1..1000] == [10..20] +fromTo fr to xs = take (to-(fr-1)) . drop (fr-1) $ xs   +quote x = '\"' : x ++ "\""   -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  ++-- Windows/Unix/Mac compatible +pathstring pathparts =+  let sep :: String+      sep = [pathSeparator] +  in intercalate sep pathparts++safeRead :: (Monad m, Read a) => [Char] -> m a+safeRead s = +  maybe (fail $ "safeRead: " ++ s)+        return +        (readMay s)++timeSince x = do+  currTime <- getClockTime+  return . diffClockTimes currTime $ x++-- splitList 3 [1..11]+-- [([(1,1),(2,2),(3,3)],(1,3)),([(4,4),(5,5),(6,6)],(4,6)),([(7,7),(8,8),(9,9)],(7,9)),([(10,10),(11,11)],(10,11))]+-- the result is a list of (indexed sublist,(fist index, last index))+splitList :: Int -> [b] -> [([b], (Int, Int))]+splitList n x = let+  part = splitList' n ( zip [1..] x) +  bounded = map (\l -> (map snd l,bounds l)) part+  bounds [] = (0,0)+  bounds l@((_,_):_) = (fst . head $ l,fst . last $ l)+  in bounded+  where +    splitList' :: Int -> [a] -> [[a]]+    splitList' _ [] = []+    splitList' n l@(x:xs) =+      let (a,b') = genericSplitAt n l+          b = splitList' n b'+      in  a : b+++lc = map toLower++-- write a file, creating parent directories if necessary+writeFileForce fp contents = do+  createDirectoryIfMissing True (takeDirectory fp)+  B.writeFile fp contents++--t = map isalphanum_S  ["asdf-","asdf_"]+-- check if a string is made of alphanumeric plus _+isalphanum_S = null . filter (not . isAlphaNum_)+isAlphaNum_ c = isAlphaNum c || '_' == c || '-' == c++allowedCharactersSnip = "please use only numbers, letters, '-', and '_'."
+ src/MiscMap.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NoImplicitPrelude #-}+module MiscMap (+  -- module Data.Map+  -- ,+  empty+  , Map+  , Data.Map.mapWithKey+  , Data.Map.map+  , Data.Map.toList+  , Data.Map.keys+  , Data.Map.filter+  , Data.Map.null+  , Data.Map.delete -- allow normal deletes that just do nothing if key not found+  , Data.Map.size+  , Data.Map.elems+  , Data.Map.lookup+  , Data.Map.fromList+  , Data.Map.union+  , insertUqM+  , deleteM+  , adjustM      +  , adjustMM+)+where++import Data.Map+import Prelude hiding (lookup)++---- kind of like what's in HAppS.Data.IxSet, but just operate on vanilla haskell maps, don't use IxSet machinery+-- modification operations+-- reject insert if duplicate key+--insertUq :: (Ord a, Ord k1, Ord k2) => k1 -> a -> Map k1 (Map k2 a) -> Map k1 (Map k2 a)+--insertUq k v index = M.insertWith M.union k (Set.singleton v) index+--  lookup++insertUqM :: (Show k, Monad m, Ord k, Ord a) => k -> a -> Map k a -> m (Map k a)+insertUqM k v m =+  case lookup k m of+    Nothing -> return $ insert k v m+    Just x -> fail $ "insertUqM, duplicate key: " ++ (show k)+++deleteM :: (Show k, Monad m, Ord a, Ord k) => k -> Map k a -> m (Map k a)+deleteM k m = case lookup k m of+   Nothing -> fail $ "deleteM, key not found: " ++ (show k)+   Just x -> return $ delete k m++-- how is update implemented in standard libs? Will this be efficient for macid?+--adjustM :: (Show k, Monad m, Ord a, Ord k) => k -> (a -> a) -> Map k a -> m (Map k a)+--adjustM k f m = adjustMM k (return . adjust f k) m++adjustM k f m = case lookup k m of+  Nothing -> fail $ "updateM, key not found: " ++ (show k)+  Just x -> return . adjust f k $ m+++-- similar to adjustM, except modification function can fail monadically+-- adjustMM :: (Ord k, Monad m, Show k) => k -> (k -> Map k a -> Either String (Map k a) ) -> Map k a -> m (Map k a)+adjustMM k mf m = case lookup k m of+  Nothing -> fail $ "updateMM, key not found: " ++ (show k)+  Just val -> case mf val of+    Left err -> fail $ "adjustMM: " ++ err+    Right newval -> return . adjust (const newval) k $ m +
+ src/SerializeableJobs.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, NoMonomorphismRestriction, ScopedTypeVariables #-}+module SerializeableJobs where++import HAppS.State+import Data.Generics+import qualified MiscMap as M+import qualified Data.ByteString.Char8 as B++-- JobName is like a primary key, Job is like the other fields, if we were in rdbms land++t = let f (JobName (j :: B.ByteString)) = B.unpack j in f . JobName $ (B.pack "job")+-- It might be a bit of overkill to declare things with this level of specificity+-- but I think it'll make the type signatures easier to read later on.+newtype JobName = JobName { unjobname :: B.ByteString }+  deriving (Show,Read,Ord, Eq, Typeable,Data)++instance Version JobName+$(deriveSerialize ''JobName) ++data Job = Job {jobbudget :: B.ByteString -- we allow jobs with unspecified budgets+                , jobblurb :: B.ByteString}+  deriving (Show,Read,Ord, Eq, Typeable,Data)+instance Version Job+$(deriveSerialize ''Job) ++-- because Haskell records are a kludge, define mutator functions. bleh. oh well.+-- mod_field takes a mutator function+-- set_field takes a value+set_jobbudget = mod_jobbudget . const+mod_jobbudget f (Job bud blu) = Job (f bud) blu++set_jobblurb = mod_jobblurb . const +mod_jobblurb f (Job bud blu) = Job bud (f blu)++newtype Jobs = Jobs { unjobs :: M.Map JobName Job }+  deriving (Show,Read,Ord, Eq, Typeable,Data)+instance Version Jobs+$(deriveSerialize ''Jobs)
src/SerializeableSessions.hs view
@@ -5,7 +5,7 @@ import Data.Generics --for deriving Typeable import HAppS.State -- for deriving Serialize -+import SerializeableUsers (UserName (..))  import qualified Data.Map as M @@ -14,8 +14,8 @@  type SessionKey = Integer                                                                    newtype SessionData = SessionData {                                                            -  sesUser :: String-} deriving (Read,Show,Eq,Typeable,Data)                                                     +  sesUser :: UserName+} deriving (Read,Show,Eq,Typeable,Data,Ord) instance Version SessionData  $(deriveSerialize ''SessionData)
− src/SerializeableSocialGraph.hs 
@@ -1,39 +0,0 @@-{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}-module SerializeableSocialGraph where--import Data.Generics-import HAppS.State----- Don't import anything from Data.Graph.Inductive.--- Export whatever you need in UniqueLabelsGraph--- That way non-unique-label operating functions like mkGraph, insNode, etc are hidden--- import UniqueLabelsGraph----- If your datatype is read/showable, you can use a deriving clause to get a serializeable--- instance, as I do below.--- However in the fgl, Gr isn't readable, which violates read/show invertability and probably--- should be patched in the fgl at some point.--- So I modified code from the fgl in the modules below, basically just to have a derived readable instance-import SerializeableTree -import SerializeableFiniteMap--import SerializeableUsers---- There is Template Haskell machinery for deriving Serialize instances of many data types--- , including Sets and Maps, in HAppS.Data.SerializeTH. --- However, there was no machinery for deriving serializeable Graphs--- So I declared an instance manually-instance Version (Gr a b) where mode = Primitive-instance (Serialize a,Serialize b, Eq a) => Serialize (Gr a b) where-    getCopy = contain ( fmap ( Gr . fmFromList ) safeGet )-    putCopy (Gr m) = contain . safePut . fmToList $ m---data SocialGraph = SocialGraph {                                                            -  socialgraph :: Gr User Float-} deriving (Read,Show,Eq, Typeable,Data) -- -instance Version SocialGraph-$(deriveSerialize ''SocialGraph) -
+ src/SerializeableUserInfos.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, NoMonomorphismRestriction  #-}+module SerializeableUserInfos where+import HAppS.State+import Data.Generics++import qualified MiscMap as M+import qualified Data.ByteString.Char8 as B+import SerializeableJobs++data UserProfile = UserProfile {+  --billing_rate :: String -- eg "" (blank is ok), "$30-$50/hour", "40-50 Euro/hour", "it depends on the project", etc.+  contact :: B.ByteString -- eg, "thomashartman1 at gmail, 917 915 9941"+  -- tell something about yourself. Edited via a text area. should replace newlines with <br> when displayed.+  , blurb :: B.ByteString+  , consultant :: Bool -- this is what actually determines whether the profile will list as a consultant or not+  , avatar :: B.ByteString -- path to an image file+} deriving (Show,Read,Ord, Eq, Typeable,Data)+instance Version UserProfile+$(deriveSerialize ''UserProfile) ++--mutators+set_contact = mod_contact . const+mod_contact f (UserProfile contact blurb consultant avatar) = UserProfile (f contact) blurb consultant avatar++set_blurb = mod_blurb . const+mod_blurb f (UserProfile contact blurb consultant avatar) = UserProfile contact (f blurb) consultant avatar++set_consultant = mod_consultant . const+mod_consultant f (UserProfile contact blurb consultant avatar) = UserProfile contact blurb (f consultant) avatar++data UserInfos = UserInfos {   +  password :: B.ByteString+  , userprofile :: UserProfile+  , jobs :: Jobs+} deriving (Show,Read,Ord, Eq, Typeable,Data)+instance Version UserInfos+$(deriveSerialize ''UserInfos) +++-- as a security measure, require that oldpass agrees with real old pass+set_password oldpass newpass (UserInfos pass up jobs) | pass == oldpass = return $ UserInfos newpass up jobs+                                              | otherwise = fail $ "bad old password: " ++-- mod_password f (UserInfos pass up jobs) = UserInfos (f pass) up jobs+set_userprofile = mod_userprofile . const+mod_userprofile f (UserInfos pass up jobs) = UserInfos pass (f up) jobs+-- set_jobs = mod_jobs . const+add_job jobname job =  mod_jobs $ M.insertUqM jobname job+del_job jobname = mod_jobs $ M.deleteM jobname++set_job = mod_job . const+mod_job f jobname = mod_jobs $ M.adjustM jobname f +mod_jobs mf (UserInfos pass up (Jobs jobs) ) = either (fail . ("mod_jobs: " ++) )+                                                      (\js -> return $ UserInfos pass up (Jobs js) )+                                                      (mf jobs)+
src/SerializeableUsers.hs view
@@ -1,39 +1,71 @@ {-# LANGUAGE TemplateHaskell, DeriveDataTypeable, NoMonomorphismRestriction  #-}-module SerializeableUsers where+module SerializeableUsers {- (+  module SerializeableUserInfos,+  Users (..), UserName -- , add_user_job+  +) -} where import HAppS.State import Data.Generics+import qualified MiscMap as M import qualified Data.Set as S-data Job = Job {jobname :: String-                , jobbudget :: String -- we allow jobs with unspecified budgets-                , jobblurb :: String}+import qualified Data.ByteString.Char8 as B++import SerializeableUserInfos++import SerializeableJobs+import Misc+++newtype UserName = UserName { unusername :: B.ByteString }   deriving (Show,Read,Ord, Eq, Typeable,Data)-instance Version Job-$(deriveSerialize ''Job) +instance Version UserName+$(deriveSerialize ''UserName) +data Users = Users { users :: M.Map UserName UserInfos }+  deriving (Show,Read,Ord, Eq, Typeable,Data)+instance Version Users+$(deriveSerialize ''Users) --- 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) +-- can fail monadically if the username doesn't exist, or the job name is a duplicate+add_user_job un jn job = mod_userMM un $ add_job jn job --- 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)  +-- adjust users, where the adjustment function can fail monadically+-- mod_userMM :: (Monad m) => UserName -> (UserInfos -> Either [Char] UserInfos) -> Users -> m Users+mod_userMM username f (Users us) = either (fail . ("mod_userMM: " ++) )+                                        (return . Users)+                                        (M.adjustMM username f us) +-- adjust users, where the adjustment function is presumed to be infallible,+-- but can still fail monadically if the username is invalid+mod_userM username f (Users us) = return . Users =<< M.adjustM username f us++set_user_userprofile_contact username c = mod_userM username $ ( mod_userprofile . set_contact $ c )+set_user_userprofile_blurb username b = mod_userM username $ ( mod_userprofile . set_blurb $ b )+set_user_userprofile_consultant username isconsultant =+  mod_userM username $ ( mod_userprofile . set_consultant $ isconsultant )++-- fails monadically if oldpass doesn't match password in user profile, via set_password+set_user_password :: (Monad m) => UserName -> B.ByteString -> B.ByteString -> Users -> m Users+set_user_password username oldpass newpass = mod_userMM username $ set_password oldpass newpass++-- set_user_userprofile username p = mod_userM username $ Right . set_userprofile p ++add_user username hashedpass (Users us)+    | B.null . unusername $ username = fail "blank username"+    | B.null hashedpass = fail "error: blank password"+    | not . isalphanum_S . B.unpack . unusername $ username+        = fail $ "bad username, " ++ allowedCharactersSnip+    | otherwise = either (fail . ("add_user: " ++))+                         (return . Users)+                         ( M.insertUqM username uis us )+  where uis = UserInfos hashedpass (UserProfile (B.pack "") (B.pack "")+                                                False (B.pack "") )+                                   (Jobs $ M.empty)++del_user username uis (Users us) = either (fail . ("del_user: " ++))+                                        (return . Users)+                                        ( M.deleteM username us )
src/StateStuff.hs view
@@ -14,12 +14,17 @@    , module SerializeableUsers   , module SerializeableSessions-+  , module SerializeableUserInfos+  , module SerializeableJobs+{-  , B.ByteString+  , B.unpack +  , B.pack -}   ) where- import HAppS.State-+import qualified Data.ByteString.Char8 as B import AppStateSetBased -- AppStateGraphBased --  import SerializeableUsers import SerializeableSessions-+import SerializeableUsers+import SerializeableUserInfos+import SerializeableJobs
− src/UniqueLabelsGraph.hs 
@@ -1,81 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}-module UniqueLabelsGraph (-  insUqNode, insUqNodes, mkUqGraph, lnodesetFromGraph, labelsetFromGraph, empty, matchLabel, labelExists,-  addLab, modLab,-  DynGraphUqL-)--where--import Data.Graph.Inductive-import Control.Monad.State-import Data.Maybe-import qualified Data.Set as S-import Data.List (foldl',find)---- like insNode(s) from Data.Graph.Inductive, but only works if node label is unique--- a class for graphs with unique labels--- you get an error if you try to insert duplicate labels--- and there's a function for returning all node labels as a set.--- wouldn't Ord constraint be better?---- minimum definition: insUqNode-class (Ord a, DynGraph gr) => DynGraphUqL a gr where-  insUqNode :: LNode a -> gr a b -> gr a b-  insUqNode (v,l) gr | found = error "insNode, duplicate Node " -                     | otherwise = insNode (v,l) gr-    where found = isJust . find (\(_,lab) -> lab==l) . labNodes $ gr-  matchLabel :: a -> gr a b -> (Maybe (Data.Graph.Inductive.Context a b), gr a b)-  matchLabel l g = -    case filter ( (==l) . snd) . labNodes $ g of-      [] -> (Nothing,g)-      [(nodeI,_)] -> match nodeI g-      otherwise -> error "matchLabel, duplidate labels"--instance (Ord a, DynGraph gr) => DynGraphUqL a gr--insUqNodes vs g = foldr insUqNode g vs--lnodesetFromGraph g = S.fromAscList . labNodes $ g--labelsetFromGraph g = (S.map snd) . lnodesetFromGraph  $ g--mkUqGraph vs es   = (insEdges' . insUqNodes vs) empty-      where-        insEdges' g = foldl' (flip insEdge) g es-- -labelExists l g = let (mcontext,gr) = matchLabel l g-                  in if (isJust mcontext)-                       then True-                       else False--{--lookupLabel l g = let (mcontext,gr) = matchLabel l g-                   in if (isJust mcontext)-                       then (Ju-                       else False                                     --}  -  --- these fail because of duplicate nodes, which is the right thing.-t, t1 :: Gr String Float-t = mkUqGraph [(1,""), (0,"")] [] -t1 = insUqNode (1,"") . insUqNode (0, "") $ empty----addLab :: (DynGraph g, Ord a) => a -> g a b -> g a b-addLab a g = run_ g $ insMapNodeM a-             --- fails, as it should, because dupe-t2 :: Gr String ()-t2 = addLab "" . addLab "" $ empty---modLab :: (Ord a, DynGraph g) => (a -> a) -> a -> g a b -> g a b-modLab f nl g = run_ g $ do-  oldgraph <- return . snd =<< get -- couldn't we just say: g instead of oldgraph and skip this?-  let ( mbOldContext, oldRemainingGr ) =  matchLabel nl $ oldgraph-      mbNewGraph = do (fr, nodeId, nodeLabel, to) <- ( mbOldContext )-                      return  $ (fr, nodeId, f nodeLabel, to) & oldRemainingGr-  return $ maybe oldgraph id mbNewGraph
src/View.hs view
@@ -1,58 +1,63 @@-{-# LANGUAGE NoMonomorphismRestriction, PatternSignatures  #-} module View where  import Text.StringTemplate import Misc-import Text.StringTemplate+-- use directoryGroupSafer instead,+-- otherwise there are annoyances with punctuation containing emacs backup files and the like+-- import Text.StringTemplate hiding (directoryGroup)  import qualified Data.Map as M import Data.List+import HAppS.Server.HTTP.Types (rqURL, Request)+import qualified Data.ByteString.Char8 as B import Data.Char import Control.Monad.Reader+import HAppS.Helpers.HtmlOutput+import Text.StringTemplate.Helpers import Network.HTTP (urlEncode)+import System.Directory (doesFileExist) import Data.Maybe-import SerializeableUsers +import StateStuff -import ViewPagination+--import SerializeableUsers +--import SerializeableUserInfos (UserProfile (..))+--import SerializeableJobs (Job(..), JobName(..))+import HAppS.Helpers --- Notice, there are no HApps.* imports --- Idea is, view is meant to be used from controller.--- Try to keep functions as type---   Pure -> .. -> Pure -> IO String---   or Pure -> Pure -> String+--import MiscStringTemplate --- 1 second reload time/IO for templates.--- tmplkvs: key/value pairs used for filling in a template---tutlayout, tutlayoutSafe :: [(String, String)] -> String -> String -> IO String---tutlayout tmplkvs basedomain tmpl = tutlayout' (unsafeVolatileDirectoryGroup "templates" 1) tmplkvs basedomain tmpl+-- debug problem with foreign character display+-- foreign chars displau okay+--t = do templates <- directoryGroup "templates" +--       -- let content = renderTemplateGroup templates [] "foreignchars"+--       writeFile "output.html" $ tutlayout (RenderGlobals templates Nothing) [] "foreignchars" --- how much stress does this put on the server?--- how could I even find this out?--- I could try setting a higher reload time, run top, and see if the happs process uses less memory--- withTemplateDir :: String -> (STGroup String -> String) -> IO String--- Could also see if it's practical to try working with the safe version--- Probably it's fine for "production", where not making template changes all the time--- and it's fine to stop/restart server when I do.---tutlayoutSafe tmplkvs basedomain tmpl = tutlayout' (directoryGroup "templates")  tmplkvs basedomain tmpl  -getTemplates :: IO (STGroup String)-getTemplates = directoryGroupSafer "templates"+-- Notice, there are no HApps.* imports +-- Idea is, view is meant to be used from controller.+-- Try to keep functions pure: > :browse View in ghci should reveal there's no IO for any of these function sigs. -data RenderGlobals = RenderGlobals { templates :: STGroup String,-                            mbUser :: Maybe User+data RenderGlobals = RenderGlobals {+                            origrq :: Request+                            , templates :: STGroup String+                            , mbSession :: Maybe SessionData                             }+  deriving Show  tutlayout :: RenderGlobals -> [([Char], [Char])] -> String -> String-tutlayout (RenderGlobals ts mbU) attrs tmpl0 = +tutlayout (RenderGlobals rq ts mbSess) attrs tmpl0 =    let tmpl = cleanTemplateName tmpl0-+      mbU = return . sesUser =<< mbSess       rendertut :: [(String,String)] -> String -> String       rendertut attrs file = ( renderTemplateGroup ts ) attrs file        -- should use readM, or whatever it's called, from Data.Safe-      readtut file = read . rendertut [] . concatMap escapequote $ file+      --readtut :: (Monad m, Read a) => String -> m a+      readtut file = (safeRead . rendertut [] . concatMap escapequote $ file)         where escapequote char = if char=='"' then "\\\"" else [char]--      attrsL = maybe attrs( \user -> [("loggedInUser",username user)] ++ attrs ) mbU  +      readTutTuples :: String -> [(String,String)]+      readTutTuples f = either (const [("readTutTuples error","")]) id+                                         $ (readtut f :: Either String [(String,String)] )+      attrsL = maybe attrs( \user -> [("loggedInUser",B.unpack . unusername $ user)] ++ attrs ) mbU          content = rendertut attrsL tmpl @@ -60,128 +65,71 @@         where            userMenu = maybe              ( rendertut attrsL "login" )-            ( \user -> paintHMenu . map (menuLink ts ("/tutorial/" ++ tmpl0) ) $-              [("/tutorial/logout","logout " ++ (username user))+            ( \user -> hMenuBars rq $+              [("/tutorial/logout","logout " ++ (B.unpack . unusername $ user))                , ("/tutorial/changepassword","change password")] )             ( mbU )            mainUserMenu = if (isJust mbU) -                           then paintHMenu .-                                  map (menuLink ts ("/tutorial/" ++ tmpl0) )-                                    . readtut $ "mainusermenu"+                           then hMenuBars rq $ readTutTuples "mainusermenu"                             else ""  -          menubarMenu =-            paintHMenu . map (menuLink ts ("/tutorial/" ++ tmpl0) ) . readtut $ "menubarmenu"-+          menubarMenu = hMenuBars rq $ readTutTuples "menubarmenu"       --, ("post-data","form post data")       --, ("get-data","querystring get data")       --, ("macid-data","macid data")       --, ("migrating","changing the data model")-      tocArea = paintVMenuOL . map (menuLink ts ("/tutorial/" ++ tmpl0) ) . readtut $ "toc"+      tocArea = vMenuOL rq $ readTutTuples "toc"                  in rendertut ( [("tocarea",tocArea)                      , ("contentarea",content)                      , ("headerarea",header)] ) "base" ----- menuLink :: Maybe String -> String -> (String, String) -> String-menuLink ::  STGroup String-  -> String-  -> (String, String)-  -> String-menuLink templates currUrl (url,anchortext) =-  let r = renderTemplateGroup templates attrs-      attrs = [("url",url),("anchortext",anchortext)]-  in  if ( currUrl == url)-        then r "menulinkselected"-        else if null url-                then r "menulinkgray"-                else r "menulinkunselected"--simpleLink templates (url,anchortext) = renderTemplateGroup templates [("url",url),("anchortext",anchortext)] "simplelink"--paintVMenu = concatMap (\mi -> "<p>" ++ mi ++ "</p>") -paintVMenuUL xs = "<ul>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ul>"-paintVMenuOL xs = "<ol>" ++ (concatMap (\mi -> "<li>" ++ mi ++ "</li>") xs) ++ "</ol>"-paintHMenu = intercalate " | " ----paintTable :: [String] -> Maybe [String] -> [[String]] -> Maybe Pagination -> String-paintTable templates mbHeaderCells datacells mbPagination =-  let trows = maybe rows ( (++rows) . paintHeaderTr) mbHeaderCells-        where rows = paintTrs tableCells--      tableCells :: [[String]]-      tableCells = maybe datacells (getPaginatedCells datacells) mbPagination --      paginationBar :: String-      paginationBar = maybe "" (paintPaginationBar templates datacells) mbPagination-      -  in ( table trows ) ++ paginationBar----paintHeaderTr hc = tr . concat . (map (td {-. biggerfont -} ) ) $ hc-paintTrs cells = concat . map (tr . concat) . ( (map . map) td ) $ cells--biggerfont x = "<font size=+1>" ++ x ++ "</font>"-tr x = "<tr>" ++ x ++ "</tr>"-td x = "<td>" ++ x ++ "</td>"-table x = "<table>" ++ x ++ "</table>"- cleanTemplateName tmpl = filter isAlpha tmpl--paintblurb b = (concatMap formatnewlines) b-  where formatnewlines c = if c == '\n' then "<br>" else [c]+paintblurb b =  newlinesToHtmlLines b -{--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 =+--paintProfile :: RenderGlobals -> String -> UserProfile -> String+paintProfile rglobs user cp userimagepath =   let attrs = [("username",user) -               , ("blurb",paintblurb . blurb $ cp)+               , ("userimage", userimagepath ) -- avatarimage (UserName . B.pack $ user) +               , ("blurb",newlinesToHtmlLines . B.unpack . blurb $ cp)                --, ("jobsPosted",paintJobsTable n rglobs $ js)-               , ("contact",contact cp)]+               , ("contact", newlinesToHtmlLines . B.unpack . 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) +paintUserJobsTable rglobs postedBy rsUserJobs currP resPP = +  let jobCells = map ( \( JobName j', Job budget blurb)  -> let j :: String+                                                                j = B.unpack j' in +                       [ joblink postedBy j+                         , simpleLink ("/tutorial/editjob?user="++ (B.unpack postedBy) ++"&job=" ++ j,"edit")+                         , simpleLink ("/tutorial/deletejob?user="++ (B.unpack postedBy) ++"&job=" ++ j,"delete") -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)] +                       ] )  rsUserJobs+  in  paintTable Nothing jobCells Nothing -- no pagination for now ++joblink postedBy j = simpleLink ("/tutorial/viewjob?user="++(B.unpack postedBy)++"&job=" ++ j,j)+userlink pBy = simpleLink ("/tutorial/viewprofile?user=" ++ (B.unpack pBy),(B.unpack pBy) )+paintjob rglobs (UserName pBy) (JobName jN, Job jBud jBlu) =+  let +      joblink = simpleLink ("/tutorial/viewjob?user=" ++ (B.unpack pBy),(B.unpack pBy) )+      attrs = [ ("username",B.unpack pBy)+              , ("jobname",B.unpack jN)               +              , ("budget",B.unpack jBud)+              , ("jobblurb",B.unpack jBlu)+              , ("postedBy",userlink pBy)]    in renderTemplateGroup (templates rglobs) attrs "job"++avatarimage un = do+  uap <- urlavatarpath un+  return $ simpleImage (uap,(B.unpack . unusername $ un) ++ " image") ("100","100")++urlavatarpath un = do+  let p = writeavatarpath $ un+  e <- doesFileExist p+  if e+    then return $ "/" ++ p+    else return $ "/static/defaultprofileimage.png"+writeavatarpath un = "userdata/" ++ ( B.unpack . unusername $ un) ++ "/" ++ "profileimage"+
− src/ViewPagination.hs 
@@ -1,55 +0,0 @@-{-# LANGUAGE NoMonomorphismRestriction #-}-module ViewPagination where--import Data.List-import Misc-import Text.StringTemplate-data Pagination = Pagination { currentpage :: Int-                              , resultsPerPage :: Int -                              , baselink :: String-                              , paginationtitle :: String -                             }--paginationRanges :: Pagination -> [a] -> [[(a,Int)]]-paginationRanges pg datacells = splitList (resultsPerPage pg) $ zip datacells [1..]--paintPaginationBar :: STGroup String -> [[String]] -> Pagination -> String-paintPaginationBar templates datacells pg  =-  let r = renderTemplateGroup templates-      paintlink (pageindex,range) = case range of-                [] -> ""-                (_,fr):xs -> let to = last . map snd $ xs-                                 attrs = [("currentpage",show pageindex),-                                          ("resultsPerPage",show $ resultsPerPage pg),-                                          ("from",show fr),-                                          ("to",show to)]-                             in if (currentpage pg) == pageindex-                                   then  r attrs "paginationlinkselected"  -                                   else r attrs "paginationlinkunselected" -      pglinks = map paintlink $ zip [1..] (paginationRanges pg datacells )--  in (paginationtitle pg) ++ ( concat . intersperse " | " $ pglinks )----getPaginatedCells datacells pg = fromTo fromRow toRow datacells-        where (fromRow,toRow) = currentPaginationFromTo datacells pg--currentPaginationFromTo :: [[a]] -> Pagination -> (Int,Int)-currentPaginationFromTo datacells pg =-  --let currentPaginationRange = paginationRanges pg datacells !! ( (currentpage pg) -1)-  case paginationRanges pg datacells of-    [] -> (0,0)-    prs -> let currrange = prs !! ((currentpage pg)-1)-           in  case currrange of-             [] -> (0,0)-             ((firstval,firstindex):xs) -> (firstindex, (last . map snd ) xs)---splitList :: Int -> [a] -> [[a]]-splitList _ [] = []-splitList n l@(x:xs) =-  let (a,b') = genericSplitAt n l -      b = splitList n b'-  in  a : b-
− src/ViewStuff.hs 
@@ -1,7 +0,0 @@-module ViewStuff (-  module View,-  module ViewPagination-  ) where--import View-import ViewPagination
+ static/defaultprofileimage.png view

binary file changed (absent → 43 bytes)

static/tutorial.css view
@@ -33,11 +33,11 @@  } -/* menu colors */ a.menuitem:link {color: blue} a.menuitem:active {color: blue} a.menuitem:visited {color: blue} a.menuitem:hover {color: blue}+ a.menuitemselected:link {color: red} a.menuitemselected:active {color: red} a.menuitemselected:visited {color: red}
templates/base.st view
@@ -1,6 +1,6 @@ <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">-<html xmlns="http://www.w3.org/1999/xhtml">+<html xmlns="http://www.w3.org/1999/xhtml" >     <head>       <meta http-equiv="content-type" content="text/html; charset=utf-8" />       <title> Real World HAppS: The Cabalized, Self-Demoing HAppS Tutorial </title>@@ -18,7 +18,7 @@ 	      </tr> </table> 	    </div>  -	$! googleanalytics() !$ +	$ googleanalytics() $  	$ footer() $
templates/basicurlhandling.st view
@@ -39,9 +39,9 @@   <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>Formatted html: <a href="/htmlAttemptWrong">First attempt at formatted html (wrong)</a> </li>+  <li><a href="/htmlAttemptRight">Second attempt at formatted html (right)</a></li>+  <li><a href="/htmlAttemptForeignChars">Foreign characters in formatted html</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>
templates/consultantprofile.st view
@@ -4,9 +4,13 @@ <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> +  <p><b>About Me:</b>+     <br>$ blurb $</p>+  <p><b>Contact: </b>+     <br>$ contact $ </p>  $! <h4>Job Posts</h4>   $ jobsPosted $ !$++$ userimage $
+ templates/debugging.st view
@@ -0,0 +1,55 @@+<h3>Debugging</h3>++<p>A few words on debugging.++<p>One thing you can do is put debugFilter before the serverPartT that seems to be causing trouble.+   <br> This will spit out the request and response objects, which can be helpful.++<p>*Main> :t debugFilter :: Show a => [ServerPartT IO a] -> [ServerPartT IO a]+<br>debugFilter :: Show a => [ServerPartT IO a] -> [ServerPartT IO a] :: (Show a) =>+<br>                                                                     [ServerPartT IO a] -> [ServerPartT IO a]+<br>*Main> :i debugFilter+<br>debugFilter ::+<br>  (Show a, Control.Monad.Trans.MonadIO m) =>+<br>  [ServerPartT m a] -> [ServerPartT m a]+<br>  	-- Defined in HAppS.Server.SimpleHTTP++<p>I personally don't use debugFilter much, as it gives almost too much information.++<p>Instead, I depend on Debug.Trace.trace (a standard library function which sneaks IO in+   anywhere you have a showable value), which I augmented with some helper functions (in Misc.hs).++<p>traceTrue x = trace (show x ++ "\n\n") True+<br>traceIt x = trace (show x ++ "\n\n") x+<br>traceMsg msg x = trace ( "\n\n" ++ msg ++ (show x) ++ "\n\n") x++<p>Typical (basically only) use of traceTrue: view arguments to a function in stdout,+   by putting it on the right side of the+   "execute this branch if true" bar in a function definition.+   The function executes as it normally would, because traceTrue always returns true.+   But you get debugging info as a side effect.++<p>tutlayout (RenderGlobals ts mbU) attrs tmpl0 | traceTrue ((RenderGlobals ts mbU), attrs, tmpl0) = .....++<p>Typical use of traceIt: quickie print to stdout of some var or expression:++<p> mainUserMenu = if (isJust mbU) +<br>&nbsp;                   then traceIt \$ paintHMenu .+<br>&nbsp;&nbsp;                            map (menuLink ts ("/tutorial/" ++ tmpl0) )+<br>&nbsp;&nbsp;&nbsp;                                    . readtut \$ "mainusermenu"+<br>&nbsp;                           else "" ++<p>traceMsg does pretty much the same thing as traceIt, except you preface the shown expression with+   your own message like "show the menu: ". This can be useful if you are doing more than one trace+   and need to disginguish them.++<p>There are probably smarter ways of debugging a happs app, the above is just what works for me.+   (Actually, I debug using these trace helpers all the time, not just in HApps.)+   If I get useful feedback on how other happs users approach debugging I will update this page.++<p>Incidentally, ghci has a debugger since 6.8.3. Overall it's great, but I didn't find it too useful for happs,+   because it would die out on me in ways I didn't understand, typically around hard to understand exceptions.+   Basically, HAppS would behave differently when I was stepping through it with the ghci debugger than +   it would when running without the debugger.+   I suspect it's because the ghci debugger lacks support for multithreaded programs, or something along those lines.+   At any rate, I wound up not using the interactive debugger much, though I would have liked to.
+ templates/dummydatainitialized.st view
@@ -0,0 +1,4 @@+<p>Dummy data initialized. You should now have <a href="/tutorial/consultants">consultants</a>+and <a href="/tutorial/jobs">jobs</a> stored in your macid state.++<p>Go back to <a href="/tutorial/macid-dummy-data">macid dummy data</a>?
templates/editconsultantprofile.st view
@@ -1,13 +1,19 @@ <h3>Edit Profile</h3>-    <form action="/tutorial/editconsultantprofile" method="post">+    <form action="/tutorial/editconsultantprofile" enctype="multipart/form-data" method="post">     <table>-	<tr><td>About Me:</td><td><input type="textfield" rows=5 name="consultantblurb" value = $blurb$ ></td></tr>+	<tr><td>About Me:</td><td colspan=2><textarea name="consultantblurb" rows=6 cols=64>$blurb$</textarea></td>+	</tr> -	<tr><td>Contact:</td><td><input type="textfield" name="contact" value=$contact$ ></td></tr>+	<tr><td>Contact:</td><td colspan=2><textarea name="contact" rows=3 cols=64>$contact$</textarea></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>List me on the HAppS developers page:</td>+	    <td colspan=2><input type="checkbox" name="listasconsultant" value="listasconsultant" $listAsConsultantChecked$ ></td></tr>          +        <tr><td>Upload picture:</td> +             <td><input type="file" name="imagecontents">+             <td>$userimage$</td>+            </td>+        </tr> 	<tr><td></td>             <td><input type="submit" name="submitbtn" value="submit"> 	        $! <input type="submit" name="editconsultantaction" value="preview"> !$
templates/editjob.st view
@@ -1,9 +1,7 @@ <h3>Edit Job</h3>     <form action="/tutorial/editjob" method="post">-    <input type=hidden name="oldjobname" value=$oldJobname$>+    <input type="hidden" name="jobtitle" value=$jobname$ >     <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>
+ templates/fileuploads.st view
@@ -0,0 +1,17 @@+<h3>File Uploads</h3>++If you want to do file uploads, look at the code that is responsible for adding a profile picture in <a href=/projectroot/src/ControllerPostActions.hs>ControllerPostActions::processformEditConsultantProfile</a>++<p>The same pattern for dealing with form data in the previous chapter holds.+   The only differences are that ++<ul>+  <li>the value for the image file that is being passed in via withData is the entire contents of a file, as a bytestring:+      <br><i>withData \$ \fd@(EditUserProfileFormData fdContact fdBlurb fdlistAsC fdimagecontents)</i>+  <li>there is an IO action in the ServerPartT handler, which writes the file:+        <br><i>liftIO \$ writeFileForce avatarpath fdimagecontents</i>+  <li>enctype="multipart/form-data" in the <a href="/projectroot/templates/editconsultantprofile.st">form itself</a>+</ul>++<p>In the above, the <i>fdimagecontents</i> variable contents the entire contents of an image file. +   writeFileForce is just a wrapper over writeFile that creates necessary parent directories if they are missing.
templates/footer.st view
@@ -1,5 +1,8 @@     <div id="footer">     copyright thomashartman1 at gmail      <br><a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/happs-tutorial">use the source</a>+        | <a href="/projectroot/templates">browse templates</a>+	| <a href="/projectroot/src">browse haskell files</a>+	| <a href="/projectroot">browse the whole enchilada</a>     </div>
+ templates/foreignchars.st view
@@ -0,0 +1,39 @@+<h3>Internationalization</h3>+<p>I had some problems displaying non-ascii characters such as ö, ä, and ü, although now everything that I want +works (except for utf8 data in dummy data). I can create users with foreign characters in usernames or profile fields,+jobs with foreign characters in the description, and so on.++<p>But I wasted enough time on this that I thought I'd say a few words in hopes of saving others trouble.++<p>First of all, if you are running this tutorial locally and are seeing escape characters in the paragraph +above, set your locale by doing something like (on linux)+<p>+export LANG=en_US.UTF-8+<br> sudo update-locale++<p>and restart the tutorial app. Hopefully at least then this page displays properly, as it does for me.++<p>Another tip: don't use emacs, or emacs22, to edit files with utf8 data. Supposedly emacs22 has good utf8 +support, but I can't even figure out a way for emacs to tell me whether the file I'm in is in utf8 or latin1, +which led to some annoying confusions. Instead, use kate (a free apt-gettable editor), use tools-> encoding+to see what encoding you are seeing, and always set the kate encoding to utf8. If a tutorial template file+displays properly in kate with utf8, it should display properly in the live tutorial as well.++<p>Another annoyance: when I attempted to create dummy data with utf8 data (edited in kate)+and save this to HAppS State, this did NOT display correctly. (See AppStateSetBased.hs) I got \123 type+character escape sequences. I think this is because Serialization is based on show instances of data,+and ... well...+<br>+<br>*Main> show "ö"+<br>"\"\\246\""+<br>*Main> putStrLn "ö"+<br>ö++<p>This annoyance may be alleviated when ghc support for unicode is added sometime after ghc 6.8.10, as alluded+to in the <a href="tk">release notes</a>++<p>I also had a problem where data in form textbox fields was mysteriously showing up \ed. It turned out +this is because I sloppily used show to escape quotes, rather than sticking a quote at the beginning and +end of the string as was more proper. I then got bitten by show as above, causing much misery.++<p>But all that having been said, as the live demo shows, in general utf8 data does work as it should.
+ templates/foreigncharsBase.st view
@@ -0,0 +1,15 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN"+"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+    <head> +      $! meta tag seems to screw things up in t3, but removing it in base.st doesn't fix tutorial pages !$+      $! <meta http-equiv="content-type" content="text/html; charset=utf-8" /> !$+      <title> Real World HAppS: The Cabalized, Self-Demoing HAppS Tutorial </title>+      <link rel="stylesheet" href="/static/tutorial.css" type="text/css" />+    </head> ++    <body>+      $ foreignchars() $+    </body>+</html> +
+ templates/foreigncharsInclude.st view
@@ -0,0 +1,1 @@+ö ä ü
+ templates/getandpost.st view
@@ -0,0 +1,46 @@+<h3>GET and POST data</h3>++<p>GET data is data attached to an http request via the url string. In the job board app, an example of this is+   <a href=/tutorial/viewprofile?user=tphyahoo>tphyahoo's profile</a>, where the user is specified on the url string.+   Another example is <a href=/tutorial/viewjob?user=tphyahoo&job=darcshub>fetching a particular job</a>.++<p>POST data is data attached to a request after submitting a form.+   One place this is used is in the <a href=/tutorial/register>registration</a> process.+   Once you have a user created, you can also see POST in action by editing your profile or creating jobs.++<p>HAppS deals with GET and POST data similarly.++<p>Let's look at how+   <a href=/tutorial/viewprofile?user=tphyahoo>tphyahoo's profile</a> gets displayed.++<p><a href=/src/Controller.hs>Controller.hs</a>: ... , dir "viewprofile" [ methodSP GET \$ userProfile rglobs ] ...++<p>using dir and methodSP as above is a common pattern. dir pops the head element of the path array+   ["viewprofile"], resulting in an empty array. methodSP checks that the path array is empty and that +   the method is GET. If so, control is passed to the next sp: userProfile rglobs, which is in another module.++<p><a href=/src/ControllerGetActions.hs>ControllerGetActions.hs</a>: ++<p>data UserNameUrlString = UserNameUrlString {profilename :: String}+<br>instance FromData UserNameUrlString where+<br>&nbsp;    fromData = liftM UserNameUrlString (look "user" `mplus` return "")+<br>userProfile rglobs = +<br>&nbsp;  withData \$ \(UserNameUrlString user) ->+<br>&nbsp;&nbsp;    [ ServerPartT \$ \rq -> do .....+<br>++<p>*Main> :t withData :: FromData a => (a->[ServerPartT IO Response]) -> ServerPartT IO Response++<p>The above is the main pattern for processing GET or POST data in happs.++<p>First, you decide what argument type withData should accept. This might be a datatype you have already +   defined, like User or Job, which already plays a major role in the app.+   Or it could be an ad-hoc datatype which is only used this once, in the form processing.+   Whatever the case you declare that data type an instance of FromData, and define how it should+   grab data attached to the request. In this case, UserNameUrlString takes one argument, so we use LiftM +   -- for two args we would use LiftM2, three args LiftM3 etc. +   To get that one arg, we look for a request GET variable named "user" and if we don't find it we+   use a reasonable default, in this case the empty string. The result is a value of type UserNameUrlString+   which gets passed to the ServerPartT handler in the userProfile function.++<p>Another use is... (pagination. now... sleeep.....)
templates/gettingstarted.st view
@@ -16,14 +16,16 @@ 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/ghciflounderingaskdatastore.st view
@@ -0,0 +1,85 @@+<h3>Appendix: Using ghci with HAppS</h3>++<p><font color=orange>When working with HAppS, I seem to spend a lot of time in ghci looking at type signatures,+   and it's not always obvious what's going on. So I thought I'd share a little mini ghci session +   in case this helps anyone.</font>++<p>*Main> :t query AskDatastore+<br>query AskDatastore :: (Control.Monad.Trans.MonadIO m) => m (Data.Set.Set User)+<br>*Main> :t query AskDatastore :: WebT IO (Data.Set.Set User) <font color=orange>-- concretize the type</font>+<br>query AskDatastore :: WebT IO (Data.Set.Set User) :: WebT IO (Data.Set.Set User) <font color=orange>-- hoorah, it typechecks</font>+<br>+<br>*Main> :t update InitializeDummyData+<br>update InitializeDummyData :: (Control.Monad.Trans.MonadIO m) => m ()+<br>*Main> :t update InitializeDummyData :: WebT IO () <font color=orange>-- concretize the type</font>+<br>update InitializeDummyData :: WebT IO () :: WebT IO ()+<p><font color=orange>What you see above are nice looking types. And they can be made concrete, with WebT -- no+   class class context in the type signature. This is Right.</font>	 ++<p><font color=orange>What happens if we try an update on something that should really be a query?+   Does it get rejected?</font>++<p>*Main> :t update AskDatastore+<br>update AskDatastore :: (UpdateEvent AskDatastore res, Control.Monad.Trans.MonadIO m) => m res+<br>*Main> :t query InitializeDummyData+<br>query InitializeDummyData :: (QueryEvent InitializeDummyData res, Control.Monad.Trans.MonadIO m) => m res+<p><font color=orange>Typechecks with a weird class context, but will complain if run,+   and impossible to make concrete in ghci using :: to narrow the type. Ugly looking types. This is Wrong. </font>++<hr>++<p><font color=orange>What exactly is askDatastore?</font>++<p>*Main> :i askDatastore+<br>askDatastore :: Query AppState (Data.Set.Set User)+<br>  	-- Defined at src/AppStateSetBased.hs:43:0-11++<p><font color=orange>what's a Query?</font>++<p>Prelude Control.Monad.Reader HAppS.State GHC.Conc> :i Query+<br>type Query state = Ev (ReaderT state STM)+<br>  	-- Defined in HAppS-State-0.9.2.1:HAppS.State.Types+<br>+<br>data StateStuff.Method st where+<br>  ...+<br>  Query :: forall st ev res.+<br>           (QueryEvent ev res) =>+<br>           (ev -> Query st res) -> StateStuff.Method st+<br>  	-- Defined in HAppS.State.ComponentSystem++<p><font color=orange>that's weird. in the type synonym Query takes a single arg,+    but in the definition for askDatastore, it took two.  I guess the type system uses currying.+    Let's just substitute the concrete type AppState for the type variables state and see if +    this mess typechecks.+    </font>++<p>*AppStateSetBased Control.Monad.Reader GHC.Conc Data.Set> :t askDatastore :: Ev (ReaderT AppState STM) (Set User)+<br>askDatastore :: Ev (ReaderT AppState STM) (Set User) :: Ev (ReaderT AppState STM) (Set User)+<br>*Main> +<br>++<P><font color=orange>No type errors -- it works.+<br>Think of it like this: askDatastore is a macid event that reads a value.++<p>:i ReaderT+<br>newtype ReaderT r m a = ReaderT {runReaderT :: r -> m a}+<br>  	-- Defined in Control.Monad.Reader++<p>The type constructor ReaderT takes three arguments to yield a concrete type. +   In the definition for askDatastore, it is partially applied,+   with two arguments. ReaderT AppState STM is an instance of Monad,+   and also an instance of MonadReader AppState, with AppState as the+   reader environment and STM (software transactional memory) as the wrapped monad.++<p>*Main Control.Monad.Reader HAppS.State GHC.Conc> :i ReaderT+<br>instance (Monad m) => Monad (ReaderT r m)+<br>&nbs;&nbsp;*Main Control.Monad.Reader HAppS.State GHC.Conc> :i ReaderT+  -- Defined in Control.Monad.Reader+<br>instance (Monad m) => MonadReader r (ReaderT r m)+<br>&nbsp;&nbsp;  -- Defined in Control.Monad.Reader++<p>What about Ev?... nah.++<p>That is as far down the HAppS type rabbit hole as I am going to go.+</font>+
templates/home.st view
@@ -8,7 +8,7 @@ <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>.+<a href=http://gilesbowkett.blogspot.com/2007/05/sql-unnecessary-in-haskells-happs.html>should be factored out</a> where possible.  <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.@@ -30,6 +30,20 @@ <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>The above description is a bit idealized. Keeping everything in macid limits you to how much RAM you can afford,+   and even if you can afford a lot (16GB in the amazon cloud costs \$576/month) there's no guarantee that you won't+   max that out if your application has a lot of data.+   (See the <a href=/tutorial/macid-stress-test>stress test</a> chapter for more caveats.)+   The HAppS developers have promised a version of HAppS that will make it easy to share ram across computers+   with a technique called sharding, but this hasn't been released in a way that inspires confidence in me+   (on hackage, sufficient documentation),+   and to be honest I don't really understand how it is supposed to work even in theory.+   But what is realistic is to write an alpha version of an application without a database access layer, +   and then add persistent hard drive storage (probably database, but could also be flat files or name your poison)+   outside of macid when it becomes necessary. Most web projects do not get to a size where this is necessary,+   so arguably coding in a database from a start is a form of insidious premature optimization, if you buy+   the argument that using a database from the start introduces significant maintenance overhead.  <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
+ templates/introductiontomacid.st view
@@ -0,0 +1,39 @@+<h3>Introduction To Macid</h3>++<p>Macid is the HAppS storage mechanism that allows you to use whatever data structure you want+   to hold your permanent data, without worrying about getting it into and out of tabular form+   fit for storage in a traditional <a href="wikipedia tk">rdbms</a>.++<p>Before delving into how it works let's learn a bit about it from an operational perspective. +   Assuming you have the tutorial installed and running locally: ++<ul>+  <li><a href=/tutorial/register>register</a> a new user with username "testuser" and password "testpassword"+  <li>Optionally, fill out profile information for your new test user, and/or make some job posts.+</ul>++<p>The data you entered is stored on your filesystem in a directory under your running executable, called <i>_local</i>.++<p>~/happs-tutorial>ls _local/happs-tutorial_state/+<br>current-0000000000  events-0000000000  events-0000000001  events-0000000002++<p>You can grep for it too.++<p>+thartman@thartman-laptop:~/happs-tutorial>grep -ra testuser _local+<br>_local/happs-tutorial_state/events-0000000000:ß\$6¡·¢:1525374391 696985193?AppStateSetBased.AddUsertestuser e1+       ... (and lots more lines of binary data)++<p>Hm... let's see, can we be sneaky and grep for the password?++<p>Try it, you can't. Because the password is stored as an md5 hash, out of respect for the privacy of your users.+   See the newUserPage function in <a href=/src/ControllerPostActions.hs>ControllerPostActions</a> if you're curious. ++$!<p>Keeping application data in static files+   may seem like a weird thing to do if you have gotten used to keeping application data in a database.+   But it's not really that weird. !$ +++<p><a href="/tutorial/maciddatasafety">Keeping your macid data safe</a>++
templates/job.st view
@@ -1,4 +1,5 @@-<h3><font color=brown>$jobname$</font></h3>+$! <h3><font color=brown>$jobname$</font></h3> !$+<h3><a href=/tutorial/viewjob?user=$username$&job=$jobname$>$jobname$</a></h3> <p> <ul>   <li>Budget: $budget$</li>
templates/login.st view
@@ -1,4 +1,31 @@-<div id="login">+<style>+.tbody {display: none;}+</style>++<script Language="JavaScript">+    var current = 1;++    function move( byWhat )+    {+	current += byWhat;+	if ( current < 1 ) current = 2;+	if ( current > 2 ) current = 1;+	show( current );+    }++    function show( nwhich )+    {+	current = nwhich;+	for ( var dnum = 1; dnum <= 2; ++dnum )+	{+	    var dv = document.getElementById("BODY"+dnum);+	    dv.style.display = ( dnum == nwhich ? 'block' : 'none' );+	}+    }+</script>++<DIV ID="BODY1" class="tbody" style="display: block;">+    <div id="login">     <form action="/tutorial/actions/login" method="post">       <table> 	<tr><td>Username:</td> <td><input type="textfield" name="username"/></td> </tr>@@ -6,10 +33,35 @@ 	<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>+	     <td> <a href="#" onClick="move(1);">register</a></td> 	</tr>       </table>     </form>-    $ errortemplate() $+    <font color=red>+      $ loginerrormsg $+    </font>    +    </div>+</DIV> -</div>+<DIV ID="BODY2" class="tbody">+    <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>+            <td><a href="#" onClick="move(1);">login</a></td>+        </tr>+    </table></form>+    <font color=red>+      $ errormsgRegister $+    </font>+    +</DIV>+++++
+ templates/maciddatasafety.st view
@@ -0,0 +1,99 @@+<h3>Keeping your macid data safe</h3>++$! <p>All web startups have something in common. If you lose your user data, you are hosed. !$++$! <p>So when I was first learning about HAppS, and contemplating doing a startup with it, one of my first questions+   was, how do I keep this from happening? !$++<p>If you are using php, ruby on rails, or one of the other popular web frameworks, your user data is likely+   in a mysql database$!, or if you are well funded maybe in Oracle!$. If you have outsourced your server hosting,+   maybe you $!are even lucky enough to!$ have a database administrator that takes backups for you on a regular basis.+   That probably helps you sleep at night, assuming that you can really trust that your dba is doing their job.++<p>As we learned in the previous lesson, if you are using HAppS with macid, your data is +   right there on your filesystem, by default in the directory called <i>_local</i>.++<p>~/happs-tutorial>ls _local/happs-tutorial_state/+<br>current-0000000000 events-0000000000 events-0000000001 events-0000000002 ++       ++<p>If there is money on the line, you are going to want to be careful with this directory.++<p>When <a href="/tutorial/macid-migration">migrating macid data</a> to a new schema, you are also going to want to be extra cautious.++<p>But for now, since you don't have any valuable data, the following procedure is probably enough+   to remind yourself to be careful while learning about HAppS in the tutorial sandbox.++<ul>+  <li>Stop happs by doing ctrl-c if you are running the ./happs-tutorial app from a shell+      or ctrl-c and completely exiting ghci if you are doing runInGhci within ghci.+  <li>~/happs-tutorial> mv _local _local.20081001-0917am.bak+  <li>Start the happs server again. All users, profiles, jobs, and sessions should be gone,+      and a new _local directory with nothing in it should have been created.+      A fresh start.+  <li>If you want your old data back, backup your existing _local directory somewhere safe+      (or just rm -rf if you want to get rid of it)+      , and rename the .bak directory back to _local+</ul>++The above procedure raises some questions.++<p>Q: Do you have to shut down the HAppS server every time you migrate data to a new schema?++<p>A: As far as I can tell, yes, you do, at least for the HAppS 0.9.2.1 release. +      <br>There is code under development in HAppS head that supposedly allows schema migration without +          shutting down HAppS, by using multiple HAppS instances and storing your data in a +          distributed way. But to keep things straightforward, in particular the zero-hassle+          HAppS install, I'm not going to cover anything on this tutorial that hasn't been+          released on hackage.+       <br>If your web startup requires zero downtime during data migrations,+           HAppS probably isn't for you, at least not yet.+           Then again, schema migrations using a traditional rdbms are+	   <a href="http://www.squidoo.com/database-refactoring">no picnic</a> either.++<p>Q: Is macid safe? Could I wake up one day with corrupted data under _local and no way to recover from it?+<p>A: Let's be realistic. +      Compared to, say, mysql, HAppS hasn't been stress-tested much in critical high-volume web sites. +      Or if it has, no one has shared their experiences.+      (This is something I hope to change by making it easier to get started with HAppS.)+      So whatever the HAppS developers say about reliability, personally I wouldn't be surprised if I encountered +      some kind of data corruption problem as an early adopter.+   <p> That said, the unix filesystem is pretty good at not losing your data -- +       a point <a href="http://www.paulgraham.com/vwfaq.html">famously</a> made by startup guru paul graham,+       who created viaweb (now yahoo stores) with all the application state in flat files.++   $! This might not have worked so well if the application required transactional integrity -- +   say, moving money between accounts. But using macid, if you set up your state appropriately, it should. !$++   <p> If you use windows or mac, you probably believe these filesystem are pretty reliable too.++   <p>Taking a closer look at what is under _local...+<p>+thartman@thartman-laptop:~/happs-tutorial/_local/happs-tutorial_state>ls -lth+<br>total 12K+<br>-rw-r--r-- 1 thartman thartman   0 Oct  1 13:55 events-0000000003+<br>-rw-r--r-- 1 thartman thartman   0 Oct  1 11:55 events-0000000002+<br>-rw-r--r-- 1 thartman thartman 792 Oct  1 11:04 events-0000000001+<br>-rw-r--r-- 1 thartman thartman 491 Oct  1 11:00 events-0000000000+<br>-rw-r--r-- 1 thartman thartman  25 Oct  1 10:59 current-0000000000+<br>thartman@thartman-laptop:~/happs-tutorial/_local/happs-tutorial_state>+++<p> Macid serialization works by writing state change event data+    one file at a time. At server startup, HAppS "replays" all the information here+    in the order specified by the file names.+    This is similar to the <a href="http://en.wikipedia.org/wiki/Transaction_log">database transaction log</a>+    used by many rdbms systems.+<p> So, if I woke up one morning with my HAppS application in a corrupt, non-startable state and +    my inbox full of angry customer email, probably what I would do is move files, one at a time,+    out of the serialization directory, last-file created first, and keep trying to restart HAppS.++<p> Q: What if my hard drive dies and I can't get my data back?+<p>    A: Like with any other data storage system, if there's valuable data, you need to be making backups.+       In the case of HAppS data stored under _local, I would probably be <a href="rsync.net">rsyncing</a>+       the _local directory to a remote server, or maybe multiple remote servers for extra safety.+       For now I am not worried+       about securing data, but when that day comes I'm pretty confident I'll be ok.+      +<p> Let's now populate our web application with <a href="/tutorial/macid-dummy-data">dummy data</a>.
+ templates/maciddummydata.st view
@@ -0,0 +1,20 @@+<h3>Populate your job board with dummy data</h3>++<p>Assumng you are following along with the tutorial and running locally, you now have a job board with one user+   ("testuser") and no jobs,  unless you took the time to create additional test data manually.++<p>+When quickly hacking together a data-driven website, populating your app with dummy data is a chore you+want to avoid wasting time on, so let's see how to do that. ++<p>Firstly, restart HAppS in a pristine state by either deleting or backing up your _local data directory+   as described earler.++<p>Now, click <a href="/tutorial/initializedummydata">this link</a>.++<p>If everything worked right, you should now have two <a href="/tutorial/consultants">users</a> and a+   couple hundred <a href="/tutorial/jobs">jobs</a> worth of test data+   displaying in your jobs site.++<p><a href="/tutorial/macid-updates-and-queries">What just happened?</a>+
+ templates/macidmigration.st view
@@ -0,0 +1,1 @@+<h3>Macid migration</h3>
+ templates/macidstresstest.st view
@@ -0,0 +1,127 @@+<h3>Macid stress test</h3>++<p>HAppS is a new, relatively unproven technology.++<p>So I asked myself this question.+   Will HAppS allow me to scale the toy job board I created for happs-tutorial +   into a high-volume, high concurrency,+   large-user count type job board?+   You know, the kind that <a href=http://www.monster.com>might make money</a>?++$! <p>Like all the world's great businessmen, I then pulled some numbers out of my ass. !$+<p>What will make money in the real world is impossible to say until you try it, +   but I attempted to come up with some not-completely-ridiculous estimates anyway. +   I figure for a typical ad-supported web 2.0 type project, each user is worth \$0.50 cent/year.+   So if you have 100,000 users, you are probably not rolling in dough, but hopefully you can at least pay your rent.++<p>Therefore, once I had the basic state functionality working I decided to see if I could scale my toy job board+   up to 100,000 users. To make things more realistic, each user would have 200 jobs.+   So, this would be the equivalent of 20,100,000 data records if we were using an rdbms: +   100,000 users and 20 million jobs.++<p>I failed to achieve this goal. ++<p>Or, more optimistically,+   I am declaring defeat for the time being so I can put a version 5 release up on hackage+   and share what I learned with a wider audience. In a future release, I still intend  to show how you can scale +   a HAppS app up to large numbers of users! :)++<p>The most important lesson I learned is that putting all application state into macid won't work if you +   have a lot of data -- not even if you have one of those <a href="tk 16 gb box at amazon">heavy iron</a>+   boxen from amazon web services, or for that matter a whole virtual data center full of them.+   16GB of RAM gets used up surprisingly fast if you are using ram for everything.+   The cloud is no substitute for+   <a href="tk ebay link">thinking your application's transactional requirements through</a>+   and coding to them.+  +<p>So, if I make good on the promise I made above about scaling this toy application up to 20,000,000 data records, you +   will be getting some future version of this tutorial where macid is being used+   in conjunction with disk based storage: either an rdbms or haskell data values serialized to disk, +   I haven't decided yet.+   Assuming I can get this working, my intuition is that this solution will be +   scale up to a lot more than my original goal of 100K users,+   and do so in a cloud computing-friendly way, so stay tuned.+<p>++<p>Another lesson learned is that the macid data structure can have a dramatic effect on application scaleability.+   In version 4 of happs-tutorial, I was using sets to store users and a linked list for jobs. Lookup of user/job values +   required finding the first value in the set where the appropriate record field matched the desired criteria.+   I also had some quirk where modifying a job value resulted in writing the entire user (with all attached jobs)+   to state, which was resulting in huge serialization files. (Thanks to LemmiH on the happs group for diagnosing this.)+   When I switched to using maps for macid state,+   with UserName and JobName values as keys, and was more careful about serialization, I had dramatic performance gains.+   Not dramatic enough to get me up to 100,000 users, true -- but initially I was seeing my server slow +   to a crawl after inserting a couple  hundred+   users, and now I can handle 10,000 users comfortably on an 8GB box. I suspect that the macid state I am using now +   can be optimized even further -- though at some point, as I said, algorithmic finesse won't help anymore and +   part of the state will have to be moved out of RAM and into hard disk.+   +<p>Finally, I created what appears to be the first macid stress test in the public domain. I actually created 3 tests, all of which are activated by clicking a link with an integer argument in the url, that specifies how many users to insert. In all cases, there are 200 jobs inserted for each user, the equivalent of 4200 records in a tradiational rdbms.++<p><font color=orange>+   Before running any of these stres tests yourself, I recommend limiting the amount of swap your happs server+   is allowed to use via the ulimit command. Otherwise stressing HAppS will result in your computer grinding to a crawl.+   But if you limit your swap, the process just gets killed, which is a lot less annoying. +   Since every macid action is serialized, you will still see the data your stress test+   inserted up to the point it was killed when you reestart HAppS. I have ++   <p>ulimit -v 262144 # (256M of swap)+ +   <p>set in .bashrc.</font>++ <p>If you click on <a href=/tutorial/stresstest/atomicinserts/20>stresstest/atomicinserts/20</a> the result is that 20 users +    get inserted, each with 200 jobs: about 4000 macid transactions total.+    Each job insertion is its own event, so macid winds up having to do a lot of work.+    This is useful for seeing how effectively happs deals with getting hammered by insert transactions,+    but it's impractical for inserting large amounts of data.+ + <p>If you click on <a href=/tutorial/stresstest/onebiginsert/20>stresstest/onebiginsert/20</a> +    the effect is the same, 20 users and 4000 jobs get inserted, but the insertion is performed with one big+    macid transaction. Onebiginsert is faster than atomicinserts for small number of users, but it won't work +    with 1000 users, all I got was a churning hard disk that eventually had to be kill -9ed.+    From this I conclude that large maps don't play well with serialization.++ <p>I found that what worked best in practice for inserting large quantities of data+    was <a href=/tutorial/stresstest/atomicinsertsalljobs/20>stresstest/atomicinsertsalljobs/20</a>.+    Here, there is one insert per user, but all jobs get inserted at once. +    Using this method of insertion, I was able to insert 1000 users at a time on my junky old laptop,+    and 4000 users at a time on a heftier server with 8G of ram. On the hefty server I was able to get up to +    20,000 users (4 million jobs) before performance degraded because of the amount of data being kept in ram.+    (With 10,000 users it ran without breaking a sweat, 20,000 was doable but went into swap.)+++$! <p>To be honest, maybe not. !$++$!+<p>I have done some preliminary testing to answer this question, and so far the results have been disappointing.++<p>I am hoping that I am doing something wrong, and that there is a way of using macid effectively+   for more than just toy applications. I also asked the HAppS googlegroup for help, and if there is a +   solution for the problems I found I will definitely be sharing it in the tutorial, so stay tuned.+   +<p>I am seeking feedback from HAppS experts and educated users on the following questions: +<ul>+  <li>Is building a heavy duty website like monster.com in HAppS a realistic goal -- say, in the next twelve months?+  <li>Are there certain types of web apps that are <i>unlikely</i> to work well with the HAppS web architecture?+  <li>Are there changes I can make to my toy app's architecture --+      be it data structures, buying new hardware, whatever -- that will enable me to get good performance+      against the stress test described below?+  <li>Are there other HAppS stress tests in the public domain, and what are the results so far?+</ul>++<p>Thanks in advance for anybody who can help me <a href=http://www.youtube.com/watch?v=akaD9v460yI>push HAppS to 11</a>!++$!++<p>Still chugging... At 1:03, about 15 minutes after we started, the 200th+   user is inserted. The jobs page loads slowly, but that's to be expected with +   a 20000 jobs long pagination. I ctrk-c out, and restart. The state file for the last experiment+   is 542M large. The jobs app gives the startup message ("exit :q ghci completely...")+   but it seems to be starting very slowly, and gives no feedback why.+   Also emacs is sluggish. I restarted at 1:10, it's 1:14 and localhost:5001 still doesn't show anything.  +   At 1:20 http://localhost:5001 loads normally.+   +++!$+
+ templates/macidupdatesandqueries.st view
@@ -0,0 +1,139 @@+<h3>Macid updates and queries</h3>++<p>Clicking <a href="/tutorial/initializedummydata">initializedummydata</a> passed off control to +  spAddDummyData in <a href="/src/Controller.hs">Controller.hs</a>. Keep that .hs file open in another window,+  scrolled down to spAddDummyData, to follow along.++<p>In spAddDummyData, pay particular attention to these two statements++<ol>+  <li>us <- query AskDatastore +  <li>update InitializeDummyData+</ol>++<p>There's a lot of type hackery and template haskell machinery behind those two lines. +   But operationally, here's what is happening.++<p>spAddDummyData queried the macid state, and checked whether the datastore, which is a set of users, is the empty set.+   If it's the empty set, there is no existing data and the dummy data can be added safely, and then +   a "dummy data success" page gets displayed. Otherwise no update happens and you get an error page.++<p>The macid state of our job board is defined in AppStateSetBased</a>,+   in the AppState data declaration. As you may recall, we have seen AppState before, in runserver,+   in our lesson on the <a href="/tutorial/main-function">main module</a>.+   AppState's use in startSystemState, in Main.hs, is what makes it the primary state component of our web app.++<p>From <a href="/src/AppStateSetBased.hs">AppStateSetBased.hs</a>+     (for optimal learning, open this file in another window):++<i>+<p>-- Think of appdatastore as the database in a traditional web app.+<br>-- Data there gets stored permanently+<br>-- Data in appsessions is stored permanently too, but we don't care as much about its persistence,+<br>-- it's just to keep track of who is logged in at a point in time.+<br>data AppState = AppState {+<br>&nbsp;&nbsp;  appsessions :: Sessions SessionData,  +<br>&nbsp;&nbsp;  appdatastore :: S.Set User+<br>&nbsp;&nbsp; deriving (Show,Read,Typeable,Data)    +<br>instance Version AppState+<br>\$(deriveSerialize ''AppState) +</i>++<p>This is the pattern for a data declaration for data that will be used by the macid state system.++<ul>+  <li>You make the data declaration pretty much in the usual way+  <li>You set the necessary LANGUAGE pragmas for the macid machinery to work (see top of AppStateSetBased.hs)+  <li>You derive Read, Show, Typeable, and Data+  <li>You declare your data type an instance of Version (to allow migrations)+  <li>You have template haskell generate boilerplate that makes AppState an instance of Serializeable.+</ul>++<p>AppState depends on the User and Sessions data types. The User data type in turn depends+   on the Job and ConsultantProfile data types. Each of these data declarations follows this same pattern,+   which you should verify for yourself by reading their data declarations in+   <a href="/src/SerializeableUsers.hs">SerializeableUsers.hs</a> and+   <a href="/src/SerializeableSessions.hs">SerializeableSessions.hs</a>.+   As long as each subcomponent has been declared in the right way, components depending upon them can+   be derived more of less hassle-free.+   +<p>Because AppState is the top-level component, in addition to Read / Show / Serializeable / Version,+   it is also an instance of Method and Component.++<p>The Component instance just defines an initial value for macid: no users, no sessions.++<p>The Method instance is generated by template haskell, by mkMethods. +   mkMethods also generates the upper case Update and Query data declarations,+   values of which which are suitable input to query/update within a server part. ++<p>In the dummy data insertion above, we saw an example of this, with+   <i>query AskDatastore</i> and <i>update InitializeDummyData</i>.++<p>AskDatastore and InitializeDummyData are generated with template haskell, based on the definitions of +   askDatastore and initializeDummyData, in AppStateSetBased.++<p>If you do++<p>*Main> :browse AppStateSetBased++<p>you'll see a number of function/datatype pairs defined via template haskell, where the datatype has the+   same name as the function, except it is upper-cased. askDatastore / AskDatastore, getUser / GetUser,+   changePassword / ChangePassword, and so on. In every case, the upper-cased datatype is generated by +   template haskell, whereas the lowercase function is a normal function.++<p>Think of query actions as the macid equivalent of a select statement in sql, and update as the equivalent+   of update/delete.++<p>The functions that query actions are based on are in MonadReader.+   askDatastore puts itself into MonadReader by its use of ask. This is a bit obfuscated by type systems+   and the complicated types, but if you <a href="/tutorial/ghci-floundering-askdatastore">flounder</a> around enough in ghci you can+   fit askDatastore into a concrete type that makes this explicit.++<p>The functions that update actions are based on are in MonadState.+   InitializeDataStore puts itself into MonadState by the use of modify in a function that it depends on.++<p>Alhough it is obvious that AskDatastore is a query action from its name,+   you can't tell that it's a query action by asking ghci -- only that it is part of the macid system.++<p>*Main> :i AskDatastore+<br>data AskDatastore = AskDatastore+<br>&nbsp;&nbsp;        -- Defined at src/AppStateSetBased.hs:(178,2)-(191,27)+<br>instance Serialize AskDatastore+<br>&nbsp;&nbsp;  -- Defined at src/AppStateSetBased.hs:(178,2)-(191,27)+<br>instance Version AskDatastore+<br>&nbsp;&nbsp;  -- Defined at src/AppStateSetBased.hs:(178,2)-(191,27)++<p>However, if you ask ghci about askDatastore, upon which you know AskDatastore is based -- +   because of the lowercase -- you <i>can</i> confirm that it is a query.++<p>*Main> :i askDatastore+<br>askDatastore :: Query AppState (Data.Set.Set User)++<p>The same goes for InitializeDummyData.++<p>So remember, if you are reading some happs code and come across a macid action and aren't certain +   whether it's a query or an update, a quick way to find out is to ask ghci for information about +   the lowercase function it's based on.++<p>Macid is one of the most powerful features of HApps, but I found it hard to learn. +   There are a lot of types, and those signatures can get cryptic. +   It took me a while to get as comfortable with the macid way of doing things as I was with sql.+   But when I finally got it I was glad I made the effort.+   I really feel that this is a much more powerful, straightforward way of+   laying out a web app's functionality, and that I will win back the invested time+   with more rapid development of future websites. ++<p>To get comfortable with macid++<ul>+  <li>read and understand the .hs files that define the job board state:+        AppStateSetBased.hs, SerializeableUsers.hs, and SerializeableSessions.hs+  <li>Play with your locally installed job board while reading along with the+      source code. See how queries and updates are used in the job board:+      when logging in, when creating or deleting jobs,+      when editing a user profile, and so on.+  <li>start using HAppS with macid for your own web apps+</ul>+++
templates/mainfunction.st view
@@ -1,11 +1,15 @@ <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>Have a look at <a href="/src/Main.hs">Main.hs</a> module 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>Two bits of code that should jump out at you as being important are  -<p>The entrypoint function has to do with the HAppS state system, and we'll pospone learning about it for later.</p>+<ol>+  <li>startSystemState (Proxy :: Proxy AppState) -- start the HAppS state system+  <li>simpleHTTP (Conf {port=p}) controller -- start serving web pages+</ol>++<p>We'll pospone learning about the HAppS state system (the first line) 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>
templates/menubar.st view
@@ -2,7 +2,7 @@      <td>             $ menubarMenu $      </td>-     <td width=250> $! td is for alignment only, an ugly hack, and it renders bad if you resize the window.+     <td width=100> $! 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>
templates/menulinkselected.st view
@@ -1,1 +1,1 @@-<a class=menuitemSelected href=$url$>$anchortext$</a>+<a class=menuitemSelected href="$url$">$anchortext$</a>
templates/menulinkunselected.st view
@@ -1,1 +1,1 @@-<a class=menuitem href=$url$>$anchortext$</a>+<a class=menuitem href="$url$">$anchortext$</a>
− templates/paginationlinkselected.st 
@@ -1,1 +0,0 @@-<a class=menuitemSelected href=$baselink$?currentpage=$currentpage$&resultsPerPage=$resultsPerPage$> $from$ - $to$ </a>
− templates/paginationlinkunselected.st 
@@ -1,1 +0,0 @@-<a class=menuitemUnSelected href=$baselink$?currentpage=$currentpage$&resultsPerPage=$resultsPerPage$> $from$ - $to$ </a>
templates/prerequisites.st view
@@ -10,7 +10,7 @@ 	  <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>+	                      You may have to darcs get HAppS-State head, and/or tweak the cabal file.</a>  	  </li>  	</ul>
− templates/register.st 
@@ -1,13 +0,0 @@-<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/registered.st view
@@ -0,0 +1,3 @@+<h3>Registration successful</h3>++<p>Thanks for registering. You can now post a consultant profile, or jobs that you need help with.
templates/runtutoriallocally.st view
@@ -2,7 +2,7 @@  <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>This tutorial is cabalized. You can install it, and chase down all the HAppS dependencies it needs, simply by doing  <p>cabal install happs-tutorial  <p>The cabal installation may take up to an hour, mainly because the@@ -17,6 +17,21 @@     <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>I cabalized happs-tutorial was for the dependency chasing you get with cabal install,+not for actually running it.+++<p>Cabal installs an executable somewhere that you can run, but the tutorial pages won't display because+the executable needs template files to display pages correctly. To actually run the tutorial locally, copy the +happs-tutorial.tar.gz distribution file that cabal downloaded -- probably somewhere under  ~/.cabal if you're on linux: ++<p><i>find ~/.cabal | grep -i happs-tutorial</i>++<p>should show you a tar file. Or you can just download the tar file from+<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/happs-tutorial">hackage</a>.+Once you have the tar file, untar this somewhere, cd into that, build and run here as described below.+Or, you could darcs get happs-tutorial and run there. + <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@@ -26,6 +41,16 @@ 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>Every so often, when starting via runInGhci, you may get an error message like:++<p>*Main> runInGhci+happs tutorial running in ghci.+exit :q ghci completely and reenter ghci, before restarting.+*** Exception: _local/happs-tutorial_state/events-0000000006: openFile: resource busy (file is locked)++<p>Don't worry about it. Every time I get this error I simply run runInGhci again, and the second time it always works.+ <p> You may also want to <a href="start-happs-on-boot">start HAppS on boot</a>.
− templates/simplelink.st 
@@ -1,1 +0,0 @@-<a href="$url$">$anchortext$</a>
+ templates/stresstestcompleted.st view
@@ -0,0 +1,5 @@+<h3>Stress Test for $stressTestName$ Completed</h3>++Users $first$ to $last$ have been inserted.+<br>+Stress test time: $testTime$
templates/stringtemplatebasics.st view
@@ -2,17 +2,19 @@  <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>*Main Misc View Text.StringTemplate> do templates <- directoryGroupSafer "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,+  <li>The directoryGroupSafer 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.+      of StringTemplates. It is a modification of the directoryGroup command that comes with Text.StringTemplate package,+      which ignores email backup files-type files with punctuation, that cause annoyance+      when using HStringTemplate functions. +      <br>*Main Misc View Text.StringTemplate> :t (directoryGroupSafer :: String -> IO (STGroup String))+      <br>The actual type of directoryGroupSafer is a little less concrete than the above, and uses type classes.+      <br>Our :t command gives directoryGroupSafer 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@@ -46,3 +48,4 @@     <li><a href="http://fmapfixreturn.wordpress.com/tag/hstringtemplate/">fmapfixreturn, Sterling Clover's blog</a> </ul> +<p>And now, on to <a href="/tutorial/introduction-to-macid">macid</a>.
templates/templatesdontrepeatyourself.st view
@@ -30,20 +30,30 @@  <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" +<br>*Main Misc View Text.StringTemplate> do templates <- directoryGroupSafer "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>*Main Misc View Text.StringTemplate> do templates <- directoryGroupSafer "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>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 a full page from ghci, as it would appear for a logged in user, try -<p>*Main Misc View Text.StringTemplate> do html <- tutlayout  [("loggedInUser","DarthVader")] "templates-dont-repeat-yourself"; writeFile "output.html" html+<p>*Main Misc View Text.StringTemplate> do templates <- directoryGroupSafer "templates"; writeFile "output.html" \$ tutlayout (RenderGlobals templates (Just \$ User "Darth" "" undefined undefined)) [] "templates-dont-repeat-yourself" +<p>Note that tutlayout is a pure function. The only IO is in fetching the templates with directoryGroupSafer.+Currently the tutorial does a directory read every time the main webserver handler loops, but it could just+as easily only do the directory read once at app startup time. This would mean a lot less disk reads, but+of course you would have to stop/start the server whenever a template changed to see your changes. Which setup+you want depends on whether you are willing to sacrifice development convenience for a snappier server.+I opted for convenience, but it would be easy to change -- just move the directoryGroupSafer command out of the+tutorial handler and into Main.hs before the server starts. Try it as an exercise if you like.++<p>As a side note, you can get away with passing undefined values to the tutlayout function because+it never attempts to evaluate the profile and jobs bits of the User data object. That's lazy evaluation at work. <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.
templates/toc.st view
@@ -6,12 +6,19 @@  , ("/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/stringtemplate-basics","stringtemplate basics")  + , ("/tutorial/debugging","debugging")+ , ("/tutorial/get-and-post","form data: get and post")+ , ("/tutorial/file-uploads","form data: file uploads")+ , ("/tutorial/introductiontomacid","introduction to macid")  + , ("/tutorial/macid-data-safety","using macid safely")  + , ("/tutorial/macid-dummy-data","macid dummy data")+ , ("/tutorial/macid-updates-and-queries","macid updates and queries")+ , ("/tutorial/macid-migration","changing the data model")+ , ("/tutorial/macid-stress-test","macid stress test")+ , ("/tutorial/foreignchars","foreign characters")  , ("/tutorial/start-happs-on-boot","cron jobs")  , ("/tutorial/thanks","thanks")+ , ("/tutorial/ghci-floundering-askdatastore","appendix (floundering in ghci)") ]