happs-tutorial 0.8 → 0.8.1
raw patch · 40 files changed
+619/−844 lines, 40 filesdep +happstackdep +happstack-ixset
Dependencies added: happstack, happstack-ixset
Files
- happs-tutorial.cabal +4/−5
- src/AppStateGraphBased.hs +9/−11
- src/Controller.hs +8/−5
- src/ControllerBasic.hs +0/−1
- src/ControllerGetActions.hs +23/−25
- src/ControllerMisc.hs +29/−26
- src/ControllerPostActions.hs +57/−76
- src/ControllerStressTests.hs +9/−12
- src/FirstMacid.hs +17/−5
- src/IxSetExample.hs +137/−0
- src/Main.hs +9/−2
- src/Misc.hs +3/−10
- src/MiscMap.hs +2/−7
- src/MultiExample1.hs +1/−3
- src/MultiExample2.hs +1/−3
- src/MultiExample3.hs +1/−3
- src/Redirector.hs +0/−9
- src/StateTExample.hs +3/−1
- src/StateVersions/AppState1.hs +106/−87
- src/UniqueLabelsGraph.hs +3/−3
- src/View.hs +25/−43
- src/add10000users.hs +0/−14
- src/gentable.hs +0/−13
- src/migrationexample/CreateState1.hs +24/−9
- src/migrationexample/MigrateToState2.hs +5/−11
- src/migrationexample/MigrateToState3.hs +0/−23
- src/migrationexample/README +0/−55
- src/migrationexample/StateVersions/AppState1.hs +27/−39
- src/migrationexample/StateVersions/AppState2.hs +34/−33
- src/migrationexample/StateVersions/AppState3.hs +0/−64
- templates/cookies.st +6/−17
- templates/footer.st +2/−0
- templates/ixset.st +11/−0
- templates/macidlimits.st +3/−4
- templates/macidmigration.st +30/−218
- templates/multimaster.st +2/−1
- templates/toc.st +3/−1
- templates/whatsnew.st +7/−0
- templates/yourfirsthappstack.st +1/−1
- templates/yourfirstmacid.st +17/−4
happs-tutorial.cabal view
@@ -1,5 +1,5 @@ Name: happs-tutorial-Version: 0.8+Version: 0.8.1 Synopsis: A Happstack Tutorial that is its own web 2.0-type demo. Description: A nice way to learn how to build web sites with Happstack @@ -24,7 +24,6 @@ src/migrationexample/*.hs src/migrationexample/*.lhs src/migrationexample/StateVersions/*.hs- src/migrationexample/README Cabal-Version: >= 1.6 @@ -49,8 +48,8 @@ View ghc-options: -Wall Build-Depends: base, HStringTemplate, HStringTemplateHelpers, mtl, bytestring,- happstack-server, happstack-data, happstack-state,- containers, pretty, pureMD5, directory, filepath, hscolour, HTTP, safe,- old-time, parsec, happstack-helpers, DebugTraceHelpers+ happstack, containers, pretty, pureMD5, directory, filepath, hscolour, + HTTP, safe, old-time, parsec, happstack-helpers, DebugTraceHelpers,+ happstack-server, happstack-data, happstack-ixset, happstack-state if flag(base4) Build-Depends: base >=4 && <5, syb
src/AppStateGraphBased.hs view
@@ -60,14 +60,14 @@ (s :: AppState ) <- ask return . appdatastore $ s -askUsersGraph = askDatastore >>= return . socialgraph+askUsersGraph = fmap socialgraph askDatastore askUsersSet :: Query AppState (S.Set User) -askUsersSet = askUsersGraph >>= return . labelsetFromGraph+askUsersSet = fmap labelsetFromGraph askUsersGraph askSessions :: Query AppState (Sessions SessionData)-askSessions = return . appsessions =<< ask+askSessions = fmap appsessions ask -- modUsers :: ( S.Set User -> S.Set User ) -> Update AppState () modGraph :: ( Gr User Float -> Gr User Float ) -> Update AppState ()@@ -79,7 +79,7 @@ isUser :: String -> Query AppState Bool isUser name =- return . (S.member name) . (setmap username) =<< askUsersSet+ 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@@ -113,23 +113,21 @@ in SocialGraph $ maybe usersgraph resetP mbU getUser :: String -> Query AppState (Maybe User)-getUser u =- askUsersGraph >>=- return . lookupUser ((==u) . username)--lookupUser f users = find f . S.toList . labelsetFromGraph $ users+getUser u = liftM (lookupUser ((==u) . username)) askUsersGraph+ +lookupUser f = find f . S.toList . labelsetFromGraph 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+ modSessions $ Sessions . M.insert key u . unsession return key delSession :: SessionKey -> Update AppState ()-delSession sk = modSessions $ Sessions . (M.delete sk) . unsession+delSession sk = modSessions $ Sessions . M.delete sk . unsession getSession::SessionKey -> Query AppState (Maybe SessionData)
src/Controller.hs view
@@ -42,12 +42,15 @@ -- the order of the static content handler matter anyway? -- At the very least, fileServer should have a highly visible comment warning about this problem. staticfiles - `mappend` ( tutorial tDirGroups dynamicTemplateReload allowStressTests ) + `mappend` tutorial tDirGroups dynamicTemplateReload allowStressTests `mappend` simpleHandlers `mappend` myFavoriteAnimal `mappend` (return . toResponse $ "Quoth this server... 404.") --- with diretoryGroupsOld (lazy readFile), appkiller.sh causes crash+-- with directoryGroupsOld (lazy readFile), appkiller.sh causes crash+-- directoryGroupsHAppS is defined in happstack-helpers. This is where+-- the assumption that all the templates lie in a subdirectory called+-- templates comes from getTemplateGroups :: (Stringable a) => IO (M.Map FilePath (STGroup a)) getTemplateGroups = directoryGroupsHAppS "templates" @@ -77,7 +80,7 @@ , dir "changepassword" (methodSP POST $ changePasswordSP rglobs) , dir "editconsultantprofile" (methodSP GET (viewEditConsultantProfile rglobs) `mappend` - (methodSP POST (processformEditConsultantProfile rglobs)))+ methodSP POST (processformEditConsultantProfile rglobs)) , dir "editjob" (methodSP GET $ viewEditJobWD rglobs) , dir "deletejob" (methodSP GET $ deleteJobWD rglobs)@@ -97,12 +100,12 @@ -- 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) ]+ , dir "atomicinsertsalljobs" (spStressTest allowStressTests ("atomic inserts, all jobs at once",insertusAllJobs) rglobs)] , spJustShowTemplate rglobs ] ] spJustShowTemplate :: (Monad m) => RenderGlobals -> ServerPartT m Response-spJustShowTemplate rglobs = lastPathPartSp0 (\_ tmpl -> return $ tutlayoutU rglobs [] tmpl ) +spJustShowTemplate rglobs = lastPathPartSp0 $ const (return . tutlayoutU rglobs []) spStressTest :: (MonadIO m) => Bool -> (String, Users -> WebT m a) ->
src/ControllerBasic.hs view
@@ -2,7 +2,6 @@ import Happstack.Server import Happstack.Helpers-import Misc import Data.Monoid import Text.StringTemplate.Helpers import Control.Monad.Trans
src/ControllerGetActions.hs view
@@ -6,7 +6,7 @@ import Happstack.State import Data.List-import Happstack.Helpers.HtmlOutput+import Happstack.Helpers import qualified Data.ByteString.Char8 as B import ControllerMisc import StateVersions.AppState1@@ -19,17 +19,16 @@ viewConsultants :: RenderGlobals -> ServerPartT IO Response viewConsultants rglobs = do- (PaginationUrlData currB resPB currP resPP) <- getData >>= maybe mzero return- consultants <- return . map unusername- =<< return . M.keys . M.filter (consultant . userprofile) . users- =<< query AskDatastore+ PaginationUrlData currB resPB currP resPP <- getData'+ consultants <- fmap (map unusername . M.keys . M.filter (consultant . userprofile) . users) $ + query AskDatastore let p = Pagination { currentbar = currB , resultsPerBar = resPB , currentpage = currP , resultsPerPage = resPP , baselink = "tutorial/consultants" , paginationtitle = ""} - consultantCells = map ( (:[]) . userlink ) consultants+ consultantCells = map ( return . userlink ) consultants consultantTable = paintTable Nothing consultantCells (Just p) @@ -37,13 +36,13 @@ -- basically an incentive to register tmplattrs = maybe (def ++ [("registerAsConsultant","list yourself as a Happstack developer")]) (const def)- (return . sesUser =<< mbSession rglobs)+ (mbUser rglobs) where def = [("consultantList", consultantTable)] return . tutlayoutU rglobs tmplattrs $ "consultants" viewConsultantsWanted :: RenderGlobals -> ServerPartT IO Response viewConsultantsWanted rglobs = do- (PaginationUrlData currB resPB currP resPP) <- getData >>= maybe mzero return+ (PaginationUrlData currB resPB currP resPP) <- getData' consultantswanted <- return . map unusername . M.keys =<< return . M.filter (not . M.null . unjobs . jobs ) . users =<< query AskDatastore@@ -54,19 +53,19 @@ , baselink = "tutorial/consultantswanted" , paginationtitle = ""} - consultantCells = map ( (:[]) . userlink ) consultantswanted+ consultantCells = map ( return . userlink ) consultantswanted consultantTable = paintTable Nothing consultantCells (Just p) -- an incentive to register- tmplattrs = maybe (def ++ [("postJob","post a HAppS job")])+ tmplattrs = maybe (def ++ [("postJob","post a Happstack job")]) (const def )- (return . sesUser =<< mbSession rglobs)+ (mbUser rglobs) where def = [("ulist", consultantTable)] return . tutlayoutU rglobs tmplattrs $ "consultantswanted" viewJobs :: RenderGlobals -> ServerPartT IO Response viewJobs rglobs = do- (PaginationUrlData currB resPB currP resPP) <- getData >>= maybe mzero return+ PaginationUrlData currB resPB currP resPP <- getData' rsListAllJobs <- query ListAllJobs let pag = Pagination { currentbar = currB , resultsPerBar = resPB@@ -89,14 +88,14 @@ -- 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")]) (const def) (return . sesUser =<< mbSession rglobs)+ tmplattrs = maybe (def++[("postJob","post a Happstack job")]) (const 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 = - case (return . sesUser =<< mbSession rglobs) of+ case mbUser rglobs of Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate" Just currU -> do mbUis <- query $ GetUserInfos currU @@ -110,9 +109,8 @@ 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)+ , ("blurb", B.unpack . blurb $ cp)+ , ("contact", B.unpack . contact $ cp) , ("listAsConsultantChecked", checkedStringIfTrue $ consultant cp ) , ("profile",showPr) ]@@ -120,7 +118,7 @@ viewEditJob :: UserName -> JobName -> RenderGlobals -> ServerPartT IO Response viewEditJob pBy jN rglobs = - case ( return . sesUser =<< mbSession rglobs )of+ case mbUser rglobs of Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate" Just currU -> if currU /= pBy@@ -148,8 +146,8 @@ pageMyJobPosts :: RenderGlobals -> ServerPartT IO Response pageMyJobPosts rglobs = do - mbUis <- getGlobsUserInfos rglobs -- (query . GetUserInfos) =<< ( return . mbUser $ rglobs )- case (mbUis :: Either String (UserName,UserInfos)) of+ mbUis <- getGlobsUserInfos rglobs+ case mbUis of Left err -> return . tutlayoutU rglobs [("errormsg", err)] $ "errortemplate" Right (currU,uis) -> do let jobPostsTable = paintUserJobsTable (unusername currU) (M.toList . unjobs . jobs $ uis)@@ -157,7 +155,7 @@ getGlobsUserInfos :: Monad m => RenderGlobals -> ServerPartT IO (m ( UserName,UserInfos) ) getGlobsUserInfos rglobs =- case (return . sesUser =<< mbSession rglobs) of+ case (fmap sesUser $ mbSession rglobs) of Nothing -> fail "getUserInfos, no user in globals" Just un -> do mbUis <- query $ GetUserInfos un@@ -167,7 +165,7 @@ viewJob :: (MonadIO m) => RenderGlobals -> ServerPartT m Response viewJob rglobs = do- JobLookup pBy jN <- getData >>= maybe mzero return+ JobLookup pBy jN <- getData' mbJ <- lookupJob pBy jN case mbJ of Nothing -> return $ tutlayoutU rglobs [("errmsg", "no job found")] "errortemplate"@@ -175,10 +173,10 @@ userProfile :: (MonadIO m) => RenderGlobals -> ServerPartT m Response userProfile rglobs = do- UserNameUrlString user <- getData >>= maybe mzero return+ UserNameUrlString user <- getData' mbCP <- do mbUis <- query (GetUserInfos user) - return $ mbUis >>= (return . userprofile)+ return $ fmap userprofile mbUis case mbCP of Nothing -> return $ tutlayoutU rglobs [("errormsgProfile", "bad user: " ++ (B.unpack . unusername $ user) )] "viewconsultantprofile"@@ -197,7 +195,7 @@ -- maybe can consolidate deleteJob :: UserName -> JobName -> RenderGlobals -> ServerPartT IO Response deleteJob pBy jN rglobs = - case (return . sesUser =<< mbSession rglobs) of+ case mbUser rglobs of Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate" Just currU -> if currU /= pBy
src/ControllerMisc.hs view
@@ -15,29 +15,24 @@ import Happstack.Helpers import qualified Data.ByteString.Char8 as B ---import Text.StringTemplate.Helpers--- (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+-- The final value is HtmlString so that the Happstack machinery does the right thing with toMessage.+-- If the final value was left as a String, the page would display as text, not html.+-- The only difference is in the content types between the ToMessage instances. tutlayoutU :: RenderGlobals -> [(String,String)] -> String -> Response-tutlayoutU rglobs attrs tmpl = ( toResponse . HtmlString . tutlayout rglobs attrs ) tmpl+tutlayoutU rglobs attrs = toResponse . HtmlString . tutlayout rglobs attrs getmbSession :: Request -> IO (Maybe SessionData)-getmbSession rq = maybe ( return Nothing ) ( query . GetSession ) ( getMbSessKey rq )+getmbSession = maybe ( return Nothing ) ( query . GetSession ) . getMbSessKey -- 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' :: (MonadIO m) => RenderGlobals -> UserName -> String -> ServerPartT m Response-startsess' ( RenderGlobals origRq ts _ ) user landingpage = do +startsess' :: (MonadIO m) => UserName -> String -> ServerPartT m Response+startsess' user landingpage = do let sd = SessionData user key <- update $ NewSession sd- addCookie 3600 (mkCookie "sid" (show key))- return $ RenderGlobals origRq ts (Just sd) - --let lp = getLandingpage origRq- --return () - withRequest (const $ redirectToUrl landingpage)+ addCookie 3600 (mkCookie "sid" (show key)) + seeOther landingpage (toResponse "") getLoggedInUserInfos :: RenderGlobals -> ErrorT String (ServerPartT IO) (UserName,UserInfos) getLoggedInUserInfos (RenderGlobals _ _ Nothing) = fail "getLoggedInUserInfos, not logged in"@@ -53,22 +48,20 @@ updateuser :: (Monad m) => t -> b -> m b updateuser _ newuser = do- --update (UpdateUser olduser newuser) undefined return newuser logoutPage :: RenderGlobals -> ServerPartT IO Response-logoutPage rglobs@(RenderGlobals origRq ts _) =- withRequest $ \rq -> do- newRGlobs <-- maybe- ( return rglobs )- ( \sk -> do update . DelSession $ sk- return (RenderGlobals origRq ts Nothing)- )- (getMbSessKey rq)- ( return . tutlayoutU newRGlobs [] ) "home"+logoutPage rglobs@(RenderGlobals origRq ts _) = do+ rq <- askRq+ newRGlobs <- maybe+ ( return rglobs )+ (\sk -> do + update . DelSession $ sk+ return (RenderGlobals origRq ts Nothing))+ (getMbSessKey rq)+ return . tutlayoutU newRGlobs [] $ "home" avatarimage :: UserName -> IO String avatarimage un = do@@ -79,8 +72,18 @@ let p = writeavatarpath n e <- doesFileExist p if e- then return $ "/" ++ p+ then return $ '/' : p else return "/static/defaultprofileimage.png" writeavatarpath :: UserName -> String writeavatarpath un = "userdata/" ++ ( B.unpack . unusername $ un) ++ "/" ++ "profileimage"++errW :: RenderGlobals -> String -> Response+errW rglobs msg = tutlayoutU rglobs [("errormsg", msg)] "errortemplate"+ +requireLogin :: (UserName -> RenderGlobals -> ServerPartT IO Response) + -> RenderGlobals -> ServerPartT IO Response+requireLogin f rglobs = do+ case mbUser rglobs of+ Nothing -> return $ errW rglobs "Not logged in"+ Just u -> f u rglobs
src/ControllerPostActions.hs view
@@ -22,8 +22,8 @@ loginPage rglobs@(RenderGlobals rq _ _) = -- unfortunately can't just use rqUrl rq here, because sometimes has port numbers and... it gets complicated case tutAppReferrer rq of- Left e -> errW rglobs e- Right landingpage -> loginPage' authUser startsess' rglobs landingpage + Left e -> return $ errW rglobs e+ Right landingpage -> loginPage' authUser (const startsess') rglobs landingpage where authUser = authUser' getUserPassword getUserPassword name = return . maybe Nothing (Just . B.unpack . password) =<< query (GetUserInfos name)@@ -42,7 +42,7 @@ -- try immediately to log in again it won't let you. Right rf -> if isInfixOf "logout" rf || isInfixOf "login" rf || isInfixOf "newuser" rf then Right ar- else Right rf+ else Right rf -- Use a helper function because the plan is to eventually have a similar function -- that works for admin logins@@ -52,14 +52,12 @@ -> RenderGlobals -> String -> ServerPartT m Response-loginPage' auth startsession rglobs landingpage =- withData $ \(UserAuthInfo user pass) -> do- loginOk <- auth user pass- if loginOk- then startsession rglobs user landingpage- else errW rglobs "Invalid user or password" {- case ( modRewriteCompatibleTutPath rq ) of- Left e -> errW rglobs e - Right p -> return $ tutlayoutU rglobs [("loginerrormsg","login error: invalid username or password")] p -}+loginPage' auth startsession rglobs landingpage = do+ UserAuthInfo user pass <- getData'+ loginOk <- auth user pass+ if loginOk+ then startsession rglobs user landingpage+ else return $ errW rglobs "Invalid user or password" -- check if a username and password is valid. If it is, return the user as successful monadic value -- otherwise fail monadically@@ -72,7 +70,8 @@ changePasswordSP :: RenderGlobals -> ServerPartT IO Response-changePasswordSP rglobs = withData $ \(ChangePasswordInfo newpass1 newpass2) ->+changePasswordSP rglobs = do + ChangePasswordInfo newpass1 newpass2 <- getData' if newpass1 /= newpass2 then return $ errw "new passwords don't match" else do @@ -80,90 +79,72 @@ case etRes of Left e -> return $ errw e Right (u,_) -> do - -- newp <- newPassword (B.unpack newpass1) update $ ChangePassword u newpass1 return $ tutlayoutU rglobs [] "accountsettings-changed" where errw msg = tutlayoutU rglobs [("errormsgAccountSettings", msg)] "changepassword" processformEditConsultantProfile :: RenderGlobals -> ServerPartT IO Response-processformEditConsultantProfile rglobs =- withData $ \(EditUserProfileFormData fdContact fdBlurb fdlistAsC fdimagecontents) ->- case (return . sesUser =<< mbSession rglobs) of- Nothing -> errW rglobs "Not logged in"- Just unB -> do- mbUP <- query $ GetUserProfile unB- case mbUP of- Nothing -> errW rglobs "error retrieving user infos"- Just (UserProfile _ _ _ 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- viewEditConsultantProfile rglobs+processformEditConsultantProfile = requireLogin $ \unB rglobs -> do + EditUserProfileFormData fdContact fdBlurb fdlistAsC fdimagecontents <- getData'+ mbUP <- query $ GetUserProfile unB+ case mbUP of+ Nothing -> return $ errW rglobs "error retrieving user infos"+ Just (UserProfile _ _ _ 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+ viewEditConsultantProfile rglobs processformEditJob :: RenderGlobals -> ServerPartT IO Response-processformEditJob rglobs@(RenderGlobals _ _ mbSess) =- withData $ \(EditJob jn jbud jblu) ->- case (return . sesUser =<< mbSess) of- Nothing -> errW rglobs "Not logged in" - -- Just olduser@(User uname p cp js) -> do- Just uname ->- if null (B.unpack . unjobname $ jn)- then errW rglobs "error, blank job name"- else do - update $ SetJob uname jn (Job (B.pack jbud) (B.pack jblu))- viewEditJob uname jn rglobs--errW :: (Monad m) => RenderGlobals -> String -> m Response-errW rglobs msg = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate"- +processformEditJob = requireLogin $ \uname rglobs -> do+ EditJob jn jbud jblu <- getData'+ if null (B.unpack . unjobname $ jn)+ then return $ errW rglobs "error, blank job name"+ else do + update $ SetJob uname (Job (B.pack jbud) (B.pack jblu)) jn+ viewEditJob uname jn rglobs processformNewJob :: RenderGlobals -> ServerPartT IO Response-processformNewJob rglobs@(RenderGlobals _ _ mbSess) =- withData $ \(NewJobFormData jn newjob) ->- case (return . sesUser =<< mbSess) of- Nothing -> errW rglobs "Not logged in"- Just user ->- if null (B.unpack . unjobname $ jn)- then errW rglobs "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 rglobs "duplicate job name"- _ -> errW rglobs "error inserting job"- Right () -> pageMyJobPosts rglobs+processformNewJob = requireLogin $ \user rglobs -> do + NewJobFormData jn newjob <- getData'+ if null (B.unpack . unjobname $ jn)+ then return $ errW rglobs "error, blank job name"+ else do + res <- update (AddJob user jn newjob)+ case res of + Left err -> if isInfixOf "duplicate key" (lc err) + then return $ errW rglobs "duplicate job name"+ else return $ errW rglobs "error inserting job"+ Right () -> pageMyJobPosts rglobs newUserPage :: RenderGlobals -> ServerPartT IO Response-newUserPage rglobs =- withData $ \(NewUserInfo user (pass1 :: B.ByteString) pass2) -> do- rq <- askRq- etRes <- runErrorT $ - setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) - case etRes of- Left err -> errW rglobs err - Right () -> case modRewriteAppUrl "tutorial/registered" rq of- Left e -> errW rglobs e- Right p -> startsess' rglobs user p+newUserPage rglobs = do+ NewUserInfo user pass1 pass2 <- getData'+ rq <- askRq+ etRes <- runErrorT $ setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) + case etRes of+ Left err -> return $ errW rglobs err + Right () -> case modRewriteAppUrl "tutorial/registered" rq of+ Left e -> return $ errW rglobs e+ Right p -> startsess' user p where- setupNewUser :: NewUserInfo -> ErrorT [Char] (ServerPartT IO) ()- setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) = do+ setupNewUser :: NewUserInfo -> ErrorT String (ServerPartT IO) ()+ setupNewUser (NewUserInfo user pass1 pass2) = do when (B.null pass1 || B.null pass2) (throwError "blank password") when (pass1 /= pass2) (throwError "passwords don't match") -- Q: can return . Left be replaced with throwError? -- A: no. But you can return just plain Left with throwError. nameTakenHAppSState <- query $ IsUser user when nameTakenHAppSState (throwError "name taken")- addUserVerifiedPass user pass1 pass2-- + addUserVerifiedPass user pass1 pass2 addUserVerifiedPass :: UserName -> B.ByteString -> B.ByteString -> ErrorT String (ServerPartT IO) () addUserVerifiedPass user pass1 pass2 =
src/ControllerStressTests.hs view
@@ -37,8 +37,6 @@ -- 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' :: (MonadIO m) => (String, Users -> m a) -> Int -> RenderGlobals -> m Response stressTest' (fname,f) n rglobs = do@@ -46,7 +44,7 @@ (userRange,us) <- getUsers 10 n f us stressTestTime <- liftIO $ return . timeDiffToString =<< timeSince startTime- liftIO $ putStrLn $ fname ++ " stresstest, " ++ (show n) ++ " users, elapsedtime: " ++ stressTestTime+ liftIO $ putStrLn $ fname ++ " stresstest, " ++ show n ++ " users, elapsedtime: " ++ stressTestTime return $ tutlayoutU rglobs [("first",show . head $ userRange) , ("last",show . last $ userRange) , ("stressTestName",fname)@@ -62,7 +60,7 @@ [] -> 1 xs -> (+1) . last . sort $ xs userRange = [startNum..(startNum+n-1)] - return (userRange, (stresstestdata jobsPerU) userRange)+ return (userRange, stresstestdata jobsPerU userRange) getDummyNumber :: String -> Maybe Int@@ -83,7 +81,7 @@ -- 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+insertus = update . AddDummyData . users insertusAllJobs :: (MonadIO m) => Users -> m () insertusAllJobs = mapM_ insertuAllJobs . M.toList . users @@ -110,19 +108,19 @@ --stresstestdata :: (Integral a) => [a] -> Users stresstestdata :: (Integral a) => a -> [a] -> Users-stresstestdata jobsperU us = Users $ M.fromList $ map (stresstestUser jobsperU) us+stresstestdata jobsperU = Users . M.fromList . map (stresstestUser jobsperU) stresstestUser :: (Integral a) => a -> a -> (UserName, UserInfos)-stresstestUser jobsperU i = ( UserName . B.pack $ ("user"++(show i)) +stresstestUser jobsperU i = ( UserName . B.pack $ ("user"++show i) , UserInfos - ( B.pack $ "password" ++ (show i))+ ( B.pack $ "password" ++ show i) (stresstestprofile i) (Jobs $ M.fromList $ map (stresstestjob i) [1..jobsperU]) )- where stresstestprofile x = UserProfile { contact = B.pack $ "someone" ++ (show x) ++ "@somewhere.com"+ where stresstestprofile x = UserProfile { contact = B.pack $ "someone" ++ show x ++ "@somewhere.com" , blurb = B.pack "la la la" , consultant = even x , avatar = B.pack ""}- stresstestjob x j = ( JobName . B.pack $ "make something " ++ (show (x,j)) ,+ stresstestjob x j = ( JobName . B.pack $ "make something " ++ show (x,j) , Job { jobbudget = B.pack . show $ (x,j) , jobblurb = B.pack . ("blurb " ++) . show $ (x,j) } ) @@ -139,7 +137,6 @@ tphyahooProfile :: UserProfile 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 \@@ -168,5 +165,5 @@ , ("sql-ledger clone", "")] serpinskiJobs :: Jobs-serpinskiJobs = Jobs $ M.fromList $ map (\num -> ( JobName . B.pack $ "job" ++ (show num), Job ( B.pack "$0") ( B.pack "")) ) [10..203]+serpinskiJobs = Jobs $ M.fromList $ map (\num -> ( JobName . B.pack $ "job" ++ show num, Job ( B.pack "$0") ( B.pack "")) ) [10..203]
src/FirstMacid.hs view
@@ -53,6 +53,18 @@ incVal :: Int -> Update ExampleState () incVal i = modify (\(ExampleState n) -> ExampleState (n+i)) +-- An Update that makes use of the utility function getRandomR.+-- getRandom or getRandomR can be used in the middle of an Update+-- or Query without needing to perform any unsafe IO magic or somehow+-- carry around a random seed with your state.+-- This Update also serves as a reminder that despite all the deep+-- magic that is used to make Updates and Querys work, these are+-- still legitimate Haskell monads and we can combine them together+-- the same as always.++succRand :: Update ExampleState ()+succRand = getRandomR (0,1000) >>= incVal+ {- Another required bit of Template Haskell magic. This will derive a set of data types to be used in the over all event handling that are in 1-1 correspondence with the Updates and Querys that you@@ -67,7 +79,7 @@ IncVal Int. -} -$(mkMethods ''ExampleState ['succVal, 'getVal, 'incVal])+$(mkMethods ''ExampleState ['succVal, 'getVal, 'incVal, 'succRand]) -- One more thing you can't forget to define in order for MACID to work -- If your data type is composed from non-primitive data, then you need@@ -96,9 +108,7 @@ rootState = Proxy main :: IO ()-main = do- ctl <- startSystemState rootState- commandLoop ctl+main = startSystemState rootState >>= commandLoop commandLoop :: MVar TxControl -> IO () commandLoop ctl = do@@ -106,6 +116,7 @@ putStrLn "Enter 'v' to view the state." putStrLn "Enter 's' to increment the state by 1." putStrLn "Enter 'c' to checkpoint the state."+ putStrLn "Enter 'r' to increment the state by a random number." putStrLn "Enter 'q' to quit." val <- liftM head getLine handler ctl val@@ -169,9 +180,10 @@ handler _ 'q' = return () handler c 'v' = query GetVal >>= print >> commandLoop c handler c 's' = update SuccVal >> commandLoop c-handler c 'i' = (flip catch) (const $ commandLoop c) $ do+handler c 'i' = flip catch (const $ commandLoop c) $ do v <- readLn update $ IncVal v commandLoop c handler c 'c' = createCheckpoint c >> commandLoop c+handler c 'r' = update SuccRand >> commandLoop c handler c _ = commandLoop c
+ src/IxSetExample.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE DeriveDataTypeable, MultiParamTypeClasses #-} +-- You'll need these language extensions when defining a type you want to be in an IxSet+++{-+ This file should be loaded into ghci for your personal experiments.+ Try looking at all the different values that start with "ex" and + hopefully you should get some definite intuition for using IxSet.+-}++import Happstack.Data.IxSet++-- We need to import Data.Map, Data.Set, and Data.Typeable in order to set up a type to work with IxSet +import qualified Data.Map as Map+import Data.Map (Map)+import Data.Set (Set)+import Data.Typeable+import Data.Data++{- Indexing is done by dispatch over the actual type, so it isn't possible to+ have a working IxSet with multiple indexes of the same type. The standard+ trick, then, is to use newtypes.+-}++newtype Id = Id Int+ deriving (Ord,Eq,Show,Typeable,Data)++newtype Val = Val Int+ deriving (Ord,Eq,Show,Typeable,Data)++newtype Name = Name String+ deriving (Ord,Eq,Show,Typeable,Data)++newtype Calc = Calc Int+ deriving (Ord,Eq,Data,Typeable)++{- Now we define the actual data type that we'll be storing in the IxSet +-}++data Example1 = Example1 {+ uid :: Id,+ name :: Name,+ val :: Val,+ unindexed :: Int+ }+ deriving (Ord,Eq,Data,Typeable,Show)++{- In order to actually use the IxSet interface with a type,+ that type needs to be made an instance of Indexable.+ + The actual instance is extremely straight forward, however,+ in that all we need is to make the list of Maps in empty+ contain an Ix (Map.empty :: Map a (Set Example)) for each type a+ that we want to index, which in this case means Id, Name, and Val.++ Now the calcs method is actually something quite interesting. It+ provides a calculated index, not actually stored in the type,+ that you can use as an index just like the ones you define in the+ empty instance. Notice that we need to include the +-}++instance Indexable Example1 Calc where+ empty = IxSet [Ix (Map.empty :: Map Id (Set Example1)),+ Ix (Map.empty :: Map Name (Set Example1)),+ Ix (Map.empty :: Map Val (Set Example1)),+ Ix (Map.empty :: Map Calc (Set Example1))]+ calcs e = let (Val v) = val e+ u = unindexed e+ in Calc (u+v)++exEmpty :: IxSet Example1+exEmpty = empty++exInsert1 :: IxSet Example1+exInsert1 = insert (Example1 (Id 1) (Name "Foo") (Val 10) 0) empty++exInsert2 :: IxSet Example1+exInsert2 = insert (Example1 (Id 3) (Name "Bar") (Val 20) 3) $ + insert (Example1 (Id 2) (Name "Baz") (Val 10) 0) exInsert1++exDelete :: IxSet Example1+exDelete = delete (Example1 (Id 3) (Name "Bar") (Val 20) 3) exInsert2++-- There exist both fromList and fromSet functions for building+-- up IxSets from simpler containers. fromList in particular is+-- convenient because of the syntax for lists.+exFromList :: IxSet Example1+exFromList = fromList [Example1 (Id 4) (Name "Blah") (Val 30) 5, + Example1 (Id 5) (Name "Blah") (Val 40) 0, + Example1 (Id 6) (Name "Blah") (Val 10) 0]++-- The (|||) operator is used for creating unions of IxSets.+-- Conversely the (&&&) operator is used for intersecting IxSets.+exUnion :: IxSet Example1+exUnion = exFromList ||| exInsert2++exQuery1 :: IxSet Example1+exQuery1 = exUnion @= Name "Blah"++exQuery2 :: IxSet Example1+exQuery2 = exUnion @< Val 40++exQuery3 :: IxSet Example1+exQuery3 = exUnion @>< ((Id 0),(Id 20))++-- the @+ function takes a list of indices and returns the IxSet that+-- matches one of the indices. The @* function returns the IxSet that+-- matches all of the indices. In this case, we pick out the examples+-- that have Id 1 or Id 6+exQuery4 :: IxSet Example1+exQuery4 = exUnion @+ [(Id 1),(Id 6)]++-- Again, we can treat the type Calc just as if it was actually contained+-- in Example1 for the purposes of queries and updates.+exCalcQuery :: IxSet Example1+exCalcQuery = exUnion @= Calc 35++{- The following query passes in a String to the query+ operator @=. Since we have no index of type String,+ what do you expect to happen? The behavior of the IxSet+ library in this case is going to be to return an empty IxSet.++ Something I think you should take away from this is that + the compiler can not check that you are providing+ a valid index to an IxSet.+-}+exBadQuery :: IxSet Example1+exBadQuery = exUnion @= "ham"++{- To modify a particular item in the ixset, you can use+ the updateIx function; however, it only works if the index is+ unique. Otherwise, it'll only modify one of the items that+ matches the index.+-} ++exUpdateIx :: IxSet Example1+exUpdateIx = updateIx (Id 1) (Example1 (Id 1) (Name "Bar") (Val 20) 3) exUnion
src/Main.hs view
@@ -11,13 +11,20 @@ main :: IO () main = do- args <- getArgs+ args <- getArgs -- getArgs is from System.Environment, if you're not familiar with it case args of [port, dynamicTemplateReload', allowStressTests'] -> do let p = read port allowStressTests = read allowStressTests' dynamicTemplateReload = read dynamicTemplateReload'- tDirGroups <- getTemplateGroups+ tDirGroups <- getTemplateGroups -- defined in Controller.hs+ {- smartserver and its cousin smartserver' are from the happstack-helpers package.+ They are essentially a combination startSystemState and simpleHTTP('), with a+ few other minor conveniences built in.++ Just like with simpleHTTP we pass in the ServerPartT, given by controller from Controller.hs,+ and just like startSystemState we pass in a Proxy in order to initialize the system state.+ -} smartserver (Conf p Nothing) "happs-tutorial" (controller tDirGroups dynamicTemplateReload allowStressTests) stateProxy
src/Misc.hs view
@@ -5,6 +5,7 @@ import qualified Data.ByteString.Lazy.Char8 as L import Control.Monad import Data.List+import Control.Arrow import Data.Digest.Pure.MD5 import Text.PrettyPrint as PP import System.FilePath (pathSeparator, takeDirectory)@@ -32,13 +33,6 @@ [lastpart] -> f rq lastpart _ -> mzero -{--ifFirstPathPartSp pathpart f = ServerPartT $ \rq ->- case rqPaths rq of- (x:xs) -> f rq pathpart- _ -> noHandle--}- -- store passwords as md5 hash, as a security measure scramblepass :: String -> String scramblepass = show . md5 . L.pack@@ -49,7 +43,7 @@ tFromTo = fromTo 10 20 [1..1000] == [10..20] -fromTo fr to xs = take (to-(fr-1)) . drop (fr-1) $ xs +fromTo fr to = take (to-(fr-1)) . drop (fr-1) quote x = '\"' : x ++ "\"" @@ -76,7 +70,7 @@ 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+ bounded = map (map snd &&& bounds) part bounds [] = (0,0) bounds l@((_,_):_) = (fst . head $ l,fst . last $ l) in bounded@@ -96,7 +90,6 @@ 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
src/MiscMap.hs view
@@ -1,7 +1,5 @@ {-# LANGUAGE NoImplicitPrelude #-} module MiscMap (- -- module Data.Map- -- , empty , Map , Data.Map.mapWithKey@@ -26,7 +24,7 @@ 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+---- kind of like what's in Happstack.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)@@ -46,8 +44,6 @@ Just _ -> 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 :: (Ord k, Monad m, Show k) => k -> (a -> a) -> Map k a -> m (Map k a)@@ -57,10 +53,9 @@ -- 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 ::(Ord k, Monad m, Show k) => k -> - (a -> Either [Char] a) -> Map k a -> m (Map k a)+ (a -> Either String 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
src/MultiExample1.hs view
@@ -39,9 +39,7 @@ rootState = Proxy main:: IO ()-main = do- c <- startSystemStateMultimaster rootState- commandLoop c+main = startSystemStateMultimaster rootState >>= commandLoop commandLoop :: MVar TxControl -> IO () commandLoop c = do
src/MultiExample2.hs view
@@ -34,9 +34,7 @@ rootState = Proxy main:: IO ()-main = do- c <- startSystemStateMultimaster rootState- commandLoop c+main = startSystemStateMultimaster rootState >>= commandLoop commandLoop :: MVar TxControl -> IO () commandLoop c = do
src/MultiExample3.hs view
@@ -31,9 +31,7 @@ rootState = Proxy main:: IO ()-main = do- c <- startSystemStateMultimaster rootState- commandLoop c+main = startSystemStateMultimaster rootState >>= commandLoop commandLoop :: MVar TxControl -> IO () commandLoop c = do
− src/Redirector.hs
@@ -1,9 +0,0 @@-module Main where-import Happstack.Server-import Happstack.State-import Misc-import System.Environment----main = simpleHTTP (Conf {port=5001}) (ServerPartT $ \rq -> seeOther "http://happstutorial.com" (toResponse ""))
src/StateTExample.hs view
@@ -7,7 +7,9 @@ -- and is the suitable transformer to be passed as the first parameter to -- simpleHTTP' main :: IO ()-main = simpleHTTP' (flip evalStateT 0) (Conf 8880 Nothing) handler+main = do+ putStrLn "Now listening on port 8880"+ simpleHTTP' (flip evalStateT 0) (Conf 8880 Nothing) handler handler :: ServerPartT (StateT Int IO) String handler = do
src/StateVersions/AppState1.hs view
@@ -20,7 +20,7 @@ import Misc t :: String-t = let f (JobName (j :: B.ByteString)) = B.unpack j in f . JobName $ (B.pack "job")+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.@@ -36,15 +36,25 @@ 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+{-+ For convenience we define a set of mutator functions for the various fields of our+ data types. It pays off at the end of the day when writing our Updates.++ mod_field takes a mutator function+ set_field takes a value+-}+set_jobbudget :: B.ByteString -> Job -> Job 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)+mod_jobbudget :: (B.ByteString -> B.ByteString) -> Job -> Job+mod_jobbudget f j@(Job b _) = j{jobbudget=f b} +set_jobblurb :: B.ByteString -> Job -> Job+set_jobblurb = mod_jobblurb . const++mod_jobblurb :: (B.ByteString -> B.ByteString) -> Job -> Job +mod_jobblurb f j@(Job _ b) = j{jobblurb=f b}+ newtype Jobs = Jobs { unjobs :: M.Map JobName Job } deriving (Show,Read,Ord, Eq, Typeable,Data) instance Version Jobs@@ -60,16 +70,24 @@ instance Version UserProfile $(deriveSerialize ''UserProfile) ---mutators+set_contact :: B.ByteString -> UserProfile -> UserProfile set_contact = mod_contact . const-mod_contact f (UserProfile contact blurb consultant avatar) = UserProfile (f contact) blurb consultant avatar +mod_contact :: (B.ByteString -> B.ByteString) -> UserProfile -> UserProfile+mod_contact f u@(UserProfile c _ _ _) = u{contact=f c}++set_blurb :: B.ByteString -> UserProfile -> UserProfile set_blurb = mod_blurb . const-mod_blurb f (UserProfile contact blurb consultant avatar) = UserProfile contact (f blurb) consultant avatar +mod_blurb :: (B.ByteString -> B.ByteString) -> UserProfile -> UserProfile+mod_blurb f u@(UserProfile _ b _ _) = u{blurb=f b}++set_consultant :: Bool -> UserProfile -> UserProfile set_consultant = mod_consultant . const-mod_consultant f (UserProfile contact blurb consultant avatar) = UserProfile contact blurb (f consultant) avatar +mod_consultant :: (Bool -> Bool) -> UserProfile -> UserProfile+mod_consultant f u@(UserProfile _ _ c _) = u{consultant=f c}+ data UserInfos = UserInfos { password :: B.ByteString , userprofile :: UserProfile@@ -78,18 +96,29 @@ instance Version UserInfos $(deriveSerialize ''UserInfos) --- mod_password f (UserInfos pass up jobs) = UserInfos (f pass) up jobs+set_userprofile :: UserProfile -> UserInfos -> UserInfos 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 +mod_userprofile :: (UserProfile -> UserProfile) -> UserInfos -> UserInfos+mod_userprofile f u@(UserInfos _ up _) = u{userprofile=f up}++add_job :: (Monad m) => JobName -> Job -> UserInfos -> m UserInfos+add_job jobname = mod_jobs . M.insertUqM jobname++del_job :: (Monad m) => JobName -> UserInfos -> m UserInfos+del_job = mod_jobs . M.deleteM++set_job :: (Monad m) => Job -> JobName -> UserInfos -> m UserInfos set_job = mod_job . const++mod_job :: (Monad m) => (Job -> Job) -> JobName -> UserInfos -> m UserInfos mod_job f jobname = mod_jobs $ M.adjustM jobname f -mod_jobs mf (UserInfos pass up (Jobs jobs) ) = either (fail . ("mod_jobs: " ++) )++mod_jobs :: (Monad m) => (M.Map JobName Job -> Either String (M.Map JobName Job)) + -> UserInfos -> m UserInfos+mod_jobs mf (UserInfos pass up (Jobs j) ) = either (fail . ("mod_jobs: " ++) ) (\js -> return $ UserInfos pass up (Jobs js) )- (mf jobs)+ (mf j) @@ -104,27 +133,33 @@ $(deriveSerialize ''Users) -- 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+add_user_job :: (Monad m) => UserName -> JobName -> Job -> Users -> m Users+add_user_job un jn = mod_userMM un . add_job jn -- adjust users, where the adjustment function can fail monadically--- mod_userMM :: (Monad m) => UserName -> (UserInfos -> Either [Char] UserInfos) -> Users -> m Users++mod_userMM :: (Monad m) => UserName -> + (UserInfos -> Either String 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 :: (Monad m) => UserName -> (UserInfos -> UserInfos) -> Users -> m Users 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 )+set_user_userprofile_contact::(Monad m)=> UserName -> B.ByteString -> Users -> m Users+set_user_userprofile_contact username = mod_userM username . mod_userprofile . set_contact +set_user_userprofile_blurb ::(Monad m) => UserName -> B.ByteString -> Users -> m Users+set_user_userprofile_blurb username = mod_userM username . mod_userprofile . set_blurb --- set_user_userprofile username p = mod_userM username $ Right . set_userprofile p +set_user_userprofile_consultant :: (Monad m) => UserName -> Bool -> Users -> m Users+set_user_userprofile_consultant username = mod_userM username . mod_userprofile . set_consultant +add_user :: (Monad m) => UserName -> B.ByteString -> Users -> m Users add_user username hashedpass (Users us) | B.null . unusername $ username = fail "blank username" | B.null hashedpass = fail "error: blank password"@@ -137,12 +172,13 @@ False (B.pack "") ) (Jobs M.empty) -del_user username uis (Users us) = either (fail . ("del_user: " ++))+del_user :: (Monad m) => UserName -> t -> Users -> m Users+del_user username _ (Users us) = either (fail . ("del_user: " ++)) (return . Users) ( M.deleteM username us ) +type SessionKey = Integer -type SessionKey = Integer newtype SessionData = SessionData { sesUser :: UserName } deriving (Read,Show,Eq,Typeable,Data,Ord)@@ -181,50 +217,44 @@ instance Component AppState where type Dependencies AppState = End - initialValue = AppState { appsessions = (Sessions M.empty),- appdatastore = Users M.empty }+ initialValue = AppState { appsessions = Sessions M.empty,+ appdatastore = Users M.empty } askDatastore :: Query AppState Users-askDatastore = do- (s :: AppState ) <- ask- return . appdatastore $ s-+askDatastore = fmap appdatastore ask askSessions :: Query AppState (Sessions SessionData)-askSessions = return . appsessions =<< ask+askSessions = fmap 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-+setUserProfile uname = modUserInfos uname . set_userprofile --- delJob :: UserName -> JobName -> Update AppState (Either String ())-delJob uname jn = modUserInfosM uname $ del_job jn +addJob :: UserName -> JobName -> Job -> Update AppState (Either String ())+addJob uname jn = modUserInfosM uname . add_job jn +delJob :: UserName -> JobName -> Update AppState (Either String ())+delJob uname = modUserInfosM uname . del_job -setJob uname jn j = modUserInfosM uname $ set_job j jn+setJob :: UserName -> Job -> JobName -> Update AppState (Either String ())+setJob uname j = modUserInfosM uname . set_job j 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+ (AppState sessions (Users us)) <- get+ case M.adjustMM un mf us 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+ (AppState sessions (Users us)) <- get+ case M.adjustM un f us 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))) @@ -234,22 +264,11 @@ 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--{--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--}+ (Users us ) <- askDatastore+ return (isJust $ M.lookup name us) addUser :: UserName -> B.ByteString -> Update AppState (Either String ())-addUser un@(UserName name) hashedpass = do+addUser un hashedpass = do AppState s us <- get case ( add_user un hashedpass us :: Either String Users) of Left err -> if isInfixOf "duplicate key" err@@ -259,72 +278,73 @@ return $ Right () ---changePassword :: UserName -> B.ByteString -> Update AppState (Either String ())+changePassword :: UserName -> B.ByteString -> Update AppState () changePassword un newpass = do AppState s us <- get let hashednewpass = scramblepass $ B.unpack newpass newUs <- set_user_password un (B.pack hashednewpass) us put $ AppState s newUs --- set_user_password :: UserName -> B.ByteString -> Users -> Either String Users-set_user_password username newpass = mod_userM username $ set_password newpass+set_user_password :: (Monad m) => UserName -> B.ByteString -> Users -> m Users+set_user_password username = mod_userM username . set_password set_password :: B.ByteString -> UserInfos -> UserInfos-set_password newpass (UserInfos pass up jobs) = UserInfos newpass up jobs+set_password newpass u = u{password=newpass} -- was getUser getUserInfos :: UserName -> Query AppState (Maybe UserInfos) getUserInfos u = ( return . M.lookup u . users ) =<< askDatastore +getUserProfile :: UserName -> Query AppState (Maybe UserProfile) getUserProfile u = do mbUI <- getUserInfos u case mbUI of Nothing -> return Nothing- Just (UserInfos pass profile jobs) -> return $ Just profile+ Just (UserInfos _ profile _) -> return $ Just profile -- list all jobs along with the username who posted each job--- listAllJobs :: Query AppState (M.Map UserName Jobs)-listAllJobs = return .+listAllJobs :: Query AppState [(JobName, Job, UserName)]+listAllJobs = fmap ( 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+ . M.map (unjobs . jobs) . users) + askDatastore + where g uname = map ( \(jobname,job) -> (jobname,job,uname) ) . M.toList --- lookupUser f users = find f . S.toList $ users listUsers :: Query AppState [UserName]-listUsers = ( return . M.keys . users ) =<< askDatastore+listUsers = fmap (M.keys . users) askDatastore -listUsersWantingDevelopers = (return . M.keys . M.filter wantingDeveloper . users) =<< askDatastore- where wantingDeveloper uis = not . M.null . unjobs . jobs $ uis+listUsersWantingDevelopers :: Query AppState [UserName]+listUsersWantingDevelopers = fmap (M.keys . M.filter wantingDeveloper . users) askDatastore+ where wantingDeveloper = not . M.null . unjobs . jobs newSession :: SessionData -> Update AppState SessionKey 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+ inssess u' sessions = do key <- getRandom- case (M.insertUqM key u sessions) of- Nothing -> inssess u sessions+ 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+delSession sk = modSessions $ Sessions . M.delete sk . unsession getSession::SessionKey -> Query AppState (Maybe SessionData)-getSession key = liftM (M.lookup key . unsession) askSessions+getSession key = fmap (M.lookup key . unsession) askSessions numSessions :: Query AppState Int-numSessions = liftM (M.size . unsession) askSessions+numSessions = fmap (M.size . unsession) askSessions --- initializeDummyData :: M.Map UserName UserInfos -> m ()++initializeDummyData :: M.Map UserName UserInfos -> Update AppState () initializeDummyData dd = do AppState ss (Users us) <- get if M.null us @@ -333,12 +353,12 @@ -- 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 :: (MonadState AppState m) => M.Map UserName UserInfos -> m ()++addDummyData :: M.Map UserName UserInfos -> Update AppState () addDummyData dd = do AppState ss (Users us) <- get put $ AppState ss (Users (M.union us dd) ) --- addDummyUser :: (MonadState AppState m) => (UserName, UserInfos) -> m () addDummyUser :: (UserName, UserInfos) -> Update AppState () addDummyUser (un,uis) = do AppState ss (Users us) <- get@@ -356,7 +376,6 @@ , 'addUser , 'changePassword , 'setUserProfile- -- , 'updateUser , 'isUser , 'listUsers , 'listAllJobs
src/UniqueLabelsGraph.hs view
@@ -36,9 +36,9 @@ insUqNodes vs g = foldr insUqNode g vs -lnodesetFromGraph g = S.fromAscList . labNodes $ g+lnodesetFromGraph = S.fromAscList . labNodes -labelsetFromGraph g = (S.map snd) . lnodesetFromGraph $ g+labelsetFromGraph = (S.map snd) . lnodesetFromGraph mkUqGraph vs es = (insEdges' . insUqNodes vs) empty where@@ -69,4 +69,4 @@ 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 + return $ fromMaybe oldgraph mbNewGraph
src/View.hs view
@@ -11,42 +11,34 @@ import Data.Maybe import StateVersions.AppState1 --- ---import SerializeableUserInfos (UserProfile (..))--- (Job(..), JobName(..)) import Happstack.Helpers --- debug problem with foreign character display--- foreign chars displau okay---t = do templates <- directoryGroup "templates" --- -- let content = renderTemplateGroup templates [] "foreignchars"--- writeFile "output.html" $ tutlayout (RenderGlobals templates Nothing) [] "foreignchars"----- Notice, there are no HApps.* imports +-- Notice, there are no Happstack.* 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.+-- :browse View in ghci should reveal there's no IO for any of these function sigs. +{-+ RenderGlobals is essentially just a cute wrapper around a triple+ meant to pass along the set of templates, the SessionData which is stored+ in a cookie when the user has logged in, and the actual Request made.+-} data RenderGlobals = RenderGlobals { origrq :: Request- , templates :: STDirGroups String -- STGroup String -- STDirGroups String -- + , templates :: STDirGroups String , mbSession :: Maybe SessionData } deriving Show -----+mbUser :: RenderGlobals -> Maybe UserName+mbUser = fmap sesUser . mbSession -tutlayout :: RenderGlobals -> [([Char], [Char])] -> String -> String+tutlayout :: RenderGlobals -> [(String, String)] -> String -> String tutlayout (RenderGlobals rq ts' mbSess) attrs tmpl0 = let ts = getTemplateGroup "." ts' tmpl = cleanTemplateName tmpl0- mbU = return . sesUser =<< mbSess+ mbU = fmap sesUser mbSess rendertut :: [(String,String)] -> String -> String- rendertut attrs file = ( renderTemplateGroup ts ) attrs file+ rendertut = renderTemplateGroup ts -- should use readM, or whatever it's called, from Data.Safe --readtut :: (Monad m, Read a) => String -> m a@@ -55,7 +47,7 @@ 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 + attrsL = maybe attrs ( \user -> ("loggedInUser",B.unpack . unusername $ user) : attrs ) mbU content = rendertut attrsL tmpl @@ -66,22 +58,16 @@ ( \user -> hMenuBars rq [("/tutorial/logout","logout " ++ (B.unpack . unusername $ user)) , ("/tutorial/changepassword","change password")] )- ( mbU ) - mainUserMenu = if (isJust mbU) + mbU+ mainUserMenu = if isJust mbU then hMenuBars rq $ readTutTuples "mainusermenu" else "" menubarMenu = hMenuBars rq $ readTutTuples "menubarmenu"- --, ("post-data","form post data")- --, ("get-data","querystring get data")- --, ("macid-data","macid data")- --, ("migrating","changing the data model")- tocArea = vMenuOL rq $ readTutTuples "toc"- - - in rendertut ( [("tocarea",tocArea)- , ("contentarea",content)- , ("headerarea",header)] ) "base"+ tocArea = vMenuOL rq $ readTutTuples "toc" + in rendertut [("tocarea",tocArea)+ ,("contentarea",content)+ ,("headerarea",header)] "base" cleanTemplateName :: String -> String cleanTemplateName = filter isAlpha@@ -94,9 +80,8 @@ let ts = getTemplateGroup "." . templates $ rglobs attrs = [("username",user) - , ("userimage", userimagepath ) -- avatarimage (UserName . B.pack $ user) + , ("userimage", userimagepath ) , ("blurb",newlinesToHtmlLines . B.unpack . blurb $ cp)- --, ("jobsPosted",paintJobsTable n rglobs $ js) , ("contact", newlinesToHtmlLines . B.unpack . contact $ cp)] in renderTemplateGroup ts attrs "consultantprofile" @@ -105,17 +90,17 @@ paintUserJobsTable postedBy rsUserJobs = let jobCells = map ( \( JobName j', Job _ _) -> let 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")+ , simpleLink ("/tutorial/editjob?user="++ B.unpack postedBy ++"&job=" ++ j,"edit")+ , simpleLink ("/tutorial/deletejob?user="++ B.unpack postedBy ++"&job=" ++ j,"delete") ] ) rsUserJobs in paintTable Nothing jobCells Nothing -- no pagination for now joblink :: B.ByteString -> String -> String-joblink postedBy j = simpleLink ("/tutorial/viewjob?user="++(B.unpack postedBy)++"&job=" ++ j,j)+joblink postedBy j = simpleLink ("/tutorial/viewjob?user="++B.unpack postedBy++"&job=" ++ j,j) userlink :: B.ByteString -> String-userlink pBy = simpleLink ("/tutorial/viewprofile?user=" ++ (B.unpack pBy),(B.unpack pBy) )+userlink pBy = simpleLink ("/tutorial/viewprofile?user=" ++ B.unpack pBy, B.unpack pBy) paintjob :: RenderGlobals -> UserName -> (JobName, Job) -> String paintjob rglobs (UserName pBy) (JobName jN, Job jBud jBlu) =@@ -126,6 +111,3 @@ , ("jobblurb",B.unpack jBlu) , ("postedBy",userlink pBy)] in renderTemplateGroup ts attrs "job"---
− src/add10000users.hs
@@ -1,14 +0,0 @@-import Network.Download--main = mapM_ f $ [1..100]--f iter = do- either- (error . ("error: "++))- (\_ -> putStrLn $ "added" ++ (show batchsize) ++ " users, iter: " ++ (show iter) )- =<< (openURI url) - --url = "http://www.happstutorial.com:5002/tutorial/stresstest/atomicinsertsalljobs/" ++ (show batchsize)-batchsize = 100-
− src/gentable.hs
@@ -1,13 +0,0 @@-import Text.StringTemplate.Helpers-import Happstack.Helpers-import HSH--n = 10-imgfiles = [[ (show x ) ++ (show y) ++ ".gif" | y <- [1..n] ] | x <- [1..n] ]-imgtags = ( map . map ) (\f -> render1 [("f",f)] "<img src=$f$>") imgfiles-t2 = paintTable Nothing imgtags Nothing- where t2show x y = render1 [("x",show x),("y",show y)] "<img src=$x$$y$.gif>"--iof dest = bracketCD "../static/Html2" $ runIO $ "cp icon.gif " ++ dest-mkfiles = mapM_ iof $ ( concat imgfiles)-
src/migrationexample/CreateState1.hs view
@@ -1,21 +1,36 @@-{-# OPTIONS -fglasgow-exts #-}- import StateVersions.AppState1 import Happstack.State import System.Environment -entryPoint :: Proxy State+entryPoint :: Proxy AppState entryPoint = Proxy +{- First, we're using withProgName "migration-demo" with both CreateState1 and MigrateState2+ in order to make sure that both executables are looking at the same state+ under _local.++ Second, in this example we're using the state+ contained in AppState1, which is just+ AppState Int, and we increment it before creating+ our checkpoint.++ Why create a checkpoint? Well that goes to something+ fairly important about how migrations work. If you+ _don't_ create a checkpoint, then when you start+ MigrateState2.hs it will attempt to replay back the+ set of events recorded in _local and it won't be able+ to handle them because the actual state module, and thus+ namespace, has changed. Instead, we need to create+ a checkpoint and serialize the actual state itself+ rather than the events. The Migrate instance will+ then handle the rest.+-}+ main :: IO () main = withProgName "migration-demo" $ do control <- startSystemState entryPoint-- update $ InsertPage "index" (Page (Title "Home") (Body "hello, world") )- update $ InsertPage "index" (Page (Title "Home 2") (Body "hello, world 2") )- update $ InsertPage "index" (Page (Title "Home3 ") (Body "hello, world 3") )-- query AskPages >>= print+ update IncVal+ query AskVal >>= print createCheckpoint control shutdownSystem control
src/migrationexample/MigrateToState2.hs view
@@ -1,23 +1,17 @@-{-# OPTIONS -fglasgow-exts #-}- import StateVersions.AppState2 import Happstack.State import System.Environment -entryPoint :: Proxy State+entryPoint :: Proxy AppState entryPoint = Proxy main :: IO ()--- specify program name so the same _local directory gets read+-- Again, we specify program name so the same _local directory gets read main = withProgName "migration-demo" $ do control <- startSystemState entryPoint - update $ InsertPage "index2" (Page (Title "Home 2") (Body "hello, world 2") )- update $ InsertPage "index3" (Page (Title "Home 3") (Body "hello, world 3") )- update $ InsertPage "index4" (Page (Title "Home 4") (Body "hello, world 4") )-- query AskPages >>= print-+ update IncVal+ query AskVal >>= print+-- You should be able to see the proper incrementing of the value printed out. createCheckpoint control shutdownSystem control-
− src/migrationexample/MigrateToState3.hs
@@ -1,23 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}--import StateVersions.AppState3-import Happstack.State-import System.Environment- -entryPoint :: Proxy State-entryPoint = Proxy--main :: IO ()--- specify program name so the same _local directory gets read-main = withProgName "migration-demo" $ do- control <- startSystemState entryPoint--- update $ InsertPage "index5" (Page (Title "Home 5") (Header "Header5") (Body "hello, world 5") )- update $ InsertPage "index6" (Page (Title "Home 6") (Header "Header5") (Body "hello, world 6") )-- query AskPages >>= print-- createCheckpoint control- shutdownSystem control- return ()
− src/migrationexample/README
@@ -1,55 +0,0 @@-== The following is a demo of HAppS migrations--In this directory you'll find the following files:---- StateVersions/AppState1.hs- - Our first state. Fairly basic.- - --- StateVersions/AppState2.hs- - The next iteration, moving from a lookup list to a Map, containing the code- for the migration and the reference to the previous version.- --- StateVersions.AppState3.hs-- The next iteration, adding a Header field. ---- CreateState1.hs-- Run the 'main' function of this file to create the state in the first- format (State1). This will also create a checkpoint. ----- MigrateToState2.hs-- Run this to test the migration. The old version of HAppS will return the- inital state (empty map), not loading the old checkpoint. Using a patched- version will give you the data created with CreateState1, but now as a Map.-- Note that if we hadn't created the checkpoint, it would have worked out- fine, since we would replay the 'InsertPage' action, but now for the new- state. In the long run, you'll likely to want to use checkpoints, rename- event functions, etc, so this is not a feasable approach.---- MigrateToState3.hs-- Do the third migration, which adds a Header field.--The demo is as follows: --$ runghc CreateState1.hs -[("index",Page {title = Title "Home3 ", body = Body "hello, world 3"}),("index",Page {title = Title "Home 2", body = Body "hello, world 2"}),("index",Page {title = Title "Home", body = Body "hello, world"})]--$ runghc MigrateToState2.hs-fromList [("index",Page {title = Title "Home", body = Body "hello, world"}),("index2",Page {title = Title "Home 2", body = Body "hello, world 2"}),("index3",Page {title = Title "Home 3", body = Body "hello, world 3"}),("index4",Page {title = Title "Home 4", body = Body "hello, world 4"})]--$ runghc MigrateToState3.hs -fromList [("index",Page (Title "Home") (Header "") (Body "hello, world")),("index2",Page (Title "Home 2") (Header "") (Body "hello, world 2")),("index3",Page (Title "Home 3") (Header "") (Body "hello, world 3")),("index4",Page (Title "Home 4") (Header "") (Body "hello, world 4")),("index5",Page (Title "Home 5") (Header "Header5") (Body "hello, world 5")),("index6",Page (Title "Home 6") (Header "Header5") (Body "hello, world 6"))]--Of course, for this to run, you need to have HAppS installed. --This migration demo is included as part of the happstutorial distribution, which is cabal installable. -With happstutorial installed, you should be able to run the migration demo too.-
src/migrationexample/StateVersions/AppState1.hs view
@@ -1,51 +1,39 @@-{-# OPTIONS -fglasgow-exts #-} {-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances,- MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+ MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable,+ TypeFamilies #-} module StateVersions.AppState1 where import Happstack.State-import qualified Data.Map as Map-import Data.Generics import Control.Monad import Control.Monad.Reader-import Control.Monad.State (modify,put,get,gets,MonadState)--newtype Title = Title String- deriving (Read,Show,Eq,Data,Typeable)-instance Version Title-$(deriveSerialize ''Title)--newtype Body = Body String- deriving (Read,Show,Eq,Data,Typeable)-instance Version Body-$(deriveSerialize ''Body)--data Page = Page { title :: Title- , body :: Body- } deriving (Read, Show, Eq, Typeable, Data)--type Pages = [(String, Page)]--data State = State { pages :: Pages- } deriving (Read, Show, Typeable, Data)--instance Version State-instance Version Page+import Control.Monad.State+import Data.Typeable+import Data.Data -$(deriveSerialize ''Page)-$(deriveSerialize ''State)+newtype AppState = AppState Int + deriving (Read, Show, Typeable, Data) -instance Component State where- type Dependencies State = End -- no dependencies- initialValue = State {pages = []} -- no pages+instance Version AppState +-- Now, I've said that Version is important for migrations+-- but the nice thing is that you don't have to plan in advance+-- that you may be migrating your state. You can just use the+-- default instance of Version for the very first application+-- state you define. It's only future versions that need +-- anything other than the default instance for Version.+$(deriveSerialize ''AppState) -insertPage :: MonadState State m => String -> Page -> m ()-insertPage pageName page = modPages $ (:) (pageName,page)+instance Component AppState where+ type Dependencies AppState = End -- no dependencies+ initialValue = AppState 0 -modPages :: MonadState State m => (Pages -> Pages) -> m ()-modPages f = modify (\s -> State (f $ pages s))+askVal :: Query AppState Int+askVal = do+ AppState i <- ask+ return i -askPages :: MonadReader State m => m (Pages)-askPages = asks pages+incVal :: Update AppState ()+incVal = do+ AppState i <- get+ put $ AppState (i+1) -$(mkMethods ''State ['askPages, 'insertPage])+$(mkMethods ''AppState ['askVal,'incVal])
src/migrationexample/StateVersions/AppState2.hs view
@@ -1,49 +1,50 @@-{-# OPTIONS -fglasgow-exts #-} {-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances,- MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}-module StateVersions.AppState2 ( InsertPage (..), State(..), AskPages (..), Old.Page (..), Old.Title(..), Old.Body (..) ) + MultiParamTypeClasses, GeneralizedNewtypeDeriving, DeriveDataTypeable, TypeFamilies #-}+module StateVersions.AppState2 where import Happstack.State-import qualified Data.Map as Map-import Data.Generics hiding ((:+:)) import Control.Monad import Control.Monad.Reader-import Control.Monad.State (modify,put,get,gets,MonadState)+import Control.Monad.State+import Data.Typeable+import Data.Data import qualified StateVersions.AppState1 as Old --- Keep the page-type Page = Old.Page-type Title = Old.Title-type Body = Old.Body --type Pages = Map.Map String Page-data State = State { pages :: Pages- } deriving (Read, Show, Typeable, Data)----- Only for the new state-$(deriveSerialize ''State)+newtype AppState = AppState (Int,Int)+ deriving (Read, Show, Typeable, Data) -instance Migrate Old.State State where- migrate (Old.State p) = State (Map.fromList p)- -instance Version State where- mode = extension 1 (Proxy :: Proxy Old.State)+$(deriveSerialize ''AppState) +-- We need to make our Migrate instance between the two states.+-- As you can see, Migrate needs to be defined as Migrate Old New.+-- In this case, we do a very simple migration and just convert+-- the singleton to the first element of the tuple.+instance Migrate Old.AppState AppState where+ migrate (Old.AppState i) = AppState (i,0) -instance Component State where- type Dependencies State = End -- no dependencies- initialValue = State {pages = Map.empty} -- no pages+-- +instance Version AppState where+ mode = extension 1 (Proxy :: Proxy Old.AppState)+-- extension is the preferred way to create the version instance+-- for your migration. You just need to provide it with the number+-- of the version and a Proxy corresponding to the directly previous+-- state. Since the version in the default instance starts with a+-- version number of 0, we choose 1 as the version. -insertPage :: MonadState State m => String -> Page -> m ()-insertPage pageName page = modPages $ Map.insert pageName page+instance Component AppState where+ type Dependencies AppState = End -- no dependencies+ initialValue = AppState (0,0) -modPages :: MonadState State m => (Pages -> Pages) -> m ()-modPages f = modify (\s -> State (f $ pages s))+incVal :: Update AppState ()+incVal = do+ AppState (i,j) <- get+ put $ AppState (i+1,j+1) -askPages :: MonadReader State m => m (Pages)-askPages = asks pages+askVal :: Query AppState (Int,Int)+askVal = do+ AppState p <- ask+ return p -$(mkMethods ''State ['askPages, 'insertPage])+$(mkMethods ''AppState ['askVal, 'incVal])
− src/migrationexample/StateVersions/AppState3.hs
@@ -1,64 +0,0 @@-{-# OPTIONS -fglasgow-exts #-}-{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances,- MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}-module StateVersions.AppState3 ( InsertPage (..), State, AskPages (..), Page (..), Old.Title(..), Old.Body (..),- Header (..)-) where--import Happstack.State-import qualified Data.Map as Map-import Data.Generics hiding ((:+:))-import Control.Monad-import Control.Monad.Reader-import Control.Monad.State (modify,put,get,gets,MonadState)--import qualified StateVersions.AppState2 as Old--newtype Header = Header String- deriving (Read,Show,Eq,Data,Typeable)-instance Version Header-$(deriveSerialize ''Header)--type Title = Old.Title-type Body = Old.Body ----- Keep the page-data Page = Page Title Header Body - deriving (Read,Show,Eq,Data,Typeable)---- should this version somehow extend the version from State2?-instance Version Page-$(deriveSerialize ''Page)---type Pages = Map.Map String Page-data State = State { pages :: Pages- } deriving (Read, Show, Typeable, Data)---- Only for the new state-$(deriveSerialize ''State)--instance Migrate Old.State State where- migrate (Old.State p) = State (Map.map migratepage p)- -migratepage (Old.Page t b) = Page t (Header "") b --instance Version State where- mode = extension 2 (Proxy :: Proxy Old.State)---instance Component State where- type Dependencies State = End -- no dependencies- initialValue = State {pages = Map.empty} -- no pages--insertPage :: MonadState State m => String -> Page -> m ()-insertPage pageName page = modPages $ Map.insert pageName page--modPages :: MonadState State m => (Pages -> Pages) -> m ()-modPages f = modify (\s -> State (f $ pages s))--askPages :: MonadReader State m => m (Pages)-askPages = asks pages--$(mkMethods ''State ['askPages, 'insertPage])
templates/cookies.st view
@@ -1,17 +1,5 @@ <h3>Cookies</h3> -<p>Cookies don't work quite right in Happstack out of the box. The most common problem- is that google analytics and Happstack session cookies are mutually incompatible.- (There is a thread about what went wrong in the initial implementation in the Happstack googlegroup.)--<p>Support for cookies will be improved in future Happstack releases.--<p>Meanwhile, there is a workaround in the happstack-helpers package on hackage, which is used by happs-tutorial,- and is built into smartserver.- So, cookies do work in happs-tutorial: I use google analytics to track visitors, - along with normal Happstack session cookies.- If you use happs-tutorial as a template for your apps you should be fine.- <p>Besides the cookies used by google analytics, which are obfuscated by javascript, happs-tutorial uses cookies to track session state -- the data that corresponds to the current user's session in <br>@@ -19,12 +7,12 @@ <br> appsessions :: Sessions SessionData, <br> appdatastore :: Users <br>} deriving (Show,Read,Typeable,Data)-+</p> <p>When you log in, a cookie is created that expires in an hour (3600 seconds). Every time a happstack handler needs to check if a user is logged in (for example, when it needs to decide whether to show the logged-in-user menubar), a check is made to see if a cookie- has been set. + has been set. </p> <p>The cookie code is in <a href=/projectroot/src/Misc.hs>ControllerMisc.hs</a>: @@ -35,8 +23,9 @@ <br> addCookie (3600) (mkCookie "sid" (show key)) <br> ..... <br>-<br>getMbSessKey rq = runReaderT (readCookieValue "sid") (rqInputs rq,rqCookies rq)-+<br>getMbSessKey rq = runReaderT (readCookieValue "sid") (rqInputs rq,rqCookies rq)</p>+<p>As you can see, the basic use of cookies is surprisingly simple with the two functions+addCookie and mkCookie</p> <p>We've spent a good bit of time now on how happstack-server handles requests, so we're ready to move on to the major feature of happstack-state,- <a href="/tutorial/introductiontomacid">MACID</a>.+ <a href="/tutorial/introductiontomacid">MACID</a>.</p>
@@ -1,4 +1,6 @@ <div id="footer">+ happstack tutorial v 0.8.1+ <br> copyright thomashartman1 at gmail, wchogg 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>
+ templates/ixset.st view
@@ -0,0 +1,11 @@+<h3>Introduction to IxSet</h3>+<p>There's another utility package included in the Happstack suite, happstack-ixset, which you might find useful</p>+<p>In a nutshell, the package provides a module Happstack.Data.IxSet, that defines a new data type which acts+an awful lot like the old familiar Data.Map but allows you to easily select subsets based upon component data.</p>+<p>An example is included with this tutorial at <a href="/src/IxSetExample.hs">IxSetExample.hs</a>.</p>+<p>I suggest reading over the code included to supplement the haddock documentation for Happstack.Data.IxSet and+playing with all of the values starting with "ex" to make sure you feel comfortable with the values they have and why.</p>+<p>I make no attempt to cover all of the combinators defined in Happstack.Data.IxSet, but I hope I cover enough of them+to give you a good start.</p>+<p>A final note about IxSet is that if the contained type is an instance of Serialize, then the entire IxSet will+be an instance of Serialize thus making it suitable for use with Happstack.State<p>
templates/macidlimits.st view
@@ -4,14 +4,13 @@ <p>Keeping everything in macid limits you to how much RAM you can afford. Even if you have a business model where 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, if you are limited to one computer.+ max that out if your application has a lot of data, if you are limited to one computer.</p> <p>(See the <a href=/tutorial/macid-stress-test>stress test</a> chapter for more caveats.) The Happstack core developers have promised Happstack features that will make it easy to share application state across many computers, making scaling to ebay-sized proportions relatively straightforward: you - just add more computers to your amazon EC2 cloud. This feature is called Multimaster and will be- documented more in a future chapter of this tutorial.+ just add more computers to your amazon EC2 cloud.</p> <p>My take is that, as currently implemented, Macid may be impractical for an app with tens of thousands of @@ -57,4 +56,4 @@ <p>The remaining chapters are of an appendix nature. Nice to have, but not fundamental. -<p>If you want to keep reading, the next chapter is about using <a href=/tutorial/foreignchars>utf8</a> in happs.+<p>If you want to keep reading, the next chapter is about using <a href=/tutorial/foreignchars>utf8</a> in Happstack.</p>
templates/macidmigration.st view
@@ -1,224 +1,36 @@ <h3>Macid migration</h3> -<p>What happens when your data model changes?--<p>People who have been following this tutorial for a while may have noticed that every time I come out with - a new version, the existing users and jobs disappear and we start out with a blank slate again.--<p>That's because changing the data schema of a happstack-with-macid web app (aka migrating) is a chore.+<p>What happens when your data model changes?</p> -<p>It's a chore with traditional web apps too. But it's probably more difficult with macid, especially- given the sparse documentation.- <p>This isn't a problem for tutorial.happstack.com, because typically there are only a few dozen users and jobs, plus whatever dummy data I've entered myself. Who cares?- So far, rather than migrating, I've just wiped the slate clean.--<p>However, that isn't going to work for your latest facebook-killer.--<p>The good news is, there is a way to migrate Happstack state through various iterations, it's sufficiently- documented if you know where to look, and it's not too painful once you've gotten used to it.--<p>The main challenge is finding documentation. --<p>The best documentation I have found is two threads in the happs googlegroup, along with the migration example- that was produced by eelco lempsink during the thread. I have taken this migration example example and- included it in the happstutorial distribution, with some improvements of my own.--<p>The googlegroup migration threads are - <a href="http://groups.google.com/group/HAppS/browse_thread/thread/c23101b258d337d0/261e3a871853b0e8?">here</a>- and follow-up <a href="http://groups.google.com/group/HAppS/browse_thread/thread/98e129e6349e4b0b/0e174e9c36edbd72">here</a>.--<p>The migration example I've included with the tutorial is at <a href="/src/migrationexample">migrationexample</a>.--<p>My advice is to try the demo in <a href="/projectroot/src/migrationexample">migrationexample</a> first, - following the directions in the <a href ="/projectroot/src/migrationexample/README">README</a> file, - read through the source files to understand how the demo works,- and then refer to the googlegroups thread if necessary.--<p>Possibly this is sufficient documentation for you to start doing migrations yourself. If so, great,- ignore what follows.--<p>If you feel like you could use more guidance, read on for some notes I put together on my own- migration experience.--<hr>--<p>Though I haven't started migration for the toy job board in happs-tutorial, I am using it for my - commercial project that is under development. This will be the basis of the notes that follow.--<p>I almost didn't include these notes, because I wanted to provide an- easy step by step example that referenced the toy job board as I have done for other tutorial topics.- However, doing this will be quite a bit of work, I haven't gotten around to doing this after many weeks.- I want to get the information out, so I decided to just share what I have. --<p>I apologize in advance if some of this seems confusing or fragmentary. I did my best, and I will - try to clean things up and integrate the example into the tutorial rather than snipping from an external app.--<hr>--<p>Ok... General migration notes:--<p> Old state module names should not change, nor be shifted around in- directory structure (which is really just another kind of name- change). Therefore it's a good idea to start out with a sane- directory hierarchy for schema versions before you start doing- migrations. I recommend keeping App state in one monolithic file, in- a directory devoted to state versions. It makes schema migrations- much easier, as all references to the old state can then be handle- via import Qualified StateLast.hs as Old, then referenced via- Old.whatever, when bits of logic that remain consistent between the- old monolithic state file and the new monolithic state file. Resist- the temptation to split state into multiple files. Bear in mind that due to template haskell the order of- data structures declarations becomes significant, which is usually not- the case with haskell. (I seem to reall this annoyance was part of the- reason why I started splitting things into multiple files to begin- with, which I later regretted because it made migration that much harder.) --<p> Don't call Happstack State "State", as this conflicts with the- State datatype in Control.Monad.State. I usually call my state- datatype AppState.--<p> There will be code duplication, for the functions that get- transformed to state modifiers in template haskell. This is a bad- code smell, but I think it's unavoidable for the mkMethods directive with - all the methods template haskell needs.- -<p> In the old state file (being migrated from), make sure it exports- everything via module OldState ( ... everything gets exported here- ...) where.... My way to do this is load the state module, :browse- in ghci, copy the output, and clean it up using emacs regexen. In- emacs, dired-mark-files-regexp and dired-do-query-replace-regexp are- your friends.--<p> Then, (my way), cd StateVersions, cp AppState1.hs AppState2.hs (or whatever version number we're on.)--<p> Seems almost too obvious to say, but if you have live customer- you're not going to want to migrate this without having tested the- migration in a sandbox first. Create your sandbox, which should- include a snapshot of live customer data. Good way to create a- snapshot is tar -czvf _local on your live data. Test thoroughly on this - snapshot before doing the live migration. And even if you think you've tested enough, - tar snapshot your live data before the migration again, just in case.--<hr>--Notes for doing a step by step migration:--<p>Make a live data snapshot and copy it to your migration sandbox: _local.tar.gz. (If there is an unwieldy large - amount of data, create a smaller data set by setting up a server identical with the live server and doing some - actions manually.)--<p> cd StateVersions; cp AppState1.hs AppState2.hs (or whatever version we're on)- For now, we just want a placeholder that will have AppState2 behaving exactly like AppState1.- change references from AppState1.hs to AppState2.hs in app code.- try running server, the result should be that it compiles, runs, but all data is all lost. (because we haven't written migration yet.)- -<p>roll back from backup taken earlier: rm -rf _local and tar -xzvf _local.tar.gz (an explicit reminder to - rollback the live data tar may be omitted from future steps, but basically you keep rolling back until - you get a successful migration.)--<p> modify AppState (or whatever your main State datastructure is), say, adding a field. Don't write a Migrate instance - yet. Try running. You'll probably get an error like "Exception: Non-exhaustive patterns in case."- Kind of a crappy error message if you ask me, but ok. What's happening is the pre-existing data in the - _local directory isn't compatible with your modified AppState. If you rm -rf _local and try running again, it should - work now. But of course you have lost all your data, and need to rollback the live data again for the next step. - -<p> Now make necessary changes in code for migration. - See eelco's and my uploads to - <a href="http://groups.google.com/group/HAppS/browse_thread/thread/98e129e6349e4b0b/0e174e9c36edbd72?lnk=gst&q=eelco+tphyahoo#0e174e9c36edbd72">happs google group</a>. - Summary is:- modify the version instance for AppState and add a migrate instance, allong the following lines. First, --<p> import qualified StateVersions.AppState1 as Old-<br> ...-<br> -- we'll say 2 because this is StateVersions/AppState2.hs-<br> -- I don't think it matters what number you use as long as it's higher than the last version, -<br> -- but I'd like to have a core dev confirm that intuition.-<br> -- I wonder too what happens if you screw up this version number somehow. EG, what if you specify a version number-<br> -- identical to the version you're migrating from?-<br> instance Version AppState where-<br> mode = extension 2 (Proxy :: Proxy Old.AppState) --<p> This won't compile, you'll get an error about a missing (Migrate Old.AppState AppState) - instance arising from use of extension. So we supply the instance--<p> instance Migrate Old.AppState AppState where-<br> migrate (Old.AppState s d) = AppState (migrates s) (migrated d)-<br> migrates s = undefined-<br> migrated (us, aus, rs, rus) = undefined--<p> We use undefined just to get it to compile and have something to darcs commit, and then write sensible code later.- -<br>*Main> :! grep -irn AppState1 *.hs-<br>Controller.hs:27:import StateVersions.AppState1-<br>ControllerAppMigration.hs:18:import StateVersions.AppState1-<br>......-<br>View.hs:29:import StateVersions.AppState1--<p>These are the places in the code that need to be switched to use AppState2 instead.--<br>Let's test this by adding an emails field to UserInfos-<br>Actually, first let's try adding an email field to Macid1 and see if we get an error.-<br>We do get an error, and it's a weird error:-<br> *** Exception: src/Macid1/Repos.hs:45:2-24: Non-exhaustive patterns in case-<br> at \$(deriveSerialize ''Repos) --<p>Is non-exhaustive pattern because somewhere behind the scenes there has been a macid version bump - when it detected that the schema changed?--<p>Dunno, but let's try now by switching state to AppState2.hs-<p>Let's also note the latest checkpoint in the _local directory. It is: ...-<br> ls -lth _local/patch-shack_state/ | head -n2-<br>... checkpoints-0000000014--<p>and back it up: -<br> tar -czvf _loacl.beforemigration.tar.gz _local--<p>Step1, cd StateVersions; cp AppState1.hs AppState2.hs. Ok, that works. (Haven't actually used migration machinery yet.)--<p>Now, let's try using the migration machinery, but the migrate is actually just id (so no data structure actually changes).--<p>The following is a snip from a working migration instance, where one field in an interior data structure-has been added. (Specifically, UserProfile has gone from a 3 argument constructor to a 4 argument constructor).--<p>You might think this looks like a lot of boilerplate for adding a single field, and I would agree. The good news-is that your migration code will look similar if you are making more than just that one change, and the problem-is still tractable.--<p>And of course, migrations with a database back-end are no picnic either.--<hr>-<p>Migrate instance example (add a field to UserProfile):+ So far, rather than migrating, I've just wiped the slate clean.</p> -<font color=orange>-<p>instance Migrate Old.AppState AppState where-<br> migrate (Old.AppState s d) = AppState (migrates s) (migrated d)-<br>-<br>-- Nothing changed in sessions -- it's the second arg to appstate (AppDatastore users) that had a field added-<br>-- We could have avoided writing migrates by using type synonyms to exactly copy the types from AppState1, -<br>-- as is done in eelco's example.-<br>-- I prefer to write out the migration explicitly rather than use type synonyms, because then after a successful -<br>-- migration the Migrate instance and the old state code can be removed, and you wind up with just a monolithic-<br>-- state file evolving over time rather than a sequence of states each with a module dependency on the previous state-<br>-- . (I think this is the case -- still have to prove this works.)-<br>migrates :: Old.Sessions Old.SessionData -> Sessions SessionData-<br>migrates (Old.Sessions s) = Sessions . M.map f \$ s-<br> where f :: Old.SessionData -> SessionData-<br> f (Old.UserSession (Old.UserName u) ) = UserSession (UserName u)-<br> f (Old.AdminSession (Old.AdminUserName u) ) = AdminSession (AdminUserName u)-<br>-<br>migrated (Old.Users us, Old.AdminUsers aus, Old.Repos rs, Old.RepoUsers rus) = -<br> ( (Users . M.map ui . M.mapKeys uk \$ us), -<br> (AdminUsers . M.map auv . M.mapKeys auk \$ aus),-<br> (Repos . M.map rv . M.mapKeys rk \$ rs), -<br> (RepoUsers . IXS.fromSet . S.map ru . IXS.toSet \$ rus ) -<br> )-<br> where ui (Old.UserInfos p (Old.UserProfile c bl av ) ) = UserInfos p (UserProfile S.empty c bl av)-<br> uk (Old.UserName u) = UserName u-<br> auk (Old.AdminUserName u) = AdminUserName u-<br> auv (Old.AdminUserInfos p) = AdminUserInfos p-<br> rv (Old.Repo (Old.UserName u) bud blu isp) = Repo (UserName u) bud blu isp-<br> rk (Old.RepoName n) = RepoName n-<br> ru (Old.RepoUser (Old.RepoName n) (Old.UserName u) ) = RepoUser (RepoName n) (UserName u)-</font> +<p>However, that isn't going to work for your latest facebook-killer. Instead, you need to use Happstack's +migration machinery. Migrating is actually far simpler than one might expect. There are really only two things+you need to understand to make it work: the Migrate and Version type classes.</p>+<p>ghci>:m + Happstack.Data+<br>ghci>:i Migrate+<br>class Migrate a b where migrate :: a -> b+<br> -- Defined in Happstack.Data.Migrate+<br>ghci>:i Version+<br>class Version a where mode :: Mode a+<br> -- Defined in Happstack.Data.Serialize+<br>ghci>:i Mode+<br>data Mode a+<br> = Primitive | Versioned (Happstack.Data.Serialize.VersionId a) (Maybe (Happstack.Data.Serialize.Previous a))+<br> -- Defined in Happstack.Data+</p>+<p>Now, you've already seen in previous Happstack.State examples that we've been relying on the default instance of+Version. It defines the given type as being of version number 0 and having no previous version. This is good enough+for your first version of application state.</p>+<p>The basic intuition is that if you want one data type to be converted to another in a new version, it needs to be+reflected in an instance of Migrate, with the actual conversion function between the two types, and in the Version instance+of the new state type. You really don't need to do a lot more than this in order to have your migration working correctly.</p>+<p>Try taking a look at the code in <a href="/projectroot/src/migrationexample">src/migrationexample</a> in order to get a feel for how+to practically make migrations work.</p>+<ol>+<li>Read over the comments in the migrationexample files</li>+<li>runghc CreateState1.hs</li>+<li>runghc MigrateToState2.hs</li>+</ol>
templates/multimaster.st view
@@ -1,6 +1,7 @@ <h3>Scaling your applications with multimaster</h3> <p>-An obvious concern when learning that Happstack.State keeps all state in memory is scalability. After all, that certainly seems to imply that one can only use a single Happstack instance on one machine to service your entire application. Fortunately, this isn't the case thanks to a feature called multimaster!+When first learning that Happstack.State keeps all state information in memory, you might assume that your application+must be served by a single instance running on a single machine. This is actually not the case! You can have a number of nodes each with their own copy of the state using a feature called multimaster. </p> <p>Multimaster is a way to synchronize state between multiple Happstack instances. It's built atop the <a href="http://www.spread.org/">Spread Toolkit</a> via the
templates/toc.st view
@@ -1,4 +1,5 @@-[("/tutorial/home","build a web 2.0 app in happstack")+[("/tutorial/whatsnew","new in this version")+ , ("/tutorial/home","build a web 2.0 app in happstack") , ("/tutorial/why-happstack-is-cool","why happstack is cool") , ("/tutorial/getting-started","getting started with happstack") , ("/tutorial/prerequisites","prerequisites")@@ -21,6 +22,7 @@ , ("/tutorial/macid-stress-test","macid stress test") , ("/tutorial/macid-limits","limitations of macid") , ("/tutorial/foreignchars","foreign characters")+ , ("/tutorial/ixset","IxSets") , ("/tutorial/start-happstack-on-boot","cron jobs") , ("/tutorial/thanks","thanks") , ("/tutorial/ghci-floundering-askdatastore","appendix (floundering in ghci)")]
+ templates/whatsnew.st view
@@ -0,0 +1,7 @@+<h3>What's new in version 0.8.1</h3>+<ul>+<li>New section on IxSets</li>+<li>Simplified migration examples</li>+<li>General cleanups of the tutorial code</li>+<li>Using random numbers in Updates and Queries in MACID intro</li>+</ul>
templates/yourfirsthappstack.st view
@@ -76,7 +76,7 @@ </p> <p>Please don't be alarmed by that type signature. This function is actually very simple for any cases you're likely to use. simpleHTTP itself is equivalent to simpleHTTP' id.</p>-<p>Take a look at the source of <a href="/src/StateTExample.hs">StateTExample.hs</a> and then try running StateTExample.</p>+<p>Take a look at the source of <a href="/src/StateTExample.hs">StateTExample.hs</a> and then try running StateTExample with, for example, runghc StateTExample.hs.</p> <p>If you navigate to localhost:8880 then you should see the little lonely number 1. Try it a few more times! Has the number changed at all? This is because each handling of a request will apply the (flip evalStateT 0)
templates/yourfirstmacid.st view
@@ -7,8 +7,21 @@ you left it. Cool, eh?</p> <p>One thing I want to point out is that this example makes no use of Happstack.Server whatsoever. They are completely independent of each other.</p>-<p>Now we have a second example to look at before we're done with this intro to Happstack.State: -<a href="/src/ComponentExample.hs">ComponentExample.hs</a>. Again, you'll want to read the-inline comments as they contain the bulk of the instruction of this chapter.</p>+<p>Now here's a second example to look at, one that demonstrates using a non-trivial Dependencies+list in order to improve modularity: <a href="/src/ComponentExample.hs">ComponentExample.hs</a>. +Again, you'll want to read the inline comments as they contain the bulk of the instruction of this chapter.</p>+<p>To summarize the major points of this chapter: </p>+<ul>+<li>By default, Happstack.State serializes an event record under the _local directory.</li>+<li>The state management is started with the startSystemState function</li>+<li>For a data type to be used as the state, it needs to be an instance of Component which itself+requires a number of other instances.</li>+<li>Checkpointing allows you to serialize the actual state and not just the event record. + <ul>+ <li>You can roll back time by deleting the events that took place after the checkpoint.</li>+ <li>Checkpointing must be done by manually calling createCheckpoint</li>+ </ul></li>+<li>Dependencies allow separate components to be combined together into the final top level state.</li>+</ul> <p>Next we'll talk about creating -<a href="/tutorial/multimaster">distributed</a> applications using Happstack.State.+<a href="/tutorial/multimaster">distributed</a> applications using Happstack.State.</p>