happs-tutorial 0.7.1 → 0.8
raw patch · 53 files changed
+1864/−673 lines, 53 filesdep +sybdep ~basedep ~happstack-datadep ~happstack-helpers
Dependencies added: syb
Dependency ranges changed: base, happstack-data, happstack-helpers, happstack-server, happstack-state, hscolour
Files
- happs-tutorial.cabal +17/−8
- src/AppStateGraphBased.hs +157/−0
- src/ComponentExample.hs +85/−0
- src/Controller.hs +55/−72
- src/ControllerBasic.hs +87/−96
- src/ControllerGetActions.hs +67/−73
- src/ControllerMisc.hs +18/−16
- src/ControllerPostActions.hs +46/−69
- src/ControllerStressTests.hs +39/−28
- src/FirstMacid.hs +177/−0
- src/FromDataInstances.hs +9/−6
- src/Main.hs +11/−16
- src/Misc.hs +11/−27
- src/MiscMap.hs +8/−3
- src/MultiExample1.hs +60/−0
- src/MultiExample2.hs +55/−0
- src/MultiExample3.hs +50/−0
- src/Redirector.hs +9/−0
- src/SerializeableSocialGraph.hs +39/−0
- src/StateTExample.hs +19/−0
- src/StateVersions/AppState1.hs +18/−31
- src/UniqueLabelsGraph.hs +72/−0
- src/View.hs +18/−18
- src/add10000users.hs +14/−0
- src/gentable.hs +13/−0
- src/migrationexample/CreateState1.hs +21/−0
- src/migrationexample/MigrateToState2.hs +23/−0
- src/migrationexample/MigrateToState3.hs +23/−0
- src/migrationexample/README +55/−0
- src/migrationexample/Setup.lhs +3/−0
- src/migrationexample/StateVersions/AppState1.hs +51/−0
- src/migrationexample/StateVersions/AppState2.hs +49/−0
- src/migrationexample/StateVersions/AppState3.hs +64/−0
- templates/basichtml.st +20/−0
- templates/basicurlhandling.st +13/−16
- templates/cookies.st +5/−5
- templates/debugging.st +10/−14
- templates/getandpost.st +48/−18
- templates/happstackwostate.st +8/−0
- templates/home.st +6/−7
- templates/introductiontomacid.st +8/−11
- templates/maciddatasafety.st +26/−39
- templates/maciddummydata.st +8/−3
- templates/mainfunction.st +6/−6
- templates/moreserver.st +67/−0
- templates/multimaster.st +47/−0
- templates/prerequisites.st +5/−17
- templates/runtutoriallocally.st +20/−43
- templates/templatesdontrepeatyourself.st +1/−1
- templates/toc.st +6/−5
- templates/whyhappstackiscool.st +17/−25
- templates/yourfirsthappstack.st +86/−0
- templates/yourfirstmacid.st +14/−0
happs-tutorial.cabal view
@@ -1,5 +1,5 @@ Name: happs-tutorial-Version: 0.7.1+Version: 0.8 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 @@ -8,23 +8,29 @@ Author: Thomas Hartman, Eelco Lempsink, Creighton Hogg Maintainer: Creighton Hogg <wchogg at gmail.com>-Copyright: 2008 Thomas Hartman+Copyright: 2008 Thomas Hartman, 2009 Thomas Hartman & Creighton Hogg Stability: Experimental Category: Web Build-type: Simple --- when cabal install 1.6 comes out, hopefully can use * patterns for templates--- see http://hackage.haskell.org/trac/hackage/ticket/213 Extra-Source-Files: recompile-and-kill-head.sh hackInGhci.sh static/*.png static/*.css templates/*.st+ src/*.hs+ src/migrationexample/*.hs+ src/migrationexample/*.lhs+ src/migrationexample/StateVersions/*.hs+ src/migrationexample/README Cabal-Version: >= 1.6 +Flag base4+ Description: Choose the even newer, even smaller, split-up base package.+ Executable happs-tutorial Main-is: Main.hs hs-source-dirs:@@ -41,7 +47,10 @@ MiscMap ControllerStressTests View- Build-Depends: base>=3.0.3.0, HStringTemplate, HStringTemplateHelpers, mtl, bytestring,- happstack-server == 0.1, happstack-data == 0.1, happstack-state == 0.1,- containers, pretty, pureMD5, directory, filepath, hscolour >= 1.10.1, HTTP, safe,- old-time, parsec, happstack-helpers >= 0.11 && < 0.20, DebugTraceHelpers+ 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+ if flag(base4)+ Build-Depends: base >=4 && <5, syb
+ src/AppStateGraphBased.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, + MultiParamTypeClasses, DeriveDataTypeable, TypeFamilies,+ TypeSynonymInstances, PatternSignatures #-}++module AppStateGraphBased where ++import qualified Data.Map as M+import qualified Data.Set as S+import Data.List+import Control.Monad.Reader+import Control.Monad.State (modify,put,get,gets)++import Data.Generics+import Happstack.State+++import SerializeableSessions+import SerializeableSocialGraph+++import Misc+import SerializeableTree++{-+DynGraphUqL is class hack datastructure for a graph with unique labels, with functions+for non-unique-labeled graphs hidden from imported Data.Graph.Inductive++(Eg mkGraph, insNode, etc are hidden)++So don't import anything from Data.Graph.Inductive.+Export whatever you need in UniqueLabelsGraph+++class (Ord a, DynGraph gr) => DynGraphUqL a gr where ........+-}+import UniqueLabelsGraph++++-- Think of appdatastore as the database in a traditional web app.+-- Data there gets stored permanently+-- Data in appsessions is stored permanently too, but we don't care as much about its persistence,+-- it's just to keep track of who is logged in at a point in time.+-- appsessions field could be less complicated, just have M.Map Int SessionData+-- don't really see the advantage of declaring a wrapper over map.++-- Works! At least, it compiles :)+data AppState = AppState {+ appsessions :: Sessions SessionData, + appdatastore :: SocialGraph+} deriving (Show,Read,Typeable,Data)+instance Version AppState +$(deriveSerialize ''AppState) +instance Component AppState where + type Dependencies AppState = End + initialValue = AppState { appsessions = (Sessions M.empty),+ appdatastore = SocialGraph empty }++askDatastore = do+ (s :: AppState ) <- ask+ return . appdatastore $ s++askUsersGraph = askDatastore >>= return . socialgraph++askUsersSet :: Query AppState (S.Set User) +askUsersSet = askUsersGraph >>= return . labelsetFromGraph+++askSessions :: Query AppState (Sessions SessionData)+askSessions = return . appsessions =<< ask++-- modUsers :: ( S.Set User -> S.Set User ) -> Update AppState ()+modGraph :: ( Gr User Float -> Gr User Float ) -> Update AppState ()+modGraph f = modify (\appS -> (AppState (appsessions appS)+ ( SocialGraph . f . socialgraph . appdatastore $ appS)))++modSessions :: (Sessions SessionData -> Sessions SessionData) -> Update AppState ()+modSessions f = modify (\s -> (AppState (f $ appsessions s) (appdatastore s))) ++isUser :: String -> Query AppState Bool+isUser name =+ return . (S.member name) . (setmap username) =<< askUsersSet++-- I tried to declare a functor instance for Set a but got blocked.+setmap f = S.fromList . map f . S.toList+++addUser :: String -> String -> Update AppState ()+addUser name pass = modGraph $ addLab (User name pass Nothing Nothing ) ++--modUsers :: ( S.Set User -> S.Set User ) -> Update AppState ()+modUsers f = modify (\s -> (AppState (appsessions s) (f $ appdatastore s)))+++changePassword :: String -> String -> String -> Update AppState ()+changePassword username oldpass newpass = modUsers $ changepasswordPure username oldpass newpass+++-- yowch! modify is delete plus insert? +-- this will work for the time being, but will probably eventually need to be something smarter+-- also it would be nice if the type could reflect the possibility of failure, (Maybe, Either, etc)+-- but can't figure out how to do that smartly+-- modify is simply delete plus insert +changepasswordPure :: String -> String -> String -> SocialGraph -> SocialGraph+changepasswordPure u inputtedOldpass inputtedNewpass (SocialGraph usersgraph ) = + let hashedoldpass = scramblepass inputtedOldpass+ hashednewpass = scramblepass inputtedNewpass+ mbU = lookupUser ( (==u). username) usersgraph + resetP olduser@(User u realoldpass mbCP mbJobs ) =+ if realoldpass == hashedoldpass+ then modLab (const $ User u hashednewpass mbCP mbJobs ) olduser usersgraph+ else usersgraph+ in SocialGraph $ maybe usersgraph resetP mbU ++getUser :: String -> Query AppState (Maybe User)+getUser u =+ askUsersGraph >>=+ return . lookupUser ((==u) . username)++lookupUser f users = find f . S.toList . labelsetFromGraph $ users+++listUsers :: Query AppState [String]+listUsers = liftM (map username . S.toList) askUsersSet+newSession :: SessionData -> Update AppState SessionKey+newSession u = do+ key <- getRandom+ modSessions $ Sessions . (M.insert key u) . unsession+ return key++delSession :: SessionKey -> Update AppState ()+delSession sk = modSessions $ Sessions . (M.delete sk) . unsession+++getSession::SessionKey -> Query AppState (Maybe SessionData)+getSession key = liftM (M.lookup key . unsession) askSessions++numSessions :: Query AppState Int+numSessions = liftM (M.size . unsession) askSessions++-- define types which are upper case of methods below, eg AddUser, AuthUser...+-- these types work with HApppS query/update machinery+-- in ghci, try :i AddUser++$(mkMethods ''AppState+ ['askUsersSet+ , 'getUser + , 'addUser+ , 'changePassword + , 'isUser+ , 'listUsers+ , 'getSession+ , 'newSession+ , 'delSession+ , 'numSessions]+ )+
+ src/ComponentExample.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,+ MultiParamTypeClasses, TypeFamilies, FlexibleContexts,+ TypeSynonymInstances, TypeOperators #-}++module Main where++{- The following is a fairly simple example using+ multiple components. It essentially follows the same structure+ as the previous example with the exception that the final+ state, State3, doesn't actually contain any data but has the+ other two states as a part of its dependency. This means+ we can create Update and Query functions against State1 and+ State2 and use them both if we make our proxy have type+ State3.++ This allows you to make orthogonal components into separate,+ potentially reusable, modules.+-}++import Happstack.State+import Data.Typeable+import Control.Monad.State+import Control.Monad.Reader++data State1 = State1 Int+ deriving (Typeable,Show)+instance Version State1+$(deriveSerialize ''State1)++getState1 :: Query State1 Int+getState1 = do+ State1 n <- ask+ return n++setState1 :: Int -> Update State1 ()+setState1 = put . State1++$(mkMethods ''State1 ['getState1,'setState1])++instance Component State1 where+ type Dependencies State1 = End+ initialValue = State1 0++data State2 = State2 String+ deriving (Typeable,Show)+instance Version State2+$(deriveSerialize ''State2)++getState2 :: Query State2 String+getState2 = do+ State2 s <- ask+ return s++setState2 :: String -> Update State2 ()+setState2 = put . State2++$(mkMethods ''State2 ['getState2,'setState2])++instance Component State2 where+ type Dependencies State2 = End+ initialValue = State2 ""++data State3 = State3+ deriving (Typeable,Show)+instance Version State3+$(deriveSerialize ''State3)++instance Component State3 where+ type Dependencies State3 = State1 :+: State2 :+: End+ initialValue = State3+-- Wait, I haven't defined any methods, so why do I need to call+-- mkMethods? mkMethods actually does a good bit of boilerplate+-- that you need even if you haven't defined any Update or Query+-- methods for your component+$(mkMethods ''State3 []) ++main :: IO ()+main = do+ startSystemState (Proxy :: Proxy State3)+ s1 <- query GetState1+ print s1+ s2 <- query GetState2+ print s2+ update $ SetState1 10+ update $ SetState2 "TEST"
src/Controller.hs view
@@ -2,19 +2,12 @@ module Controller where -import Control.Monad-import Control.Monad.Trans-import Data.List+import Control.Monad.State import qualified Data.Map as M-import qualified Data.Set as S-import Data.Maybe -import HAppS.Server -import HAppS.State+import Happstack.Server import Text.StringTemplate import System.FilePath-import System.Directory import Data.Char-import Debug.Trace.Helpers import StateVersions.AppState1 import View @@ -24,22 +17,22 @@ import ControllerMisc import ControllerStressTests -import HAppS.Helpers+import Happstack.Helpers import Misc -import Data.ByteString.Internal import Text.StringTemplate.Helpers-+import Data.Monoid -staticfiles = [ staticserve "static"- , staticserve "userdata"- , browsedir "projectroot" "."- , browsedirHS "templates" "templates"- , browsedirHS "src" "src" - ] - where staticserve d = dir d [ fileServe [] d ]+staticfiles :: ServerPartT IO Response+staticfiles = msum [ staticserve "static"+ , staticserve "userdata"+ , browsedir "projectroot" "."+ , browsedirHS "templates" "templates"+ , browsedirHS "src" "src" + ] + where staticserve d = dir d (fileServe [] d) -- main controller-controller :: STDirGroups String -> Bool -> Bool -> [ServerPartT IO Response]+controller :: STDirGroups String -> Bool -> Bool -> ServerPartT IO Response controller tDirGroups dynamicTemplateReload allowStressTests = -- staticfiles handler *has* to go first, or some content (eg images) will fail to load nondeterministically, -- eg http://localhost:5001/static/Html2/index.html (this loads ok when staticfiles handler goes first,@@ -49,88 +42,78 @@ -- 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 - ++ ( tutorial tDirGroups dynamicTemplateReload allowStressTests ) - ++ simpleHandlers - ++ [ myFavoriteAnimal ] - ++ [ msgToSp "Quoth this server... 404." ]+ `mappend` ( tutorial tDirGroups dynamicTemplateReload allowStressTests ) + `mappend` simpleHandlers + `mappend` myFavoriteAnimal + `mappend` (return . toResponse $ "Quoth this server... 404.") -- with diretoryGroupsOld (lazy readFile), appkiller.sh causes crash+getTemplateGroups :: (Stringable a) => IO (M.Map FilePath (STGroup a)) getTemplateGroups = directoryGroupsHAppS "templates" -tutorial :: STDirGroups String -> Bool -> Bool -> [ServerPartT IO Response]-tutorial tDirGroups' dynamicTemplateReload allowStressTests = [ ServerPartT $ \rq -> do+tutorial :: STDirGroups String -> Bool -> Bool -> ServerPartT IO Response+tutorial tDirGroups' dynamicTemplateReload allowStressTests = do -- A map of template groups, with the key being the containing directory name -- If true, Redo IO action for fetching templates (which was also done in main) -- so templates are loaded from templates dir for every request. -- which lets you change templates interactively without stop/starting the server -- but has a higher server disk read load. Useful for development, bad for performance under a heavy load.+ rq <- askRq tDirGroups <- liftIO $ if dynamicTemplateReload then getTemplateGroups else return tDirGroups' mbSess <- liftIO $ getmbSession rq- let mbUName = return . sesUser =<< mbSess- mbUis <- case mbUName of- Nothing -> return Nothing- Just un -> query . GetUserInfos $ un- unServerPartT ( multi . (tutorialCommon allowStressTests ) $ RenderGlobals rq tDirGroups mbSess ) rq- ] ---+ tutorialCommon allowStressTests $ RenderGlobals rq tDirGroups mbSess -tutorialCommon :: Bool -> RenderGlobals -> [ServerPartT IO Response]-tutorialCommon allowStressTests rglobs =- [ exactdir "/" [ ServerPartT $ \rq -> ( return . tutlayoutU rglobs [] ) "home" ]- , dir "tutorial" [- dir "consultants" [ methodSP GET $ viewConsultants rglobs]- , dir "consultantswanted" [ methodSP GET $ viewConsultantsWanted rglobs ]- , dir "jobs" [ methodSP GET $ viewJobs rglobs]- , dir "logout" [ (logoutPage rglobs)] - , dir "changepassword" [ methodSP POST $ changePasswordSP rglobs ]-- , dir "editconsultantprofile" [ methodSP GET $ viewEditConsultantProfile rglobs - , methodSP POST $ processformEditConsultantProfile rglobs ]+tutorialCommon :: Bool -> RenderGlobals -> ServerPartT IO Response+tutorialCommon allowStressTests rglobs = msum + [ exactdir "/" (( return . tutlayoutU rglobs [] ) "home")+ , dir "tutorial" $ msum [+ dir "consultants" (methodSP GET $ viewConsultants rglobs)+ , dir "consultantswanted" (methodSP GET $ viewConsultantsWanted rglobs)+ , dir "jobs" (methodSP GET $ viewJobs rglobs)+ , dir "logout" (logoutPage rglobs) + , dir "changepassword" (methodSP POST $ changePasswordSP rglobs) - , dir "editjob" [ methodSP GET $ viewEditJobWD rglobs ]- , dir "deletejob" [ methodSP GET $ deleteJobWD rglobs ]- , dir "editjob" [ methodSP POST $ processformEditJob rglobs ]+ , dir "editconsultantprofile" (methodSP GET (viewEditConsultantProfile rglobs) `mappend` + (methodSP POST (processformEditConsultantProfile rglobs))) - , dir "postnewjob" [ methodSP POST $ processformNewJob rglobs ]- , dir "myjobposts" [ methodSP GET $ pageMyJobPosts rglobs ]- , dir "viewprofile" [ methodSP GET $ userProfile rglobs ]- , dir "viewjob" [ methodSP GET $ viewJob rglobs ] - , dir "actions" $- [ dir "login" [ methodSP POST $ loginPage rglobs ]- , dir "newuser" [ methodSP POST $ newUserPage rglobs ]- -- , dir "upload" [ methodSP POST $ uploadFilePage rglobs ]+ , dir "editjob" (methodSP GET $ viewEditJobWD rglobs)+ , dir "deletejob" (methodSP GET $ deleteJobWD rglobs)+ , dir "editjob" (methodSP POST $ processformEditJob rglobs)+ , dir "postnewjob" (methodSP POST $ processformNewJob rglobs)+ , dir "myjobposts" (methodSP GET $ pageMyJobPosts rglobs)+ , dir "viewprofile" (methodSP GET $ userProfile rglobs)+ , dir "viewjob" (methodSP GET $ viewJob rglobs) + , dir "actions" $ msum + [ dir "login" (methodSP POST $ loginPage rglobs)+ , dir "newuser" (methodSP POST $ newUserPage rglobs) ]- , dir "initializedummydata" [ spAddDummyData rglobs ]- , dir "stresstest"+ , dir "initializedummydata" (spAddDummyData rglobs)+ , dir "stresstest" $ msum [ -- more realistic, higher stress- dir "atomicinserts" [ spStressTest allowStressTests ("atomic inserts",atomic_inserts) rglobs] + dir "atomicinserts" (spStressTest allowStressTests ("atomic inserts",atomic_inserts) rglobs) -- faster, insert all users and all jobs in one transaction -- fast for small numbers of users, but slow for >1000- , dir "onebiginsert" [ spStressTest allowStressTests ("one big insert",insertus) rglobs]- , dir "atomicinsertsalljobs" [ spStressTest allowStressTests ("atomic inserts, all jobs at once",insertusAllJobs) rglobs] - ]+ , dir "onebiginsert" (spStressTest allowStressTests ("one big insert",insertus) 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 ) +spStressTest :: (MonadIO m) => Bool -> + (String, Users -> WebT m a) -> + RenderGlobals -> ServerPartT m Response spStressTest allowStressTest insertf rglobs = if allowStressTest then lastPathPartSp0 $ \_ numusers -> do n <- Misc.safeRead numusers- stressTest' insertf n rglobs+ withRequest $ const $ stressTest' insertf n rglobs else return $ tutlayoutU rglobs [("errormsg", failmsgStressTest)] "errortemplate" +failmsgStressTest :: String failmsgStressTest = "<br>-- Stress is blocked from happening on this happs server.\ \<br>-- For your own stress testinr, run like ./happs-tutorial 5001 True (the second arg controls the stress test)"------- tEmail = runIO $ echo "this is an email" -|- "mailx -s \"O HAI SUBJECT LINE\" thomashartman1@gmail.com"
src/ControllerBasic.hs view
@@ -1,60 +1,55 @@ module ControllerBasic where -import HAppS.Server+import Happstack.Server+import Happstack.Helpers import Misc import Data.Monoid import Text.StringTemplate.Helpers import Control.Monad.Trans import Text.StringTemplate +import Control.Monad {--ServerPartTs take a request to a response, approximately like so-Request -> WebT -> Result -> Response--Request handlers are functions from a request to a WebT, WebT is a wrapper over a Result,-and a Response is extracted from a Result by monadic machinery which you don't need -to understand for now.--A HAppS Server is generally a list of ServerPartTs. When the wrapped functions are run,-either they result in NoHandle or a valid response. If there's a valid response, it gets -displayed. If NoHandle, control is passed to the next ServerPartT/handler in the list.-If all the handlers produce NoHandle as a result, the result is a 404.+ServerPartTs conceptually just take a request to a response. -ServerPartT :: (Request -> WebT m a) -> ServerPartT m a-WebT :: m (Result a) -> WebT m a-data Result a- = NoHandle | Ok (Response -> Response) a | Escape Response+A Happstack webserver is fundamentally just a ServerPartT. +This is where the Monoid instance of ServerPartT comes in, as many ServerPartTs can+be combined together with mappend. mzero corresponds to a 404 and +mzero `mappend` f = f, while if f is not mzero then f `mappend` g = f.+This means that when the wrapped function is run, the combination of ServerPartTs will be+tried from left to right until one does not return mzero. If they all return mzero the+final result of the request is a 404. -} --- For everything below, the m monad is always IO and a result type is always Response,--- so nail down types with more precision, which I have found helps with debugging--- and understanding what's going on.-type TutHandler = ServerPartT IO Response-type TutWebT = WebT IO Response---simpleHandlers :: [ServerPartT IO Response]-simpleHandlers = [+-- For everything below, the m monad is always IO and the result type is always Response,+-- to nail down types with more precision, which I have found helps with debugging+-- and understanding what's going on. Until now we've been using String as the return+-- type of the ServerPartT. Why change to Response? Isn't the whole point of the+-- ToMessage class that we don't have to explicitely use Response? Well, yes, but+-- for the purpose of this example we want to combine a variety of ServerPartTs and+-- so we use the common denominator of the toResponse function to make them all have+-- the same type. - ServerPartT $ \rq -> do- ru <- (return . rqURL) rq+simpleHandlers :: ServerPartT IO Response+simpleHandlers = msum [do+ rq <- askRq -- If you explicitly want the Request received+ -- then use askRq. It's essentially just a convenience+ -- wrapper around the MonadReader method ask+ let ru = rqURL rq if ru == "/helloworld"- then ( return . toResponse ) "hello world, this is HAppS" - else noHandle- :: TutWebT+ then return . toResponse $ "hello world, this is Happstack" + else mzero - -- exactdir :: (Monad m) => String -> [ServerPartT m a] -> ServerPartT m a- -- given a url path (for the part of the path after the domain) and a list of handlers+ -- exactdir :: (Monad m) => String -> ServerPartT m a -> ServerPartT m a+ -- given a url path (for the part of the path after the domain) and a handler -- exactdir runs the handlers against the request if the request url matches the first argument.-- -- msgToSp creates a handler that will return a constant response for any request.- -- it is useful in conjunction with exactdir and other ServerPartT constructors.+ -- exactdir is from the happstack-helpers package on hackage, also maintained by the author -- argument is an exact url path. -- so first arg is preceded by a /. -- you can use exactdir "" to match the root path- , exactdir "/exactdir-with-msgtosp" [ msgToSp "this handler uses exactdir and msgToSp. subdirectories not allowed." ]+ , exactdir "/exactdir" ( return . toResponse $ "this handler uses exactdir and msgToSp. subdirectories not allowed." ) -- argument is a string, which matches the first element of the rqURL path. -- pops the rqURL array, and passes the modified request to the list of handlers.@@ -62,99 +57,95 @@ -- the first element of the rqURL path is dir1. -- so first arg is not preceded by a /. -- you cannot use dir to match the root path.- , dir "dir-with-msgtosp" [ msgToSp "this handler uses dir and msgToSp. subdirectories are allowed." ]+ , dir "dir" (return . toResponse $ "this handler uses dir and msgToSp. subdirectories are allowed." ) -- ServerPartTs are monoids. -- instance (Monad m) => Monoid (ServerPartT m a) -- two handlers can be glued together into one handler with mappend,- -- and a list of handlers can be glued with mconcat, - -- There is a "zero" or "empty" handler which results in a 404 page for any request.- -- The way "handler addition" works is... for h1 `mappend` h2 ...- -- if h1 rq is anything other than NoHandle, return that.- -- if it is noHandle, return h2 rq- , mappend ( exactdir "/handleraddition1" [msgToSp "handleraddition 1"] )- ( exactdir "/handleraddition2" [msgToSp "handleraddition 2"] )+ -- and a list of handlers can be glued with mconcat.+ -- The following should be a simple example of the monoidal product+ -- of ServerPartTs+ , mappend ( exactdir "/handleraddition1" (return . toResponse $ "handleraddition 1") )+ ( exactdir "/handleraddition2" (return . toResponse $ "handleraddition 2") ) -- more of same , mconcat [ mempty -- the zero handler has no effect- , exactdir "/handleraddition3" [msgToSp "handleraddition 3"]- , exactdir "/handleraddition4" [msgToSp "handleraddition 4"]- , exactdir "/handleraddition5" [msgToSp "handleraddition 5"]+ , exactdir "/handleraddition3" (return . toResponse $ "handleraddition 3")+ , exactdir "/handleraddition4" (return . toResponse $ "handleraddition 4")+ , exactdir "/handleraddition5" (return . toResponse $ "handleraddition 5") ] -- zero handler using mempty from the monoid instance, and the same thing again spelled out explicitly- , exactdir "/nohandle1" [mempty] - , exactdir "/nohandle2" [ ServerPartT $ \rq -> WebT $ return NoHandle ] -- , exactdir "/exactdirAndmsgToSp/anotherResponse"- [ msgToSp "Another response generated using exactdir and msgToSp"] + , exactdir "/nohandle1" mempty + , exactdir "/exactdir/anotherResponse"+ (return . toResponse $ "Another response generated using exactdir") + -- Here we're making use of the MonadIO instance for ServerPartT to arbitrarily+ -- lift a computation into IO. While it's entirely redundant and silly in this example... , (exactdir "/ioaction"- [ ioMsgToSp (return $ HtmlString "This is an IO value.\+ ( liftIO . return . toResponse $ HtmlString "This is an IO value.\ \It could just as easily be the result of a file read operation,\- \or a database lookup." :: IO HtmlString) ] )-+ \or a database lookup.") )+ -- ...the ability to serve a file is a very good way to make use of liftIO , (exactdir "/ioaction2"- [ ioMsgToSp $ do slurp <- readFile "src/Main.hs"- return $ HtmlString $ "Let's try reading the Main.hs file: .....\n" ++ slurp ])-+ (do slurp <- liftIO $ readFile "src/Main.hs"+ return . toResponse . HtmlString $ "Let's try reading the Main.hs file: .....\n" ++ slurp ))+ -- Now when you convert a straight string as a Response it won't actually display properly as+ -- HTML. Now why on Earth could that be? Very simply, its because the content type provided+ -- by the ToMessage instance for String is "text/plain". , (exactdir "/htmlAttemptWrong"- [msgToSp "first try at displaying <font color=\"red\">red formatted</font> html (wrong)"])-+ (return . toResponse $ "first try at displaying <font color=\"red\">red formatted</font> html (wrong)"))+ -- Here we're making use of another convenience bit from happstack-helpers, the HtmlString wrapper.+ -- It allows you to take a string but have its content type be "text/html". , (exactdir "/htmlAttemptRight"- [ ( msgToSp . HtmlString ) "second attempt at displaying <font color=\"red\">red formatted</font> html (right)"])-+ (return . toResponse . HtmlString $ "second attempt at displaying <font color=\"red\">red formatted</font> html (right)"))+ , (exactdir "/htmlAttemptForeignChars"- [ ( msgToSp . HtmlString ) $ - "<html><head></head><body><font color=red>some foreign chars: ä ö ü</font></body></html>"])-- , dir "dirdemo" [ msgToSp "dir match. subpages will work" ]+ (return . toResponse . HtmlString $ + "<html><head></head><body><font color=red>some foreign chars: ä ö ü</font></body></html>")) - ]+ , dir "dirdemo" (return . toResponse $ "dir match. subpages will work")+ -- Redirection of urls in Happstack can be done using the seeOther function.+ -- seeOther can eat any valid representation of a URI, i.e. an instance of+ -- ToSURI, a response to accompany the redirect, and will then + -- perform a redirection to the provided url. In this case clicking the link+ -- will appear to have no effect at all as it will redirect back to the+ -- url handling chapter.+ , dir "redirect" $ seeOther "/tutorial/basic-url-handling" (toResponse "")] -- pretty much useless little server part constructor, for demo purposes-simplematch :: String -> TutHandler-simplematch u = ServerPartT $ \rq -> do+simplematch :: String -> ServerPartT IO Response+simplematch u = do+ rq <- askRq let ru = rqURL rq if ru == ("/simplematch" ++ u) then ( return . toResponse ) ( "matched " ++ u) - else noHandle :: TutWebT ---- don't like these functions, feel they obfuscate. --- I wrote them when I had a less good understanding --- oh well, at least I don't use them in "real" code. (eg, took this out of misc.)-msgToSp :: (Monad m, ToMessage a) => a -> ServerPartT m Response-msgToSp = anyRequest . msgToWeb-msgToWeb :: (Monad m, ToMessage a) => a -> WebT m Response-msgToWeb = return . toResponse-ioMsgToSp = anyRequest . liftIO . ( return . toResponse =<< ) + else mzero myFavoriteAnimal :: ServerPartT IO Response myFavoriteAnimal = - exactdir "/usingtemplates/my-favorite-animal" - [ ServerPartT $ \rq ->- liftIO $ do templates <- directoryGroup "templates"- let fp2 :: String- fp2 = renderTemplateGroup templates [("favoritePlantTwo","Venus Fly Trap")] "favoritePlant"- mineralList :: String- mineralList = renderTemplateGroup templates [("favoriteMinerals",["zinc ","talc"])] "myFavoriteAnimal"- r = renderTemplateGroup templates [("favoriteAnimal", "Tyrannasaurus Rex")- , ("leastFavoriteAnimal","Bambi")+ exactdir "/usingtemplates/my-favorite-animal" $+ liftIO $ do + templates <- directoryGroup "templates"+ let fp2 :: String+ fp2 = renderTemplateGroup templates [("favoritePlantTwo","Venus Fly Trap")] "favoritePlant"+ mineralList :: String+ mineralList = renderTemplateGroup templates [("favoriteMinerals",["zinc ","talc"])] "myFavoriteAnimal"+ r = renderTemplateGroup templates [("favoriteAnimal", "Tyrannasaurus Rex")+ , ("leastFavoriteAnimal","Bambi") -- if you set the same template variable several times it -- gets repeated when it gets displayed -- I think this is reasonable, because it gives you -- feedback that there's probably a bug in your program- , ("favoritePlant","Wheat")- , ("favoritePlant","Ficus")- , ("favoritePlant","Sugarcane")+ , ("favoritePlant","Wheat")+ , ("favoritePlant","Ficus")+ , ("favoritePlant","Sugarcane") -- note that template variable names must be alpha -- favoritePlant2 below would get rejected - , ("fpTwo", fp2)- , ("favoriteMinerals",mineralList)]- $ "myFavoriteAnimalBase" - return . toResponse . HtmlString $ r+ , ("fpTwo", fp2)+ , ("favoriteMinerals",mineralList)] "myFavoriteAnimalBase" + return . toResponse . HtmlString $ r -- if template key is repeated, only the first value appears - ]
src/ControllerGetActions.hs view
@@ -1,14 +1,13 @@ module ControllerGetActions where -import Control.Monad import Control.Monad.Reader-import HAppS.Server-import HAppS.State+import Control.Monad+import Happstack.Server+import Happstack.State import Data.List-import HAppS.Helpers.HtmlOutput+import Happstack.Helpers.HtmlOutput import qualified Data.ByteString.Char8 as B-import Text.StringTemplate.Helpers import ControllerMisc import StateVersions.AppState1 import View@@ -19,33 +18,32 @@ viewConsultants :: RenderGlobals -> ServerPartT IO Response-viewConsultants rglobs = withData $ \(PaginationUrlData currB resPB currP resPP) -> [ ServerPartT $ \rq -> do+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+ =<< return . M.keys . M.filter (consultant . userprofile) . users+ =<< query AskDatastore let p = Pagination { currentbar = currB- , resultsPerBar = resPB- , currentpage = currP- , resultsPerPage = resPP- , baselink = "tutorial/consultants"- , paginationtitle = ""} -- -- 1-column table- consultantCells = map ( (:[]) . userlink ) $ consultants+ , resultsPerBar = resPB+ , currentpage = currP+ , resultsPerPage = resPP+ , baselink = "tutorial/consultants"+ , paginationtitle = ""} + consultantCells = map ( (:[]) . userlink ) consultants consultantTable = paintTable Nothing consultantCells (Just p) -- if not logged in, you get an invite to register as a consultant -- basically an incentive to register- tmplattrs = maybe (def ++ [("registerAsConsultant","list yourself as a HAppS developer")])- (\_ -> def )- (return . sesUser =<< mbSession rglobs)- where def = [("consultantList", consultantTable)]+ tmplattrs = maybe (def ++ [("registerAsConsultant","list yourself as a Happstack developer")])+ (const def)+ (return . sesUser =<< mbSession rglobs)+ where def = [("consultantList", consultantTable)] return . tutlayoutU rglobs tmplattrs $ "consultants"- ] viewConsultantsWanted :: RenderGlobals -> ServerPartT IO Response-viewConsultantsWanted rglobs = withData $ \(PaginationUrlData currB resPB currP resPP) -> [ ServerPartT $ \rq -> do+viewConsultantsWanted rglobs = do+ (PaginationUrlData currB resPB currP resPP) <- getData >>= maybe mzero return consultantswanted <- return . map unusername . M.keys =<< return . M.filter (not . M.null . unjobs . jobs ) . users =<< query AskDatastore@@ -56,20 +54,19 @@ , baselink = "tutorial/consultantswanted" , paginationtitle = ""} - consultantCells = map ( (:[]) . userlink ) $ consultantswanted+ consultantCells = map ( (:[]) . userlink ) consultantswanted consultantTable = paintTable Nothing consultantCells (Just p) -- an incentive to register tmplattrs = maybe (def ++ [("postJob","post a HAppS job")])- (\_ -> def )+ (const def ) (return . sesUser =<< mbSession rglobs) where def = [("ulist", consultantTable)] return . tutlayoutU rglobs tmplattrs $ "consultantswanted"- ] viewJobs :: RenderGlobals -> ServerPartT IO Response-viewJobs rglobs = withData $ \(PaginationUrlData currB resPB currP resPP) -> - [ ServerPartT $ \rq -> do +viewJobs rglobs = do+ (PaginationUrlData currB resPB currP resPP) <- getData >>= maybe mzero return rsListAllJobs <- query ListAllJobs let pag = Pagination { currentbar = currB , resultsPerBar = resPB@@ -78,28 +75,27 @@ , baselink = "tutorial/jobs" , paginationtitle = "Job Results: "} jobCells = map f rsListAllJobs- where f (JobName j', (Job budget blurb), UserName postedBy) = let j = B.unpack j' in - [ joblink postedBy j+ where f (JobName j', (Job budget _), UserName posted) = let j = B.unpack j' in + [ joblink posted j , B.unpack budget- , userlink postedBy+ , userlink posted ]- paintAllJobsTable rglobs jobCells p = + paintAllJobsTable _ j p = paintTable (Just ["<b>project</b>","<b>budget</b>","<b>posted by</b>"])- jobCells+ j (Just p) jobTable = paintAllJobsTable rglobs jobCells pag -- if not logged in, you get invited to post a job, -- basically an incentive to register -- this next line should be coming from a template, and it's duplicated elsewhere, slightly bad.- tmplattrs = maybe (def++[("postJob","post a HAppS job")]) (\_ -> def) (return . sesUser =<< mbSession rglobs)+ tmplattrs = maybe (def++[("postJob","post a HAppS 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 = ServerPartT $ \rq -> do +viewEditConsultantProfile :: RenderGlobals -> ServerPartT IO Response+viewEditConsultantProfile rglobs = case (return . sesUser =<< mbSession rglobs) of Nothing -> return . tutlayoutU rglobs [("errormsg", "error: no user")] $ "errortemplate" Just currU -> do @@ -109,7 +105,6 @@ Just uis -> do let cp = userprofile uis - uimage <- liftIO $ avatarimage currU -- use show below to properly escape quotes let showPr = paintProfile rglobs (B.unpack . unusername $ currU) cp uimage@@ -124,10 +119,10 @@ return $ tutlayoutU rglobs attrs "editconsultantprofile" viewEditJob :: UserName -> JobName -> RenderGlobals -> ServerPartT IO Response-viewEditJob pBy jN rglobs = ServerPartT $ \_ -> do +viewEditJob pBy jN rglobs = case ( return . sesUser =<< mbSession rglobs )of Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"- Just currU -> do+ Just currU -> if currU /= pBy then return $ tutlayoutU rglobs [("errormsg", "error: " ++ (B.unpack . unjobname $ jN) ++ " not posted by " ++ (B.unpack . unusername $ currU) )]@@ -136,7 +131,7 @@ mbJ <- lookupJob pBy jN case mbJ of Nothing -> return $ tutlayoutU rglobs- [ ( "errormsg", "error, bad job: " ++ (show $ (pBy,jN) ) ) ] "errortemplate"+ [ ( "errormsg", "error, bad job: " ++ (show (pBy,jN) ) ) ] "errortemplate" Just j -> do let attrs = [ ("jobname", quote . B.unpack . unjobname $ jN) , ("budget", quote . B.unpack . jobbudget $ j) , ("jobblurb", quote . B.unpack . jobblurb $ j)@@ -144,23 +139,24 @@ ] return $ tutlayoutU rglobs attrs "editjob" +lookupJob :: (MonadIO m) => UserName -> JobName -> m (Maybe Job) lookupJob pBy jN = do mbUis <- ( query . GetUserInfos ) pBy case mbUis of Nothing -> return Nothing- Just uis -> return $ M.lookup jN $ (unjobs . jobs $ uis)+ Just uis -> return $ M.lookup jN (unjobs . jobs $ uis) pageMyJobPosts :: RenderGlobals -> ServerPartT IO Response-pageMyJobPosts rglobs = ServerPartT $ \rq -> do +pageMyJobPosts rglobs = do mbUis <- getGlobsUserInfos rglobs -- (query . GetUserInfos) =<< ( return . mbUser $ rglobs ) case (mbUis :: Either String (UserName,UserInfos)) of Left err -> return . tutlayoutU rglobs [("errormsg", err)] $ "errortemplate" Right (currU,uis) -> do- let jobPostsTable = paintUserJobsTable rglobs (unusername $ currU) (M.toList . unjobs . jobs $ uis) 1 20+ let jobPostsTable = paintUserJobsTable (unusername currU) (M.toList . unjobs . jobs $ uis) return $ tutlayoutU rglobs [("jobPostsTable",jobPostsTable)] "myjobposts" -getGlobsUserInfos :: Monad m => RenderGlobals -> WebT IO (m ( UserName,UserInfos) )-getGlobsUserInfos rglobs = do+getGlobsUserInfos :: Monad m => RenderGlobals -> ServerPartT IO (m ( UserName,UserInfos) )+getGlobsUserInfos rglobs = case (return . sesUser =<< mbSession rglobs) of Nothing -> fail "getUserInfos, no user in globals" Just un -> do@@ -169,46 +165,44 @@ Nothing -> return $ fail "getUserInfos, no user infos" Just uis -> return $ return (un,uis) -viewJob rglobs =- withData $ \(JobLookup pBy jN) ->- [ ServerPartT $ \rq -> do- mbJ <- lookupJob pBy jN - case mbJ of- Nothing -> return $ tutlayoutU rglobs [("errmsg", "no job found")] "errortemplate"- Just j -> return $ tutlayoutU rglobs [("job",paintjob rglobs pBy (jN,j) )] "viewjob"- - ]+viewJob :: (MonadIO m) => RenderGlobals -> ServerPartT m Response+viewJob rglobs = do+ JobLookup pBy jN <- getData >>= maybe mzero return+ mbJ <- lookupJob pBy jN + case mbJ of+ Nothing -> return $ tutlayoutU rglobs [("errmsg", "no job found")] "errortemplate"+ Just j -> return $ tutlayoutU rglobs [("job",paintjob rglobs pBy (jN,j) )] "viewjob" -userProfile rglobs = - withData $ \(UserNameUrlString user) ->- [ ServerPartT $ \rq -> do+userProfile :: (MonadIO m) => RenderGlobals -> ServerPartT m Response+userProfile rglobs = do+ UserNameUrlString user <- getData >>= maybe mzero return - mbCP <- do mbUis <- query (GetUserInfos user) - return $ do uis <- mbUis- return . userprofile $ uis+ mbCP <- do mbUis <- query (GetUserInfos user) + return $ mbUis >>= (return . userprofile) - case mbCP of- Nothing -> return $ tutlayoutU rglobs [("errormsgProfile", "bad user: " ++ (B.unpack . unusername $ user) )] "viewconsultantprofile"- Just cp -> do- userimg <- liftIO $ avatarimage user- return $ tutlayoutU rglobs [("cp", paintProfile rglobs (B.unpack . unusername $ user) cp userimg)] + case mbCP of+ Nothing -> return $ tutlayoutU rglobs [("errormsgProfile", "bad user: " ++ (B.unpack . unusername $ user) )] "viewconsultantprofile"+ Just cp -> do+ userimg <- liftIO $ avatarimage user+ return $ tutlayoutU rglobs [("cp", paintProfile rglobs (B.unpack . unusername $ user) cp userimg)] "viewconsultantprofile"- ] --- viewEditJob :: RenderGlobals -> ServerPartT IO Response -viewEditJobWD rglobs = withData $ \(JobLookup pBy jN) -> [viewEditJob pBy jN rglobs]-deleteJobWD rglobs = withData $ \(JobLookup pBy jN) -> [deleteJob pBy jN rglobs]+viewEditJobWD :: RenderGlobals -> ServerPartT IO Response+viewEditJobWD rglobs = withData $ \(JobLookup pBy jN) -> viewEditJob pBy jN rglobs +deleteJobWD :: RenderGlobals -> ServerPartT IO Response+deleteJobWD rglobs = withData $ \(JobLookup pBy jN) -> deleteJob pBy jN rglobs+ -- there's a lot of repeated code for viewEdit and Delete of jobs. -- maybe can consolidate-deleteJob pBy jN rglobs = ServerPartT $ \rq -> do +deleteJob :: UserName -> JobName -> RenderGlobals -> ServerPartT IO Response+deleteJob pBy jN rglobs = case (return . sesUser =<< mbSession rglobs) of Nothing -> return $ tutlayoutU rglobs [("errormsg", "error: no user")] "errortemplate"- Just currU -> do+ Just currU -> if currU /= pBy then return $ tutlayoutU rglobs [("errormsg", "error: " ++ (B.unpack . unjobname $ jN) ++ " not posted by " ++ (B.unpack . unusername $ currU) )] "errortemplate" else do update $ DelJob currU jN- unServerPartT (pageMyJobPosts rglobs ) rq-+ pageMyJobPosts rglobs
src/ControllerMisc.hs view
@@ -1,25 +1,26 @@ module ControllerMisc where -import HAppS.Server+import Happstack.Server -import Misc + import View import StateVersions.AppState1-import Text.StringTemplate+ import System.Directory (doesFileExist) -import HAppS.State-import Control.Monad+import Happstack.State import Control.Monad.Reader import Control.Monad.Error-import HAppS.Helpers+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+tutlayoutU :: RenderGlobals -> [(String,String)] -> String -> Response tutlayoutU rglobs attrs tmpl = ( toResponse . HtmlString . tutlayout rglobs attrs ) tmpl getmbSession :: Request -> IO (Maybe SessionData)@@ -28,7 +29,7 @@ -- 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 -> WebT m Response+startsess' :: (MonadIO m) => RenderGlobals -> UserName -> String -> ServerPartT m Response startsess' ( RenderGlobals origRq ts _ ) user landingpage = do let sd = SessionData user key <- update $ NewSession sd@@ -36,9 +37,9 @@ return $ RenderGlobals origRq ts (Just sd) --let lp = getLandingpage origRq --return () - redirectToUrl landingpage + withRequest (const $ redirectToUrl landingpage) -getLoggedInUserInfos :: RenderGlobals -> ErrorT String (WebT IO) (UserName,UserInfos)+getLoggedInUserInfos :: RenderGlobals -> ErrorT String (ServerPartT IO) (UserName,UserInfos) getLoggedInUserInfos (RenderGlobals _ _ Nothing) = fail "getLoggedInUserInfos, not logged in" getLoggedInUserInfos (RenderGlobals _ _ (Just (SessionData uN))) = do loggedInUserInfos <- ErrorT . return .@@ -50,16 +51,15 @@ getMbSessKey :: Request -> Maybe SessionKey getMbSessKey rq = runReaderT (readCookieValue "sid") (rqInputs rq,rqCookies rq) -updateuser olduser newuser = do+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 mbU) =+logoutPage rglobs@(RenderGlobals origRq ts _) = withRequest $ \rq -> do newRGlobs <- maybe@@ -70,15 +70,17 @@ (getMbSessKey rq) ( return . tutlayoutU newRGlobs [] ) "home" +avatarimage :: UserName -> IO String avatarimage un = do uap <- urlavatarpath un return $ simpleImage (uap,(B.unpack . unusername $ un) ++ " image") ("100","100") where - urlavatarpath un = do- let p = writeavatarpath $ un+ urlavatarpath n = do+ let p = writeavatarpath n e <- doesFileExist p if e then return $ "/" ++ p- else return $ "/static/defaultprofileimage.png"+ else return "/static/defaultprofileimage.png" +writeavatarpath :: UserName -> String writeavatarpath un = "userdata/" ++ ( B.unpack . unusername $ un) ++ "/" ++ "profileimage"
src/ControllerPostActions.hs view
@@ -1,19 +1,14 @@ {-# LANGUAGE ScopedTypeVariables #-} module ControllerPostActions where -import Text.ParserCombinators.Parsec--import Control.Monad-import Control.Monad.Trans import Data.List (isInfixOf) import qualified Data.ByteString.Char8 as B import Control.Monad.Error -import System.FilePath (takeFileName)-import HAppS.Server-import HAppS.State-import HAppS.Helpers+import Happstack.Server+import Happstack.State+import Happstack.Helpers import StateVersions.AppState1 import View@@ -24,7 +19,7 @@ loginPage :: RenderGlobals -> ServerPartT IO Response-loginPage rglobs@(RenderGlobals rq _ _) = do +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@@ -33,10 +28,6 @@ authUser = authUser' getUserPassword getUserPassword name = return . maybe Nothing (Just . B.unpack . password) =<< query (GetUserInfos name) - --- -- move this to HAppSHelpers tutAppReferrer :: Request -> Either String String tutAppReferrer rq = do@@ -44,7 +35,7 @@ approot = modRewriteAppUrl "" rq case approot of Left _ -> Left $ "tutAppReferrer, could not determine approot, rq: " ++ (show rq)- Right ar -> do + Right ar -> case getHeaderVal "referer" rq of Left e -> Left $ "smartAppReferrer error, rq: " ++ e -- check against logout, otherwise if you have just logged out then @@ -56,25 +47,23 @@ -- Use a helper function because the plan is to eventually have a similar function -- that works for admin logins loginPage' :: (Monad m) =>- (UserName -> B.ByteString -> WebT m Bool)- -> (RenderGlobals -> UserName -> String -> WebT m Response)+ (UserName -> B.ByteString -> ServerPartT m Bool)+ -> (RenderGlobals -> UserName -> String -> ServerPartT m Response) -> RenderGlobals -> String -> ServerPartT m Response loginPage' auth startsession rglobs landingpage =- withData $ \(UserAuthInfo user pass) -> - [ ServerPartT $ \rq -> do+ 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 -}- ] -- check if a username and password is valid. If it is, return the user as successful monadic value -- otherwise fail monadically-authUser' :: (UserName -> WebT IO (Maybe String) ) -> UserName -> B.ByteString -> WebT IO Bool+authUser' :: (UserName -> ServerPartT IO (Maybe String) ) -> UserName -> B.ByteString -> ServerPartT IO Bool authUser' getpwd name pass = do mbP <- getpwd name -- scramblepass works with lazy bytestrings, maybe that's by design. meh, leave it for now@@ -83,30 +72,29 @@ changePasswordSP :: RenderGlobals -> ServerPartT IO Response-changePasswordSP rglobs = withData $ \(ChangePasswordInfo newpass1 newpass2) -> [ ServerPartT $ \rq -> do+changePasswordSP rglobs = withData $ \(ChangePasswordInfo newpass1 newpass2) -> if newpass1 /= newpass2 - then errW "new passwords don't match"+ then return $ errw "new passwords don't match" else do etRes <- runErrorT $ getLoggedInUserInfos rglobs case etRes of- Left e -> errW e+ 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 = return $ tutlayoutU rglobs [("errormsgAccountSettings", msg)] "changepassword"-+ where errw msg = tutlayoutU rglobs [("errormsgAccountSettings", msg)] "changepassword" +processformEditConsultantProfile :: RenderGlobals -> ServerPartT IO Response processformEditConsultantProfile rglobs =- withData $ \fd@(EditUserProfileFormData fdContact fdBlurb fdlistAsC fdimagecontents) -> [ ServerPartT $ \rq -> do+ 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 pContact pBlurb listasC pAvatar) -> do+ Just (UserProfile _ _ _ pAvatar) -> do up <- if B.null (fdimagecontents) then return $ UserProfile fdContact fdBlurb fdlistAsC pAvatar else do@@ -116,31 +104,31 @@ liftIO $ writeFileForce avatarpath fdimagecontents return $ UserProfile fdContact fdBlurb fdlistAsC (B.pack avatarpath) update $ SetUserProfile unB up- unServerPartT ( viewEditConsultantProfile rglobs) rq- ]+ viewEditConsultantProfile rglobs processformEditJob :: RenderGlobals -> ServerPartT IO Response-processformEditJob rglobs@(RenderGlobals rq ts mbSess) =- withData $ \(EditJob jn jbud jblu) -> [ ServerPartT $ \rq -> do+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 -> 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))- unServerPartT ( viewEditJob uname jn rglobs) rq - ]+ viewEditJob uname jn rglobs +errW :: (Monad m) => RenderGlobals -> String -> m Response errW rglobs msg = ( return . tutlayoutU rglobs [("errormsg", msg)] ) "errortemplate" - -processformNewJob rglobs@(RenderGlobals rq ts mbSess) =- withData $ \(NewJobFormData jn newjob) -> [ ServerPartT $ \rq -> do++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 -> do+ Just user -> if null (B.unpack . unjobname $ jn) then errW rglobs "error, blank job name" else do @@ -148,51 +136,40 @@ case res of Left err -> case isInfixOf "duplicate key" (lc err) of True -> errW rglobs "duplicate job name"- otherwise -> errW rglobs "error inserting job"- Right () -> unServerPartT ( pageMyJobPosts rglobs ) rq - ]+ _ -> errW rglobs "error inserting job"+ Right () -> pageMyJobPosts rglobs newUserPage :: RenderGlobals -> ServerPartT IO Response newUserPage rglobs =- withData $ \(NewUserInfo user (pass1 :: B.ByteString) pass2) ->- [ ServerPartT $ \rq -> do- etRes <- runErrorT $ do+ 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 () -> do case modRewriteAppUrl "tutorial/registered" rq of- Left e -> errW rglobs e- Right p -> startsess' rglobs user p+ Right () -> case modRewriteAppUrl "tutorial/registered" rq of+ Left e -> errW rglobs e+ Right p -> startsess' rglobs user p - ] where- setupNewUser :: NewUserInfo -> ErrorT [Char] (WebT IO) ()+ setupNewUser :: NewUserInfo -> ErrorT [Char] (ServerPartT IO) () setupNewUser (NewUserInfo user (pass1 :: B.ByteString) pass2) = do- if B.null pass1 || B.null pass2- then throwError "blank password"- else return ()- if pass1 /= pass2- -- TITS: can return . Left be replaced with throwError?+ 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.- then throwError "passwords don't match"- else return () nameTakenHAppSState <- query $ IsUser user- if nameTakenHAppSState- then throwError "name taken"- else return ()+ when nameTakenHAppSState (throwError "name taken") addUserVerifiedPass user pass1 pass2 -addUserVerifiedPass :: UserName -> B.ByteString -> B.ByteString -> ErrorT String (WebT IO) ()-addUserVerifiedPass user pass1 pass2 = do+addUserVerifiedPass :: UserName -> B.ByteString -> B.ByteString -> ErrorT String (ServerPartT IO) ()+addUserVerifiedPass user pass1 pass2 = ErrorT $ newuser user pass1 pass2 where- newuser :: UserName -> B.ByteString -> B.ByteString -> WebT IO (Either String ())- newuser u@(UserName us) pass1 pass2 -- userExists- | pass1 /= pass2 = return . Left $ "passwords did not match"- | otherwise = update $ AddUser u $ B.pack $ scramblepass (B.unpack pass1)---+ newuser :: UserName -> B.ByteString -> B.ByteString -> ServerPartT IO (Either String ())+ newuser u@(UserName _) p1 p2 -- userExists+ | p1 /= p2 = return . Left $ "passwords did not match"+ | otherwise = update $ AddUser u $ B.pack $ scramblepass (B.unpack p1)
src/ControllerStressTests.hs view
@@ -1,8 +1,8 @@ {-# LANGUAGE NoMonomorphismRestriction #-} module ControllerStressTests where -import HAppS.Server-import HAppS.State+import Happstack.Server+import Happstack.State import Data.List import Misc import qualified MiscMap as M @@ -20,6 +20,8 @@ -- insert a lot of data unrealistically -- the datastore set gets set in one huge macid transaction++spAddDummyData :: (MonadIO m) => RenderGlobals -> ServerPartT m Response spAddDummyData rglobs = withRequest $ \_ -> do us <- query AskDatastore@@ -37,8 +39,10 @@ -- 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- startTime <- liftIO $ getClockTime+ startTime <- liftIO getClockTime (userRange,us) <- getUsers 10 n f us stressTestTime <- liftIO $ return . timeDiffToString =<< timeSince startTime@@ -50,7 +54,7 @@ "stresstestcompleted" ---getUsers :: (MonadIO m) => Int -> m ([Int], Users)+getUsers :: (MonadIO m) => Int -> Int -> m ([Int], Users) getUsers jobsPerU n = do us <- return . M.toList . users =<< query AskDatastore -- something around here seems kinda slow@@ -58,16 +62,14 @@ [] -> 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-getDummyNumber s = do- let i = parse parseDummyNumber "parseDummyNumber" s- case i of- Left err -> Nothing- Right i -> Just i-+getDummyNumber s =+ case parse parseDummyNumber "parseDummyNumber" s of+ Left _ -> Nothing+ Right i' -> Just i' parseDummyNumber :: Parser Int@@ -83,41 +85,46 @@ insertus :: (MonadIO m) => Users -> m () insertus us = update . ( AddDummyData . users ) $ us ---insertuAllJobs :: (MonadIO m) => (UserName, UserInfos) -> Users -> m ()+insertusAllJobs :: (MonadIO m) => Users -> m () insertusAllJobs = mapM_ insertuAllJobs . M.toList . users ++insertuAllJobs :: (MonadIO m) => (UserName, UserInfos) -> m () insertuAllJobs (u, uis) = do- update $ ( (AddDummyUser (u,uis)) ) + update (AddDummyUser (u,uis)) liftIO $ putStrLn $ "insertuAllJobs, added user: " ++ ( B.unpack . unusername $ u) -- insert a user realistically -- follow the same macid steps that would occur when data is added by a human+atomic_inserts :: (MonadIO m) => Users -> m () atomic_inserts = mapM_ insertu . M.toList . users+ insertu :: (MonadIO m) => (UserName, UserInfos) -> m () insertu (u, UserInfos pass pr (Jobs js) ) = do update $ AddUser u (B.pack . scramblepass . B.unpack $ pass) update $ SetUserProfile u pr- sequence_ $ map (\(jn,j) -> update $ AddJob u jn j) ( M.toList js )+ mapM_ (\(jn,j) -> update $ AddJob u jn j) ( M.toList js ) liftIO $ putStrLn $ "insertu, added user: " ++ ( B.unpack . unusername $ u)- where addj u j = do- -- liftIO $ putStrLn $ show ("adding job",username u,jobname j)- addJob u j-+ --------------dummy data -- create arbitrarily large numbers of users to attempt insertion --stresstestdata :: (Integral a) => [a] -> Users-stresstestdata jobsperU users = Users $ M.fromList $ map (stresstestUser jobsperU) users++stresstestdata :: (Integral a) => a -> [a] -> Users+stresstestdata jobsperU us = Users $ M.fromList $ map (stresstestUser jobsperU) us++stresstestUser :: (Integral a) => a -> a -> (UserName, UserInfos) stresstestUser jobsperU i = ( UserName . B.pack $ ("user"++(show i)) , UserInfos ( B.pack $ "password" ++ (show i)) (stresstestprofile i) (Jobs $ M.fromList $ map (stresstestjob i) [1..jobsperU]) )- where stresstestprofile i = UserProfile { contact = B.pack $ "someone" ++ (show i) ++ "@somewhere.com"- , blurb = B.pack $ "la la la"- , consultant = if even i then True else False+ 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 i j = ( JobName . B.pack $ "make something " ++ (show (i,j)) ,- Job { jobbudget = B.pack . show $ (i,j)- , jobblurb = B.pack . ("blurb " ++) . show $ (i,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) } ) -- dummy data appropriate for a job site demo and testing@@ -130,11 +137,12 @@ (UserProfile ( B.pack "") ( B.pack "") False ( B.pack "")) serpinskiJobs ) ] +tphyahooProfile :: UserProfile tphyahooProfile = UserProfile { --billing_rate = "it depends on the project"- contact = B.pack $ "thomashartman1 at gmail, +48 51 365 3957"+ 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 \+ , blurb = B.pack "I'm currently living in poland, doing a software sabbatical where I'm \ \learning new things and writing and releasing open source software, including this tutorial." , consultant = True , avatar = B.pack ""@@ -144,8 +152,9 @@ -- can't use dummy data with foreign chars -- app seems to accept them when entered through form though. -- , ("Umläute in Happs benutzen können", "umsonst?")+tphyahooJobs :: Jobs tphyahooJobs =- Jobs $ M.fromList $ map (\(j,b)-> ( JobName . B.pack $ j, Job { jobbudget = B.pack b, jobblurb = B.pack $ "make " ++ j ++ " using HAppS "} ) ) $+ Jobs $ M.fromList $ map (\(j,b)-> ( JobName . B.pack $ j, Job { jobbudget = B.pack b, jobblurb = B.pack $ "make " ++ j ++ " using HAppS "} ) ) [ ("darcshub", "$5000") , ("community wizard", "$500,000") , ("hpaste in happs", "karma points?")@@ -157,5 +166,7 @@ , ("oscommerce clone", "$1500") , ("phpbb clone", "") , ("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]
+ src/FirstMacid.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,+ MultiParamTypeClasses, TypeFamilies, FlexibleContexts #-}++module Main where++import Happstack.State+import Data.Typeable+import Control.Monad.State+import Control.Monad.Reader+import Control.Concurrent (MVar)++-- First we define our basic datatype. In this case, it is simply+-- a wrapper around an Int.+data ExampleState = ExampleState Int+ deriving (Typeable, Show)++{- Here we accept the default for Version, which corresponds to a version number of 0+ and no previous versions of the state defined.+ You might be saying "Hold on, there, what's all that about?".+ I'm going to say "Oh look, a Unicorn!" and hope you remain distracted until the+ chapter on versions & migrations. -}++instance Version ExampleState++-- This is a bit of lovely Template Haskell hackery that you really+-- shouldn't think too hard about. Suffice to say, you need to call this.+$(deriveSerialize ''ExampleState)++{- Now we're getting into the real meat of our application!+ The Update and Query methods that we can use to actually+ manipulate the persistent state. ++ The two important points are that Update st is a + MonadState st and that Query st is a MonadReader st.+ + If you have any familiarity with the mtl library, you can+ apply all your normal intuition about Reader & State monads+ to writing updates and queries.+-}++-- A very simple Update that just increments the state+succVal :: Update ExampleState ()+succVal = modify (\(ExampleState n) -> ExampleState (n+1))++-- A simple Query that just returns the bare Int contained in the state+getVal :: Query ExampleState Int+getVal = do+ ExampleState n <- ask+ return n++-- An Update that actually takes an argument. That may not seem odd+-- at the moment, but we'll talk more about it in a second.+incVal :: Int -> Update ExampleState ()+incVal i = modify (\(ExampleState n) -> ExampleState (n+i))++{- 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+ defined up above. Try compiling this with the -ddump-splices option+ in order to actually take a look at what gets created by mkMethods.+ + The data types will have the same name as your functions except+ with a capitalized first letter.++ The parameters to your Update or Query become the parameters to the+ constructor of your data type. So in this case incVal becomes+ IncVal Int.+-}++$(mkMethods ''ExampleState ['succVal, 'getVal, 'incVal])++-- 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+-- to build up a type level list using the constructor :+: and the+-- empty dependency End. Another example is going to cover the use of sub components +-- and when you'd want a non-trivial Dependencies type.+instance Component ExampleState where+ type Dependencies ExampleState = End+ initialValue = ExampleState 0++{-+ The way you actually start running a Happstack.State+ application is to call startSystemState and pass it+ a Proxy. As you can see below in the definition of+ rootState, the Proxy type carries no actual data,+ it is simply a carrier of the type of your state.+ + startSystemState is the function you'll most often use+ for Happstack.State clients. It uses the default+ behavior of serializing data to files under _local.+ While this isn't the only option for serialization of+ state, it is the only one we will consider in this+ tutorial.+-}+rootState :: Proxy ExampleState+rootState = Proxy++main :: IO ()+main = do+ ctl <- startSystemState rootState+ commandLoop ctl++commandLoop :: MVar TxControl -> IO ()+commandLoop ctl = do+ putStrLn "Enter 'i' to increment the state by a number of your choosing."+ 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 'q' to quit."+ val <- liftM head getLine+ handler ctl val++{-+ At last, our handler function is quite simple and bare bones.+ If you experiment with it at the command line you should able+ to watch it work. There isn't much in the way of a UI here,+ but it's enough that you can get the flavor of how one uses+ Happstack.State in the main application logic.++ The two functions I'd like to discuss are query and update.+ They operate fairly similarly to each other.++ update :: (MonadIO m, UpdateEvent ev res) => ev -> m res+ query :: (MonadIO m, QueryEvent ev res) => ev -> m res++ You, basically, pass data corresponding to Query functions+ to query and Updates to update. That's really what the+ type context about UpdateEvent and QueryEvent comes down+ to. The really nice thing is that they work for any+ MonadIO. In the example below, we just use IO itself, but+ since ServerPartT has a MonadIO instance we can very+ seamlessly use update & query in our Happstack web apps.++ Now, we're explicitly threading through the MVar TxControl+ returned by our call to startSystemState into the handler.+ It'd probably be cuter to just use a ReaderT (MVar TxControl) IO+ but I want to keep this code extremely straight forward.+ The only place where we actually need this TxControl is when+ calling the createCheckpoint function.++ createCheckpoint does exactly what it sounds like. It+ serializes a checkpoint of the application state. + You might be wondering what a checkpoint does if the state+ is already persistent. Normally Happstack.State serializes+ the event log, which is played back whenever the application+ is restarted. When you create a checkpoint, you are + serializing out a state you can use as a starting point+ for your application when it is restarted. You might+ want to try the following outline to build your intuition+ for checkpoints.++ 1. Increment the state a few times+ 2. Create a checkpoint+ 3. Increment the state again+ 4. Close down the app and examine the+ _local directory. You should see+ the files corresponding to the checkpoint+ and the events recorded after it+ 5. Restart the app. It should be right where+ you left it. Close it again.+ 6. Delete the events files+ 7. Restart the app. The state should correspond+ to the checkpoint you took.+ 8. ???+ 9. Profit!+-}++handler :: MVar TxControl -> Char -> IO ()+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+ v <- readLn+ update $ IncVal v+ commandLoop c+handler c 'c' = createCheckpoint c >> commandLoop c+handler c _ = commandLoop c
src/FromDataInstances.hs view
@@ -1,13 +1,12 @@ module FromDataInstances where -import HAppS.Server+import Happstack.Server import StateVersions.AppState1-import Control.Monad import Control.Monad.Reader-import Safe+-- import Safe import qualified Data.ByteString.Char8 as B import Misc-import HAppS.Helpers+import Happstack.Helpers -- This could be a lot less verbose, and use shorter variable names, -- but it's the tutorial instructional example for using FromData to deal with forms, so no harm.@@ -77,11 +76,15 @@ data NewJobFormData = NewJobFormData JobName Job instance FromData NewJobFormData where fromData = liftM2 NewJobFormData lookjobname lookjob++lookjobname :: ReaderT ([(String,Input)], [(String,Cookie)]) Maybe JobName lookjobname = do jn <- (look "jobtitle" `mplus` return "") return . JobName . B.pack $ jn++lookjob :: ReaderT ([(String,Input)], [(String,Cookie)]) Maybe Job lookjob = do bud <- return . B.pack =<< (look "jobbudget" `mplus` return "")- blurb <- return . B.pack =<< (look "jobdescription" `mplus` return "")- return $ Job bud blurb+ jobBlurb <- return . B.pack =<< (look "jobdescription" `mplus` return "")+ return $ Job bud jobBlurb data NewUserInfo = NewUserInfo UserName B.ByteString B.ByteString instance FromData NewUserInfo where
src/Main.hs view
@@ -2,31 +2,29 @@ -- http://softwaresimply.blogspot.com/2008_02_01_archive.html module Main where-import HAppS.Server-import HAppS.State+import Happstack.Server hiding (port)+import Happstack.State import Controller-import Misc import System.Environment-import Control.Concurrent import StateVersions.AppState1-import System.Time-import HAppS.Server.Helpers-import Text.StringTemplate.Helpers +import Happstack.Server.Helpers +main :: IO () main = do args <- getArgs case args of [port, dynamicTemplateReload', allowStressTests'] -> do- p <- safeRead port- allowStressTests <- safeRead allowStressTests'- dynamicTemplateReload <- safeRead dynamicTemplateReload'+ let p = read port+ allowStressTests = read allowStressTests'+ dynamicTemplateReload = read dynamicTemplateReload' tDirGroups <- getTemplateGroups smartserver (Conf p Nothing) "happs-tutorial"- (controller tDirGroups dynamicTemplateReload allowStressTests)- stateProxy- otherwise -> putStrLn "usage example: happs-tutorial 5001 True True (starts the app on port 5001, \+ (controller tDirGroups dynamicTemplateReload allowStressTests)+ stateProxy+ _ -> putStrLn "usage example: happs-tutorial 5001 True True (starts the app on port 5001, \ \templates reload dynamically on every request, allows stress tests)" +runInGhci :: IO () runInGhci = do putStrLn $ "happs tutorial running in ghci. \n" ++ "exit :q ghci completely and reenter ghci, before restarting."@@ -35,6 +33,3 @@ stateProxy :: Proxy AppState stateProxy = Proxy---
src/Misc.hs view
@@ -1,48 +1,36 @@ module Misc where -import HAppS.Server +import Happstack.Server import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Lazy.Char8 as L-import Control.Monad.Trans+import Control.Monad import Data.List-import qualified Data.Set as S import Data.Digest.Pure.MD5-import Debug.Trace import Text.PrettyPrint as PP import System.FilePath (pathSeparator, takeDirectory) import System.Directory (createDirectoryIfMissing) import Safe (readMay) import System.Time import Data.Char (isAlphaNum)-import Data.Monoid import Data.Char (toLower) -newtype HtmlString = HtmlString String-instance ToMessage HtmlString where- toContentType _ = B.pack "text/html"- toMessage (HtmlString s) = L.pack s --exactdir staticPath = spsIf (\rq -> rqURL rq == staticPath) --spsIf :: (Monad m) => (Request -> Bool) -> [ServerPartT m a] -> ServerPartT m a-spsIf p sps = withRequest $ \rq ->- if p rq- then unServerPartT (mconcat sps) rq- else mempty--pp[] = ( PP.render . vcat . map text . map show )+pp :: (Show a) => [t] -> [a] -> String+pp [] = PP.render . vcat . map (text . show)+pp _ = undefined -pathPartsSp pps f = ServerPartT $ \rq ->+pathPartsSp pps f = do+ rq <- askRq if rqPaths rq == pps then f rq - else noHandle+ else mzero -- Do something when the request has exactly one path segment left. -- lastPathPartSp :: (Request -> String -> WebT IO Response) -> ServerPartT IO Response-lastPathPartSp0 f = ServerPartT $ \rq ->+lastPathPartSp0 f = do+ rq <- askRq case rqPaths rq of [lastpart] -> f rq lastpart- _ -> noHandle+ _ -> mzero {- ifFirstPathPartSp pathpart f = ServerPartT $ \rq ->@@ -65,10 +53,6 @@ quote x = '\"' : x ++ "\"" ---- -- Windows/Unix/Mac compatible pathstring pathparts =
src/MiscMap.hs view
@@ -37,25 +37,30 @@ insertUqM k v m = case lookup k m of Nothing -> return $ insert k v m- Just x -> fail $ "insertUqM, duplicate key: " ++ (show k)+ Just _ -> fail $ "insertUqM, duplicate key: " ++ (show k) deleteM :: (Show k, Monad m, Ord a, Ord k) => k -> Map k a -> m (Map k a) deleteM k m = case lookup k m of Nothing -> fail $ "deleteM, key not found: " ++ (show k)- Just x -> return $ delete k m+ 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) adjustM k f m = case lookup k m of Nothing -> fail $ "updateM, key not found: " ++ (show k)- Just x -> return . adjust f k $ m+ Just _ -> return . adjust f k $ m -- similar to adjustM, except modification function can fail monadically -- adjustMM :: (Ord k, Monad m, Show k) => k -> (k -> Map k a -> Either String (Map k a) ) -> Map k a -> m (Map k a)++adjustMM ::(Ord k, Monad m, Show k) => k -> + (a -> Either [Char] 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
@@ -0,0 +1,60 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,+ MultiParamTypeClasses, TypeFamilies,+ FlexibleContexts #-}++module Main where++{- This code is almost identical to the previous MACID examples.+ There's one, and only, major difference between them:+ the replacement of startSystemState with startSystemStateMultimaster.+-}++import Happstack.State++import Data.Typeable+import Control.Monad.State+import Control.Monad.Reader+import Control.Concurrent (MVar)++data ExampleState = ExampleState Int deriving (Typeable)++instance Version ExampleState+$(deriveSerialize ''ExampleState)++succVal :: Update ExampleState ()+succVal = modify (\(ExampleState n) -> ExampleState (succ n))++getVal :: Query ExampleState Int+getVal = do+ ExampleState n <- ask+ return n++$(mkMethods ''ExampleState ['succVal, 'getVal])++instance Component ExampleState where+ type Dependencies ExampleState = End+ initialValue = ExampleState 0++rootState :: Proxy ExampleState+rootState = Proxy++main:: IO ()+main = do+ c <- startSystemStateMultimaster rootState+ commandLoop c++commandLoop :: MVar TxControl -> IO ()+commandLoop c = do+ putStrLn "Enter 'v' to view the state."+ putStrLn "Enter 's' to increment the state by 1."+ putStrLn "Enter 'c' to create a checkpoint."+ putStrLn "Enter 'q' to quit."+ val <- liftM head getLine+ handler c val++handler :: MVar TxControl -> Char -> IO ()+handler _ 'q' = return ()+handler c 'v' = query GetVal >>= print >> commandLoop c+handler c 's' = update SuccVal >> commandLoop c+handler c 'c' = createCheckpoint c >> commandLoop c+handler c _ = commandLoop c
+ src/MultiExample2.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,+ MultiParamTypeClasses, TypeFamilies,+ FlexibleContexts #-}++module Main where++import Happstack.State++import Data.Typeable+import Control.Monad.State+import Control.Monad.Reader+import Control.Concurrent (MVar)++data ExampleState = ExampleState Int deriving (Typeable)++instance Version ExampleState+$(deriveSerialize ''ExampleState)++succVal :: Update ExampleState ()+succVal = modify (\(ExampleState n) -> ExampleState (succ n))++getVal :: Query ExampleState Int+getVal = do+ ExampleState n <- ask+ return n++$(mkMethods ''ExampleState ['succVal, 'getVal])++instance Component ExampleState where+ type Dependencies ExampleState = End+ initialValue = ExampleState 0++rootState :: Proxy ExampleState+rootState = Proxy++main:: IO ()+main = do+ c <- startSystemStateMultimaster rootState+ commandLoop c++commandLoop :: MVar TxControl -> IO ()+commandLoop c = do+ putStrLn "Enter 'v' to view the state."+ putStrLn "Enter 's' to increment the state by 1."+ putStrLn "Enter 'c' to create a checkpoint."+ putStrLn "Enter 'q' to quit."+ val <- liftM head getLine+ handler c val++handler :: MVar TxControl -> Char -> IO ()+handler _ 'q' = return ()+handler c 'v' = query GetVal >>= print >> commandLoop c+handler c 's' = update SuccVal >> commandLoop c+handler c 'c' = createCheckpoint c >> commandLoop c+handler c _ = commandLoop c
+ src/MultiExample3.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable,+ MultiParamTypeClasses, TypeFamilies,+ FlexibleContexts #-}++module Main where++import Happstack.State++import Data.Typeable+import Control.Monad.State+import Control.Monad.Reader+import Control.Concurrent (MVar)++data ExampleState = ExampleState Int deriving (Typeable)++instance Version ExampleState+$(deriveSerialize ''ExampleState)++getVal :: Query ExampleState Int+getVal = do+ ExampleState n <- ask+ return n++$(mkMethods ''ExampleState ['getVal])++instance Component ExampleState where+ type Dependencies ExampleState = End+ initialValue = ExampleState 0++rootState :: Proxy ExampleState+rootState = Proxy++main:: IO ()+main = do+ c <- startSystemStateMultimaster rootState+ commandLoop c++commandLoop :: MVar TxControl -> IO ()+commandLoop c = do+ putStrLn "Enter 'v' to view the state."+ putStrLn "Enter 'c' to create a checkpoint."+ putStrLn "Enter 'q' to quit."+ val <- liftM head getLine+ handler c val++handler :: MVar TxControl -> Char -> IO ()+handler _ 'q' = return ()+handler c 'v' = query GetVal >>= print >> commandLoop c+handler c 'c' = createCheckpoint c >> commandLoop c+handler c _ = commandLoop c
+ src/Redirector.hs view
@@ -0,0 +1,9 @@+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/SerializeableSocialGraph.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-}+module SerializeableSocialGraph where++import Data.Generics+import Happstack.State+++-- Don't import anything from Data.Graph.Inductive.+-- Export whatever you need in UniqueLabelsGraph+-- That way non-unique-label operating functions like mkGraph, insNode, etc are hidden+-- import UniqueLabelsGraph+++-- If your datatype is read/showable, you can use a deriving clause to get a serializeable+-- instance, as I do below.+-- However in the fgl, Gr isn't readable, which violates read/show invertability and probably+-- should be patched in the fgl at some point.+-- So I modified code from the fgl in the modules below, basically just to have a derived readable instance+import SerializeableTree +import SerializeableFiniteMap++++-- There is Template Haskell machinery for deriving Serialize instances of many data types+-- , including Sets and Maps, in HAppS.Data.SerializeTH. +-- However, there was no machinery for deriving serializeable Graphs+-- So I declared an instance manually+instance Version (Gr a b) where mode = Primitive+instance (Serialize a,Serialize b, Eq a) => Serialize (Gr a b) where+ getCopy = contain ( fmap ( Gr . fmFromList ) safeGet )+ putCopy (Gr m) = contain . safePut . fmToList $ m+++data SocialGraph = SocialGraph { + socialgraph :: Gr User Float+} deriving (Read,Show,Eq, Typeable,Data) -- +instance Version SocialGraph+$(deriveSerialize ''SocialGraph) +
+ src/StateTExample.hs view
@@ -0,0 +1,19 @@+module Main where++import Happstack.Server+import Control.Monad.State++-- flip evalStateT 0 has a type of StateT Int IO a -> IO () a+-- 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++handler :: ServerPartT (StateT Int IO) String+handler = do+ -- We can use the MonadTrans instance of ServerPartT in order to lift a StateT computation+ -- into the ServerPartT monad+ i <- lift $ do+ modify (+1)+ get+ return . show $ i
src/StateVersions/AppState1.hs view
@@ -6,21 +6,22 @@ ) -} where -import HAppS.State+import Happstack.State import Data.Generics import Control.Monad (liftM) import Control.Monad.Reader (ask)-import Control.Monad.State (modify,put,get,gets)+import Control.Monad.State (modify,put,get, MonadState) import Data.Maybe import Data.List import qualified MiscMap as M-import qualified Data.Set as S import qualified Data.ByteString.Char8 as B import Misc +t :: String t = let f (JobName (j :: B.ByteString)) = B.unpack j in f . JobName $ (B.pack "job")+ -- It might be a bit of overkill to declare things with this level of specificity -- but I think it'll make the type signatures easier to read later on. newtype JobName = JobName { unjobname :: B.ByteString }@@ -49,13 +50,7 @@ instance Version Jobs $(deriveSerialize ''Jobs) ---import SerializeableUserInfos----import SerializeableJobs-- data UserProfile = UserProfile {- --billing_rate :: String -- eg "" (blank is ok), "$30-$50/hour", "40-50 Euro/hour", "it depends on the project", etc. contact :: B.ByteString -- eg, "thomashartman1 at gmail, 917 915 9941" -- tell something about yourself. Edited via a text area. should replace newlines with <br> when displayed. , blurb :: B.ByteString@@ -122,10 +117,10 @@ -- but can still fail monadically if the username is invalid mod_userM username f (Users us) = return . Users =<< M.adjustM username f us -set_user_userprofile_contact username c = mod_userM username $ ( mod_userprofile . set_contact $ c )-set_user_userprofile_blurb username b = mod_userM username $ ( mod_userprofile . set_blurb $ b )+set_user_userprofile_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 )+ mod_userM username ( mod_userprofile . set_consultant $ isconsultant ) -- set_user_userprofile username p = mod_userM username $ Right . set_userprofile p @@ -140,7 +135,7 @@ ( M.insertUqM username uis us ) where uis = UserInfos hashedpass (UserProfile (B.pack "") (B.pack "") False (B.pack "") )- (Jobs $ M.empty)+ (Jobs M.empty) del_user username uis (Users us) = either (fail . ("del_user: " ++)) (return . Users)@@ -148,16 +143,14 @@ type SessionKey = Integer -newtype SessionData = SessionData { +newtype SessionData = SessionData { sesUser :: UserName } deriving (Read,Show,Eq,Typeable,Data,Ord) instance Version SessionData $(deriveSerialize ''SessionData) ---data Sessions a = Sessions {unsession::M.Map SessionKey a} +data Sessions a = Sessions {unsession::M.Map SessionKey a} deriving (Read,Show,Eq,Typeable,Data) instance Version (Sessions a) $(deriveSerialize ''Sessions)@@ -180,7 +173,7 @@ data AppState = AppState { appsessions :: Sessions SessionData, appdatastore :: Users-} deriving (Show,Read,Typeable,Data) +} deriving (Show,Read,Typeable,Data) instance Version AppState @@ -192,8 +185,6 @@ appdatastore = Users M.empty } --- myupdate field newval record = record { field = newval }- askDatastore :: Query AppState Users askDatastore = do (s :: AppState ) <- ask@@ -232,13 +223,10 @@ Right um -> put $ AppState sessions (Users um) ------modify (\s -> (AppState (appsessions s) (f $ appdatastore s))) +--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))) +modSessions f = modify (\s -> (AppState (f $ appsessions s) (appdatastore s))) -- yecchh. -- the way setmap is being used seems kludgy@@ -285,8 +273,6 @@ set_password newpass (UserInfos pass up jobs) = UserInfos newpass up jobs -- -- was getUser getUserInfos :: UserName -> Query AppState (Maybe UserInfos) getUserInfos u = ( return . M.lookup u . users ) =<< askDatastore@@ -314,15 +300,13 @@ listUsersWantingDevelopers = (return . M.keys . M.filter wantingDeveloper . users) =<< askDatastore where wantingDeveloper uis = not . M.null . unjobs . jobs $ uis -- newSession :: SessionData -> Update AppState SessionKey newSession u = do 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+ put $ AppState (Sessions newss) us return k where inssess u sessions = do@@ -340,7 +324,7 @@ numSessions :: Query AppState Int numSessions = liftM (M.size . unsession) askSessions --- initializeDummyData dd = modUsers (const dd)+-- initializeDummyData :: M.Map UserName UserInfos -> m () initializeDummyData dd = do AppState ss (Users us) <- get if M.null us @@ -349,10 +333,13 @@ -- 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 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 us' <- M.insertUqM un uis us
+ src/UniqueLabelsGraph.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}+module UniqueLabelsGraph (+ insUqNode, insUqNodes, mkUqGraph, lnodesetFromGraph, labelsetFromGraph, empty, matchLabel, labelExists,+ addLab, modLab,+ DynGraphUqL+)++where++import Data.Graph.Inductive+import Control.Monad.State+import Data.Maybe+import qualified Data.Set as S+import Data.List (foldl',find)++-- like insNode(s) from Data.Graph.Inductive, but only works if node label is unique+-- a class for graphs with unique labels+-- you get an error if you try to insert duplicate labels+-- and there's a function for returning all node labels as a set.+-- wouldn't Ord constraint be better?++-- minimum definition: insUqNode+class (Ord a, DynGraph gr) => DynGraphUqL a gr where+ insUqNode :: LNode a -> gr a b -> gr a b+ insUqNode (v,l) gr | found = error "insNode, duplicate Node " + | otherwise = insNode (v,l) gr+ where found = isJust . find (\(_,lab) -> lab==l) . labNodes $ gr+ matchLabel :: a -> gr a b -> (Maybe (Data.Graph.Inductive.Context a b), gr a b)+ matchLabel l g = + case filter ( (==l) . snd) . labNodes $ g of+ [] -> (Nothing,g)+ [(nodeI,_)] -> match nodeI g+ otherwise -> error "matchLabel, duplidate labels"++instance (Ord a, DynGraph gr) => DynGraphUqL a gr++insUqNodes vs g = foldr insUqNode g vs++lnodesetFromGraph g = S.fromAscList . labNodes $ g++labelsetFromGraph g = (S.map snd) . lnodesetFromGraph $ g++mkUqGraph vs es = (insEdges' . insUqNodes vs) empty+ where+ insEdges' g = foldl' (flip insEdge) g es++ +labelExists l g = let (mcontext,gr) = matchLabel l g+ in isJust mcontext++-- these fail because of duplicate nodes, which is the right thing.+t, t1 :: Gr String Float+t = mkUqGraph [(1,""), (0,"")] [] +t1 = insUqNode (1,"") . insUqNode (0, "") $ empty++++addLab :: (DynGraph g, Ord a) => a -> g a b -> g a b+addLab a g = run_ g $ insMapNodeM a+ +-- fails, as it should, because dupe+t2 :: Gr String ()+t2 = addLab "" . addLab "" $ empty+++modLab :: (Ord a, DynGraph g) => (a -> a) -> a -> g a b -> g a b+modLab f nl g = run_ g $ do+ oldgraph <- return . snd =<< get -- couldn't we just say: g instead of oldgraph and skip this?+ let ( mbOldContext, oldRemainingGr ) = matchLabel nl oldgraph+ mbNewGraph = do (fr, nodeId, nodeLabel, to) <- ( mbOldContext )+ return $ (fr, nodeId, f nodeLabel, to) & oldRemainingGr+ return $ maybe oldgraph id mbNewGraph
src/View.hs view
@@ -1,16 +1,12 @@ module View where -import Text.StringTemplate import Misc-import qualified Data.Map as M import Data.List-import HAppS.Server.HTTP.Types (rqURL, Request)+import Happstack.Server.HTTP.Types (Request) import qualified Data.ByteString.Char8 as B import Data.Char import Control.Monad.Reader-import HAppS.Helpers.HtmlOutput import Text.StringTemplate.Helpers-import Network.HTTP (urlEncode) import Data.Maybe import StateVersions.AppState1@@ -18,9 +14,7 @@ -- --import SerializeableUserInfos (UserProfile (..)) -- (Job(..), JobName(..))-import HAppS.Helpers----import MiscStringTemplate+import Happstack.Helpers -- debug problem with foreign character display -- foreign chars displau okay@@ -60,7 +54,7 @@ where escapequote char = if char=='"' then "\\\"" else [char] readTutTuples :: String -> [(String,String)] readTutTuples f = either (const [("readTutTuples error","")]) id- $ (readtut f :: Either String [(String,String)] )+ (readtut f :: Either String [(String,String)] ) attrsL = maybe attrs( \user -> [("loggedInUser",B.unpack . unusername $ user)] ++ attrs ) mbU content = rendertut attrsL tmpl@@ -69,7 +63,7 @@ where userMenu = maybe ( rendertut attrsL "login" )- ( \user -> hMenuBars rq $+ ( \user -> hMenuBars rq [("/tutorial/logout","logout " ++ (B.unpack . unusername $ user)) , ("/tutorial/changepassword","change password")] ) ( mbU ) @@ -89,10 +83,13 @@ , ("contentarea",content) , ("headerarea",header)] ) "base" -cleanTemplateName tmpl = filter isAlpha tmpl-paintblurb b = newlinesToHtmlLines b+cleanTemplateName :: String -> String+cleanTemplateName = filter isAlpha ---paintProfile :: RenderGlobals -> String -> UserProfile -> String+paintblurb :: String -> String+paintblurb = newlinesToHtmlLines++paintProfile :: RenderGlobals -> String -> UserProfile -> String -> String paintProfile rglobs user cp userimagepath = let ts = getTemplateGroup "." . templates $ rglobs @@ -104,10 +101,9 @@ in renderTemplateGroup ts attrs "consultantprofile" --paintUserJobsTable rglobs postedBy rsUserJobs currP resPP = - let jobCells = map ( \( JobName j', Job budget blurb) -> let j :: String- j = B.unpack j' in +paintUserJobsTable :: B.ByteString -> [(JobName, Job)] -> String+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")@@ -115,11 +111,15 @@ ] ) 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)++userlink :: B.ByteString -> String 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) = let ts = getTemplateGroup "." . templates $ rglobs- joblink = simpleLink ("/tutorial/viewjob?user=" ++ (B.unpack pBy),(B.unpack pBy) ) attrs = [ ("username",B.unpack pBy) , ("jobname",B.unpack jN) , ("budget",B.unpack jBud)
+ src/add10000users.hs view
@@ -0,0 +1,14 @@+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 view
@@ -0,0 +1,13 @@+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
@@ -0,0 +1,21 @@+{-# OPTIONS -fglasgow-exts #-}++import StateVersions.AppState1+import Happstack.State+import System.Environment+ +entryPoint :: Proxy State+entryPoint = Proxy++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+ createCheckpoint control+ shutdownSystem control+
+ src/migrationexample/MigrateToState2.hs view
@@ -0,0 +1,23 @@+{-# OPTIONS -fglasgow-exts #-}++import StateVersions.AppState2+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 "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++ createCheckpoint control+ shutdownSystem control+
+ src/migrationexample/MigrateToState3.hs view
@@ -0,0 +1,23 @@+{-# 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 view
@@ -0,0 +1,55 @@+== 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/Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ src/migrationexample/StateVersions/AppState1.hs view
@@ -0,0 +1,51 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances,+ MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+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++$(deriveSerialize ''Page)+$(deriveSerialize ''State)++instance Component State where+ type Dependencies State = End -- no dependencies+ initialValue = State {pages = []} -- no pages++insertPage :: MonadState State m => String -> Page -> m ()+insertPage pageName page = modPages $ (:) (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])
+ src/migrationexample/StateVersions/AppState2.hs view
@@ -0,0 +1,49 @@+{-# OPTIONS -fglasgow-exts #-}+{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances,+ MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}+module StateVersions.AppState2 ( InsertPage (..), State(..), AskPages (..), Old.Page (..), Old.Title(..), Old.Body (..) ) + 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.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)++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)+++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])
+ src/migrationexample/StateVersions/AppState3.hs view
@@ -0,0 +1,64 @@+{-# 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/basichtml.st view
@@ -0,0 +1,20 @@+<h3>Basic HTML inclusion</h3>+<p>Happstack is completely agnostic as to the source of the HTML served.+There is no required templating system. We'll be looking at a few simple ways to include HTML in your application: </p>+<ul>+ <li>HtmlString</li>+ <li>Text.Html</li>+ <li>HStringTemplate</li>+</ul>+<h4>HtmlString</h4>+<p>We've already seen the use of HtmlString, from the happstack-helpers package,+in the <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a> file.+You can include your HTML as String literals wrapped with a HtmlString constructor+and the ToMessage instance for HtmlString will take care of the rest.</p>+<h4>Text.Html</h4>+<p>I won't be providing a tutorial on using <a href="http://www.haskell.org/ghc/docs/latest/html/libraries/html/Text-Html.html">Text.Html</a>, but I want to point +out that there is a ToMessage instance for Html. This means that anything built+from the combinators included in Text.Html will display correctly.+</p>+<h4>HStringTemplate</h4>+<p>Lets move on to the <a href="/tutorial/templates-dont-repeat-yourself">next</a> couple of chapters, which will cover the use HStringTemplate in some depth.</p>
templates/basicurlhandling.st view
@@ -2,27 +2,23 @@ <p>One of the most basic functions of a web framework is to give you a way of controlling what happens when a web browser makes an http request.</p> -<p>$! Before explaining the theory of request handling in Happstack, !$ Let's look at some simple -examples.</p>--<!-- who cares about MVC?... <p>In the <a href="#">FIX LINK... MVC paradigm</a> employed by Ruby on Rails and other popular frameworks, this is the task of the Controller. </p> -->+<p>Let's look at some simple examples.</p> <ol>- <li> Read the source code of the simpleHandlers function in <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a> to see how urls are handled in Happstack. <b>Pay attention to the comments!</b>- <li>Follow the urls below by clicking on them. Match what happens when you click on a link with the code in <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a></li>-</ol>+ <li> Read the source code of the simpleHandlers function in <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a> to see how urls are handled in Happstack. <b>The comments contain the bulk of the information in this chapter.</b></li>+ <li>Follow the urls below by clicking on them. Match what happens when you click on a link with the code in <a href="/src/ControllerBasic.hs">ControllerBasic.hs</a>.</li> <ul> <li>introduction to handlers: <a href="/helloworld">hello world</a></li> - <li>exactdir and msgToSp (subdirectories of the path argument do not match):- <a href="/exactdir-with-msgtosp">exactdir-with-msgtosp</a> ... - <a href="/exactdir-with-msgtosp/subdir">exactdir-with-msgtosp/subdir</a> ... + <li>exactdir (subdirectories of the path argument do not match):+ <a href="/exactdir">exactdir</a> ... + <a href="/exactdir/subdir">exactdir/subdir</a> ... </li>- <li>introduction to dir and msgToSp -- subdirectories *do* match:- <a href="/dir-with-msgtosp">dir-with-msgtosp</a> ...- <a href="/dir-with-msgtosp/subdir">dir-with-msgtosp/subdir</a>+ <li>introduction to dir -- subdirectories *do* match:+ <a href="/dir">dir</a> ...+ <a href="/dir/subdir">dir/subdir</a> </li> <li>gluing handlers together / handlers as monoids: <a href="/handleraddition1">handleraddition1</a> ... @@ -33,8 +29,7 @@ </li> <li>the "empty" handler:- <a href="/nohandle1">nohandle1</a> ...- <a href="/nohandle2">nohandle2</a>+ <a href="/nohandle1">nohandle1</a> </li> <li>IO in the response: <a href="/ioaction">IO Response</a> ... @@ -47,9 +42,11 @@ <li>Serving static files: <a href="/templates/base.st">Using dir and fileserve "templates", we can view templates</a> ... <a href="/templates/basicurlhandling.st">The template that was used to generate this page</a> </li>+ <li><a href="/redirect">redirection with seeOther</a></li> </ul> +</ol> <p>The static file serving example above hints at the templating system used by this tutorial to put together web pages behind the scenes.</p> -<p>We learn about <a href="/tutorial/templates-dont-repeat-yourself">using templates with Happstack</a> next.</p>+<p>We learn about ways to conveniently include HTML <a href="/tutorial/basic-html">next.</a></p>
templates/cookies.st view
@@ -2,15 +2,15 @@ <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 happs googlegroup.)+ (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, + So, cookies do work in happs-tutorial: I use google analytics to track visitors, along with normal Happstack session cookies.- And if you use happs-tutorial as a template for your apps you should be fine.+ 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@@ -22,8 +22,8 @@ <p>When you log in, a cookie is created that expires in an hour - (3600 seconds). And 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+ (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. <p>The cookie code is in <a href=/projectroot/src/Misc.hs>ControllerMisc.hs</a>:
templates/debugging.st view
@@ -2,22 +2,19 @@ <p>A few words on debugging. -<p>One thing you can do is put debugFilter before the serverPartT that seems to be causing trouble.- <br> This will spit out the request and response objects, which can be helpful.+<p>One thing you can do is put debugFilter before the serverPartT that seems to be causing trouble. This will spit out the request and response objects, which can be helpful.</p> -<p>*Main> :t debugFilter :: Show a => [ServerPartT IO a] -> [ServerPartT IO a]-<br>debugFilter :: Show a => [ServerPartT IO a] -> [ServerPartT IO a] :: (Show a) =>-<br> [ServerPartT IO a] -> [ServerPartT IO a]-<br>*Main> :i debugFilter+<p>*Main> :i debugFilter <br>debugFilter :: <br> (Show a, Control.Monad.Trans.MonadIO m) =>-<br> [ServerPartT m a] -> [ServerPartT m a]-<br> -- Defined in HAppS.Server.SimpleHTTP+<br> ServerPartT m a -> ServerPartT m a+<br> -- Defined in Happstack.Server.SimpleHTTP</p> -<p>I personally don't use debugFilter much, as it gives almost too much information. +<p>I personally don't use debugFilter much, as it gives almost too much information.</p>+ <p>Instead, I depend on Debug.Trace.trace (a standard library function which sneaks IO in- anywhere you have a showable value), which I augmented with some helper functions (in Misc.hs).+ anywhere you have a showable value), which I augmented with some helper functions (in Misc.hs).</p> <p>traceTrue x = trace (show x ++ "\n\n") True <br>traceIt x = trace (show x ++ "\n\n") x@@ -26,8 +23,7 @@ <p>Typical (basically only) use of traceTrue: view arguments to a function in stdout, by putting it on the right side of the "execute this branch if true" bar in a function definition.- The function executes as it normally would, because traceTrue always returns true.- But you get debugging info as a side effect.+ The function executes as it normally would, because traceTrue always returns true, but you get debugging info as a side effect.</p> <p>tutlayout (RenderGlobals ts mbU) attrs tmpl0 | traceTrue ((RenderGlobals ts mbU), attrs, tmpl0) = ..... @@ -41,9 +37,9 @@ <p>traceMsg does pretty much the same thing as traceIt, except you preface the shown expression with your own message like "show the menu: ". This can be useful if you are doing more than one trace- and need to disginguish them.+ and need to distinguish them. -<p>There are probably smarter ways of debugging a happs app, the above is just what works for me.+<p>There are probably smarter ways of debugging a happs app; the above is just what works for me. (Actually, I debug using these trace helpers all the time, not just in Happstack.) If I get useful feedback on how other Happstack users approach debugging I will update this page.
templates/getandpost.st view
@@ -8,7 +8,7 @@ One place this is used is in the <a href=/tutorial/register>registration</a> process. Once you have a user created, you can also see POST in action by editing your profile or creating jobs. -<p>HAppS deals with GET and POST data similarly.+<p>Happstack deals with GET and POST data similarly. <p>Let's look at how <a href=/tutorial/viewprofile?user=tphyahoo>tphyahoo's profile</a> gets displayed.@@ -17,30 +17,60 @@ <p>using dir and methodSP as above is a common pattern. dir pops the head element of the path array ["viewprofile"], resulting in an empty array. methodSP checks that the path array is empty and that - the method is GET. If so, control is passed to the next sp: userProfile rglobs, which is in another module.+ the method is GET. If so, control is passed to the next sp: userProfile rglobs, which is in another module.</p> -<p><a href=/src/ControllerGetActions.hs>ControllerGetActions.hs</a>: +<p>Now once we can select for any HTTP method, how do we actually grab data from the request?+Fundamentally, this comes down to the FromData class. Again, we can fire up ghci and check it out.</p>+<p>ghci>:i FromData +<br>:i FromData+<br>class FromData a where fromData :: RqData a+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (FromData a, FromData b) => FromData (a, b)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (FromData a, FromData b, FromData c) => FromData (a, b, c)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (FromData a, FromData b, FromData c, FromData d) => FromData (a, b, c, d)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (FromData a) => FromData (Maybe a)+<br> -- Defined in Happstack.Server.SimpleHTTP+</p>+<p>As you can see, there are a few convenience instances defined for tuples of FromData instances+and for the lift of a FromData instance into Maybe. How does one actually make an instance of+FromData yourself, though? The basic way is to use look.</p>+<p>ghci>:t look+<br>look :: String -> RqData String+</p>+<p>Another note is that RqData is an instance of Monad and MonadPlus. Between these instances and look+you should be able to easily define your own instances of FromData. We'll be looking at an example+from the code running this tutorial below.</p> +<p><a href=/src/ControllerGetActions.hs>ControllerGetActions.hs</a>: </p>+ <p>data UserNameUrlString = UserNameUrlString {profilename :: String} <br>instance FromData UserNameUrlString where-<br> fromData = liftM UserNameUrlString (look "user" `mplus` return "")-<br>userProfile rglobs = -<br> withData \$ \(UserNameUrlString user) ->-<br> [ ServerPartT \$ \rq -> do .....-<br>--<p>*Main> :t withData :: FromData a => (a->[ServerPartT IO Response]) -> ServerPartT IO Response+<br> fromData = liftM UserNameUrlString (look "user" `mplus` return "")</p>+<p>Since we have an instance of FromData defined, we can use it with a code fragment like the following.+<br>...UserNameUrlString user <- getData >>= maybe mzero return...+</p>+<p>ghci> :t getData+<br>getData :: (ServerMonad m, FromData a) => m (Maybe a)</p>+<p>There's also another function you can use which is helpful when you don't actually+need do notation and just want a one line function.+<br>ghci> :t withData +<br>withData :: (withData :: (FromData a,Control.Monad.MonadPlus m, ServerMonad m) => (a -> m r) -> m r+</p> -<p>The above is the main pattern for processing GET or POST data in happs.+<p>The above is the main pattern for processing GET or POST data in Happstack. Please look through+ControllerGetActions.hs to get more examples of using this.</p> -<p>First, you decide what argument type withData should accept. This might be a datatype you have already - defined, like User or Job, which already plays a major role in the app.- Or it could be an ad-hoc datatype which is only used this once, in the form processing.- Whatever the case you declare that data type an instance of FromData, and define how it should+<p>To summarize, you decide what argument type withData should accept. This might be a datatype you have already + defined, like User or Job (which already plays a major role in the app), or it could be an ad-hoc datatype which +is only used this once in the form processing.+ Whatever the case, you declare that data type an instance of FromData, and define how it should grab data attached to the request. In this case, UserNameUrlString takes one argument, so we use liftM -- for two args we would use liftM2, three args liftM3 etc. To get that one arg, we look for a request GET variable named "user" and if we don't find it we use a reasonable default, in this case the empty string. The result is a value of type UserNameUrlString- which gets passed to the ServerPartT handler in the userProfile function.--Next we cover <a href="/tutorial/file-uploads">uploading files</a>+ which gets passed to the ServerPartT handler in the userProfile function.</p>+<p>+Next we cover <a href="/tutorial/file-uploads">uploading files</a></p>
+ templates/happstackwostate.st view
@@ -0,0 +1,8 @@+<h3>Using Happstack.Server without Happstack.State</h3>+<p>One thing needs to be clarified about the usage of Happstack. Using Happstack.Server does not in any+way require you to use Happstack.State for managing application state. Most Happstack applications you'll come+across are written to use Happstack's MACID library on its merits, not because they are forced to.</p>+<p>So how does one use Happstack with a SQL database or any other state management system? Quite simply, you do it the+way you would in any other Haskell program. The key here being the free monad parameter in the Happstack.Server function+simpleHTTP'</p>+<p>ghci>:t simpleHTTP'
templates/home.st view
@@ -1,21 +1,20 @@ <h3>Real World Happstack: building a Web 2.0 App with Haskell</h3> -<p><a href="http://www.happstack.com">Happstack</a> is a great way to build web applications. +<p><a href="http://www.happstack.com">Happstack</a> is a great way to build web applications. Besides having a great feature set in its own right, it is probably the leading solution for implementing web apps in <a href="http://www.google.com/search?hl=en&q=why+haskell">Haskell</a>, my favorite language.</p> <p>If you use Ruby on Rails, Django, Perl Catalyst, PHP, or some other popular web framework, but have programmed in Haskell and would like to use the world's greatest language for your next web project,-just keep reading. I promise by the time you're done you will posess all the knowledge +just keep reading. I promise by the time you're done you will possess all the knowledge and sample code you need.</p> -<p>This tutorial is its own demo, and it is <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/happs-tutorial">open source</a>. The tutorial explains how to build a toy job board, which you can try out for yourself by-creating a user on this demo site, and play with locally after you have installed the source code.-The text you are reading this moment is bundled up too, hence "self-demoing tutorial."-For best results, you should+<p>This tutorial is its own demo and it is <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/happs-tutorial">open source</a>. The tutorial is an introduction to using Happstack, providing a number of guided "try-at-home" examples and then explaining how to build a toy job board, which you can try out for yourself by+creating a user on this demo site, and play with locally after you have installed the source code. +The text you are reading this moment is bundled up too, hence "self-demoing tutorial." For best results, you should <a href="/tutorial/run-tutorial-locally">install and run</a>-it in a local environment where you have control. Then, when you are done+it in a local environment where you have control. Then, when you are done learning, you can use the tutorial code as a starting point for your own Happstack applications. </p>
templates/introductiontomacid.st view
@@ -1,6 +1,8 @@-<h3>Introduction To Macid</h3>+<h3>Introduction To MACID</h3>+<p>For now we're going to step away from Happstack.Server and making web applications with Happstack.+Instead, we'll be talking about the persistant state system provided by Happstack.State: MACID.</p> -<p>Macid is the Happstack storage mechanism that allows you to use whatever data structure you want+<p>MACID is the Happstack storage mechanism that allows you to use whatever data structure you want to hold your permanent data, without worrying about getting it into and out of tabular form fit for storage in a traditional <a href="http://en.wikipedia.org/wiki/Relational_database_management_system">rdbms</a>. @@ -22,16 +24,11 @@ <p> thartman@thartman-laptop:~/happs-tutorial>grep -ra testuser _local <br>_local/happs-tutorial_state/events-0000000000:ß\$6¡·¢:1525374391 696985193?AppState1.AddUsertestuser e1- ... (and lots more lines of binary data)+ ... (and lots more lines of binary data)</p> -<p>Hm... let's see, can we be sneaky and grep for the password?+<p>Hm... let's see, can we be sneaky and grep for the password?</p> <p>Try it, you can't. Because the password is stored as an md5 hash, out of respect for the privacy of your users.- See the newUserPage function in <a href=/src/ControllerPostActions.hs>ControllerPostActions</a> if you're curious. --$!<p>Keeping application data in static files- may seem like a weird thing to do if you have gotten used to keeping application data in a database.- But it's not really that weird. !$ -+ See the newUserPage function in <a href=/src/ControllerPostActions.hs>ControllerPostActions</a> if you're curious.</p> -<p><a href="/tutorial/maciddatasafety">Keeping your macid data safe</a>+<p>Now it's time for your <a href="/tutorial/yourfirstmacid">first application</a>.</p>
templates/maciddatasafety.st view
@@ -1,35 +1,28 @@-<h3>Keeping your macid data safe</h3>--$! <p>All web startups have something in common. If you lose your user data, you are hosed. !$--$! <p>So when I was first learning about HAppS, and contemplating doing a startup with it, one of my first questions- was, how do I keep this from happening? !$+<h3>Keeping your MACID data safe</h3> <p>If you are using php, ruby on rails, or one of the other popular web frameworks, your user data is likely- in a mysql database$!, or if you are well funded maybe in Oracle!$. If you have outsourced your server hosting,- maybe you $!are even lucky enough to!$ have a database administrator that takes backups for you on a regular basis.- That probably helps you sleep at night, assuming that you can really trust that your dba is doing their job.+ in a mysql database. If you have outsourced your server hosting,+ maybe you have a database administrator that takes backups for you on a regular basis.+ That probably helps you sleep at night, assuming that you can really trust that your dba is doing their job.</p> -<p>As we learned in the previous lesson, if you are using Happstack with macid, your data is +<p>As we learned in the previous lesson, if you are using Happstack with MACID, your data is right there on your filesystem, by default in the directory called <i>_local</i>. <p>~/happs-tutorial>ls _local/happs-tutorial_state/-<br>current-0000000000 events-0000000000 events-0000000001 events-0000000002 -- +<br>current-0000000000 events-0000000000 events-0000000001 events-0000000002 <p>If there is money on the line, you are going to want to be careful with this directory. -<p>When <a href="/tutorial/macid-migration">migrating macid data</a> to a new schema, you are also going to want to be extra cautious.+<p>When <a href="/tutorial/macid-migration">migrating MACID data</a> to a new schema, you are also going to want to be extra cautious. -<p>But for now, since you don't have any valuable data, the following procedure is probably enough+<p>For now, since you don't have any valuable data, the following procedure is probably enough to remind yourself to be careful while learning about Happstack in the tutorial sandbox. <ul>- <li>Stop happs by doing ctrl-c if you are running the ./happs-tutorial app from a shell+ <li>Stop Happstack by doing ctrl-c if you are running the ./happs-tutorial app from a shell or ctrl-c and completely exiting ghci if you are doing runInGhci within ghci. <li>~/happs-tutorial> mv _local _local.20081001-0917am.bak- <li>Start the happs server again. All users, profiles, jobs, and sessions should be gone,+ <li>Start the Happstack application again. All users, profiles, jobs, and sessions should be gone, and a new _local directory with nothing in it should have been created. A fresh start. <li>If you want your old data back, backup your existing _local directory somewhere safe@@ -41,50 +34,44 @@ <p>Q: Do you have to shut down the Happstack server every time you migrate data to a new schema? -<p>A: No, but online migrations are a more advanced topic that will be covered in a future chapter.+<p>A: No, but online migrations are a topic that will be covered in a future chapter.</p> -<p>Q: Is macid safe? Could I wake up one day with corrupted data under _local and no way to recover from it?+<p>Q: Is MACID safe? Could I wake up one day with corrupted data under _local and no way to recover from it? <p>A: Let's be realistic. Compared to, say, mysql, Happstack hasn't been stress-tested much in critical high-volume web sites. On the other hand, stress testing is on the docket for the Happstack team and when more data is known- I'll be including it in this tutorial.- So whatever the Happstack developers say about reliability, personally I wouldn't be surprised if I encountered - some kind of data corruption problem as an early adopter.- <p> That said, the unix filesystem is pretty good at not losing your data -- - a point <a href="http://www.paulgraham.com/vwfaq.html">famously</a> made by startup guru paul graham,- who created viaweb (now yahoo stores) with all the application state in flat files.-- $! This might not have worked so well if the application required transactional integrity -- - say, moving money between accounts. But using macid, if you set up your state appropriately, it should. !$+ I'll be including it in this tutorial. </p>+<p> That said, the unix filesystem is pretty good at not losing your data -- + a point <a href="http://www.paulgraham.com/vwfaq.html">famously</a> made by startup guru Paul Graham,+ who created viaweb (now yahoo stores) with all the application state in flat files.</p> - <p> If you use windows or mac, you probably believe these filesystem are pretty reliable too.+<p>If you use Windows or Mac, you probably believe these filesystem are pretty reliable too.</p> - <p>Taking a closer look at what is under _local...-<p>-thartman@thartman-laptop:~/happs-tutorial/_local/happs-tutorial_state>ls -lth+<p>Taking a closer look at what is under _local...</p>+<p>thartman@thartman-laptop:~/happs-tutorial/_local/happs-tutorial_state>ls -lth <br>total 12K <br>-rw-r--r-- 1 thartman thartman 0 Oct 1 13:55 events-0000000003 <br>-rw-r--r-- 1 thartman thartman 0 Oct 1 11:55 events-0000000002 <br>-rw-r--r-- 1 thartman thartman 792 Oct 1 11:04 events-0000000001 <br>-rw-r--r-- 1 thartman thartman 491 Oct 1 11:00 events-0000000000 <br>-rw-r--r-- 1 thartman thartman 25 Oct 1 10:59 current-0000000000-<br>thartman@thartman-laptop:~/happs-tutorial/_local/happs-tutorial_state>+<br>thartman@thartman-laptop:~/happs-tutorial/_local/happs-tutorial_state></p> -<p> Macid serialization works by writing state change event data+<p> MACID serialization works by writing state change event data one file at a time. At server startup, Happstack "replays" all the information here in the order specified by the file names. This is similar to the <a href="http://en.wikipedia.org/wiki/Transaction_log">database transaction log</a>- used by many rdbms systems.+ used by many rdbms systems.</p> <p> So, if I woke up one morning with my Happstack application in a corrupt, non-startable state and my inbox full of angry customer email, probably what I would do is move files, one at a time,- out of the serialization directory, last-file created first, and keep trying to restart Happstack.+ out of the serialization directory, last-file created first, and keep trying to restart Happstack.</p> -<p> Q: What if my hard drive dies and I can't get my data back?+<p> Q: What if my hard drive dies and I can't get my data back?</p> <p> A: Like with any other data storage system, if there's valuable data, you need to be making backups. In the case of Happstack data stored under _local, I would probably be <a href="http://www.rsync.net">rsyncing</a> the _local directory to a remote server, or maybe multiple remote servers for extra safety. For now I am not worried- about securing data, but when that day comes I'm pretty confident I'll be ok.+ about securing data, but when that day comes I'm pretty confident I'll be ok.</p> -<p> Let's now populate our web application with <a href="/tutorial/macid-dummy-data">dummy data</a>.+<p> Let's now populate our web application with <a href="/tutorial/macid-dummy-data">dummy data</a>.</p>
templates/maciddummydata.st view
@@ -14,7 +14,12 @@ <p>If everything worked right, you should now have two <a href="/tutorial/consultants">users</a> and a couple hundred <a href="/tutorial/jobs">jobs</a> worth of test data- displaying in your jobs site.--<p><a href="/tutorial/macid-updates-and-queries">What just happened?</a>+ displaying in your jobs site.</p>+<p>What have we done here?</p>+<p>We've used the code found in <a href="/src/ControllerStressTests.hs">ControllerStressTests.hs</a> to take action+on the tutorial application state, which is to be found in <a href="/src/StateVersions/AppState1.hs">AppState1.hs</a>.+Now that you've had a basic introduction of using Happstack.State, I recommend looking through these files to get a+better feel for more complicated examples.</p>+<p>Now we need to discuss what to do when you need to <a href="/tutorial/macid-migration">change</a>+your data types.</p>
templates/mainfunction.st view
@@ -4,7 +4,7 @@ <p>In particular, notice the line -<p>smartserver (Conf p Nothing) "happs-tutorial"+<p>smartserver (Conf p Nothing) "happstack-tutorial" (controller tDirGroups dynamicTemplateReload allowStressTests) stateProxy @@ -13,8 +13,8 @@ <br>*Main> :i smartserver <br>smartserver :: <br> (Methods st, Component st, ToMessage a) =>-<br> Conf -> String -> [ServerPartT IO a] -> Proxy st -> IO ()-<br> -- Defined in HAppS.Server.Helpers+<br> Conf -> String -> ServerPartT IO a -> Proxy st -> IO ()+<br> -- Defined in Happstack.Server.Helpers <p>Each of these arguments is important enough to say something brief about. @@ -43,14 +43,14 @@ <p> <br>*Main> :i controller-<br>controller :: Bool -> [ServerPartT IO Response]+<br>controller :: Bool -> ServerPartT IO Response <br> -- Defined at <a href="/src/Controller.hs">Controller.hs</a>... <br> <br>*Main> :i ServerPartT <br>newtype ServerPartT m a = ServerPartT {unServerPartT :: Request -> WebT m a}-<br> -- Defined in HAppS.Server.SimpleHTTP+<br> -- Defined in Happstack.Server.SimpleHTTP <br>instance [overlap ok] (Monad m) => Monad (ServerPartT m)-<br> -- Defined in HAppS.Server.SimpleHTTP+<br> -- Defined in Happstack.Server.SimpleHTTP <br> <br>*Main> :i WebT <br>newtype WebT m a = WebT {unWebT :: m (Result a)}
+ templates/moreserver.st view
@@ -0,0 +1,67 @@+<h3>More examples of using Happstack.Server</h3>+<p>There are a number of basic combinators provided by Happstack.Server and Happstack.Helpers that allow us to create an arbitrarily complicated structure to handle requests.</p>+<p>The functions we'll discuss in this section are: </p>+<ul>+ <li> dir+ <li> exactdir+ <li> method+ <li> fileServ+</ul>+<p>We'll also discuss the utility of the standard instances of ServerPartT</p>++<h4>dir and exactdir</h4>+<p>Entire the following into ghci: +<br>ghci>:m + Happstack.Server+<br>ghci>let h1 = dir "snack" [return "ham"] :: ServerPartT IO String+<br>ghci>simpleHTTP (Conf 8080 Nothing) [h1]+</p>+<p>Now try navigating to "localhost:8080". You should get an error that there is no handler.</p>+<p>Now try navigating to "localhost:8080/snack". You should get the text "ham".</p>+<p>Now for one last test try "localhost:8080/snack/stuff". What happens?</p>+<p>Cool, huh? Now let's try using the exactdir method from Happstack.Helpers instead. $! need to do something about ghci and the need to restart it !$+<br>ghci>:m + Happstack.Helpers+<br>ghci>let h2 = exactdir "/foo" [return "bar"] :: ServerPartT IO String+<br>ghci>simpleHTTP (Conf 8080 Nothing) [h2]+</p>+<p>Now try navigating to "localhost:8080/foo". Works exactly as you'd expect, right? What happens if you navigate to "localhost:8080/foo/fud" instead?</p>+<h4>ServerPartT as a Monoid</h4>+<p>Interrupt simpleHTTP again and let us try something slightly different.+<br>ghci>:m + Data.Monoid+<br>ghci>let h3 = h1 `mappend` h2+<br>ghci>simpleHTTP (Conf 8080 Nothing) [h3]+</p>+<p>+There's a caveat to remember, though, related to the Monoid+instance for ServerPartT. Try this: +<br>ghci>let h4 = dir "snack" [return "ham2"]+<br>ghci>simpleHTTP (Conf 8080 Nothing) [h4 `mappend` h1] +</p>+<p>You should see ham2 if you navigate to localhost:8080/snack. That's because the <strong>first</strong> handler that can handle a request is the one that is chosen.</p>+<p>You can probably guess what mempty does for ServerPartT in order for the Monoid instance to make sense. It's the handler that cannot handle any requests.</p>+<p>One last point is that the Monoid and MonadPlus instances for ServerPartT will have the same behavior. In this tutorial I will favor the use of Monoid over MonadPlus for entirely arbitrary reasons.</p>+<h4>method and Method</h4>+<p>Every request will have a Method. This Method corresponds to the actual HTTP method of request. As you can imagine, that means that Method is an algebraic data type. Go ahead and try typing :i Method into ghci. You should see+<br>data Method+<br> = GET | HEAD | POST | PUT | DELETE | TRACE | OPTIONS | CONNECT+</p>+<p>When we've been creating ServerPartTs using return, the result is a handler that accepts requests with any type of method. As you can imagine, Happstack.Server includes a functions that can limit a handler to only responding to certain Methods. They are appropriately called method and methodSP. Check their types in ghci.+<br>ghci>:t method+<br>method :: (Happstack.Server.SimpleHTTP.MatchMethod method,Monad m) =>+<br>method -> WebT m a -> ServerPartT m a+<br>:t methodSP+<br>methodSP :: (Happstack.Server.SimpleHTTP.MatchMethod method, Monad m) => +<br>method -> ServerPartT m a -> ServerPart m a+</p>+<p>Now those might seem like very odd types, but they're simpler than they look. You can pass a literal Method, a list of Methods, or a predicate on Methods for them to make their selection. I'm going to use methodSP in the sequel because I find it more clear to use ServerPartTs as an opaque type rather than dealing with WebTs directly.</p>+<p>To test out these functions, try using the two forms below.</p>+<form name="getinput" action="/getformhandler"+ method="get">+ <input type="text" name="input">+ <input type="submit" value="Submit">+</form>++<form name="postinput" action="/postformhandler"+ method="post">+ <input type="text" name="input">+ <input type="submit" value="Submit">+</form>
+ templates/multimaster.st view
@@ -0,0 +1,47 @@+<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!+</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 +<a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/hspread">hspread</a> bindings. Happstack does not do any set up or configuration of Spread for you. You'll need to take care of the Spread daemon yourself before attempting to run an application using multimaster. We'll be walking through an example of this set up in the case of Linux.</p>+<h4>Setting up Spread on Linux</h4>+<ol>+ <li>Download and install the Spread 4 release available <a href="http://www.spread.org/download/spread-bin-4.0.0.tar.gz">here</a>.</li>+ <li>Run the following command, using the <a href="/src/spread.conf">conf</a> file included in this tutorial, to run Spread on your local machine: spread -c spread.conf -n localhost</li>+ <li>If you are immediately returned to the command prompt, then Spread is not actively running.</li>+</ol>+<h4>A few brief multimaster examples</h4>+<p>Copy the source code from <a href="/src/MultiExample1.hs">MultiExample1.hs</a>, + <a href="/src/MultiExample2.hs">MultiExample2.hs</a>, <a href="/src/MultiExample3.hs">MultiExample3.hs</a>. + I know this is a lot of files, but I'll walk you through them all.</p>+<ol>+ <li>Start up MultiExample1 and MultiExample2</li>+ <li>Increment the state in MultiExample1.</li>+ <li>Confirm that the changes are visible in MultiExample2.</li>+ <li>Checkpoint MultiExample1</li>+ <li>Close both programs.</li>+ <li>Check under _local and find the states recorded for each application. Note that each one is serializing its set+ of events separately and that a checkpoint was only made for MultiExample1. Multimaster makes sure that events+ are synced up, but checkpointing isn't an 'event' in this context.</li>+ <li>Restart one or the other and you should see the state+ as you left it.</li>+ <li>Start MultiExample3 as well. Check that the state is synced</li>+ <li>Increment the state. Notice the error message you get in the window running MultiExample3.</li>+ <li>Confirm that the state was not updated in MultiExample3.</li>+</ol>+<p>I'm presuming that the synchronization is fairly straight forward from the example, but why the errors in MultiExample3?</p>+<p>If you check out the source for MultiExample3, you'll see that there's no succVal Update defined in the file. The way multimaster works is that it reroutes the events. If an application receiving the events doesn't have a registered handler, i.e. an Update made into a Method by calling mkMethod, then it won't be able to perform the Update.+It won't crash, but it will fall out of sync; sometimes the latter can be worse!</p>+<h4>Scaling your own applications</h4>+<p>Making your own applications use multimaster is surprisingly simple!+You just need to use the function startSystemStateMultimaster.+<br>ghci>:i startSystemStateMultimaster+<br>startSystemStateMultimaster ::+<br> (Methods a, Component a) =>+<br> Proxy a -> IO (GHC.IOBase.MVar TxControl)+<br> -- Defined in Happstack.State.Control+</p>+<p>To summarize, take a look at the code in <a href="/src/MultiExample1.hs">MultiExample1.hs</a>+as a starter. Notice that all you need to do is feed a Proxy to startSystemStateMultimaster and then call simpleHTTP as normal. The back end of Happstack.State takes care of the rest.</p>+<p>Now we'll talk briefly about <a href="/tutorial/macid-data-safety">MACID safety</a>.</p>
templates/prerequisites.st view
@@ -3,25 +3,13 @@ <p>For best results with this tutorial, you hopefully have the following.</p> <ul>- <li>Basic knowledge of Haskell and html.</li>- <li>A somewhat modern computer. I have a PIII laptop with 512M of ram. </li>- <li>A modern operating system. You should be able to develop Happstack applications using Windows, OS X, or Linux.- <ul>- <li> Happstack-server 0.1 does not currently build on Windows, but this is considered a bug and will - be rectified soon.- </ul>- - <li>If you want to create a public web site based on the materials here, I recommend getting either a private server (more expensive) or a virtual private server (less expensive) which gives you admin privileges to install the packages and software you need. I use the cheapest virtual private server plan at <a href="http://www.linode.com">linode</a> to host this tutorial publicly. I wouldn't try hosting a Happstack project publicly using a shared hoster like <a href="http://www.dreamhost.com">dreamhost</a> that doesn't give you root powers to administer your server. (Dreamhost is great for other things, like cheap storage for online images.)</li>+ <li>Basic knowledge of Haskell and HTML.</li>+ <li>A somewhat modern computer. This tutorial has been run on as little as a PIII with 512 MB of RAM.</li>+ <li>A modern operating system. You should be able to develop Happstack applications using Windows, OS X, or Linux.</li>+ <li>If you want to create a public web site based on the materials here, I recommend getting either a private server or a virtual private server which gives you admin privileges to install the packages and software you need.</li> <li>More requirements are described in the instructions for- <a href="/tutorial/run-tutorial-locally">installing and running this tutorial locally</a>.- However, if you have the basics ingredients above you should be okay.+ <a href="/tutorial/run-tutorial-locally">installing and running this tutorial locally</a>. However, if you have the basics ingredients above you should be okay. </li>- <li>Please let me know -- or patch the tutorial -- if I forgot something. I hate getting stuck on some finicky aspect of installation when I am trying to learn something.</li> </ul> <p><a href="/tutorial/run-tutorial-locally">Install me already!</a></p>--- --</ul>
templates/runtutoriallocally.st view
@@ -1,70 +1,47 @@ <h3>Run This Tutorial Locally</h3> -<p> Before going further, you may want to inform yourself about the <a href=/tutorial/prerequisites>basic prerequisites</a>, both knowledge and equipment, you need to make the best use of this tutorial </p>+<p> Before going further, you may want to inform yourself about the <a href=/tutorial/prerequisites>basic prerequisites</a>, both knowledge and equipment, you need to make the best use of this tutorial. </p> <p>This tutorial is cabalized. You can install it, and chase down all the Happstack dependencies it needs, simply by doing -<p>cabal install happs-tutorial--<p><font color=orange>Unfortunately, the above statement is false on ghc 6.10.1 at the moment, because - <br>the crypto package won't cabal install out of the box. You can build crypto first by doing - <br>darcs get http://code.haskell.org/crypto- <br>cd crypto- <br>cabal install- <br>When ghc 6.10.2 is released the hackage version of Crypto should build right out of the box</font>--<p>If you've never used cabal install or need more detailed info....</p>+<p>cabal install happs-tutorial</p> -<ul>- <li>Haskell: I use ghc 6.10.1, and suggest you do too. - I installed this with with apt-get install haskell (works for ubuntu hardy heron), and then <a href="http://www.haskell.org/ghc/download.html">upgraded to ghc 6.10.1</a>.</li> - <li>Dependency chasing haskell package installers: you should have the latest versions of cabal and cabal install from <a href="http://hackage.haskell.org/packages/archive/pkg-list.html">hackage</a>. These are already included in the latest version of ghc, or they will be soon. I have - <br>cabal --version- <br>cabal-install version 0.6.0- <br>using version 1.6.0.1 of the Cabal library - <br>The latest version of cabal is a bit tricky to install. What I did was start with ghc 6.10.1 and then- download the tar file of the latest version of cabal from hackage, unzip that and run bootstrap.sh.+<p>If you've never used cabal install or need more detailed info see the <a href="http://hackage.haskell.org/trac/hackage/wiki/CabalInstall">cabal install</a> homepage.</p> -</li>- <li>If you want to check out the latest version of this tutorial, install <a href="http://www.darcs.net">Darcs</a> and check out the repo with darcs get http://patch-tag.com/publicrepos/happstack-tutorial</li>-</ul>+<p>If you want to use the latest version of this tutorial, install <a href="http://www.darcs.net">Darcs</a> and check out the repo with darcs get http://patch-tag.com/publicrepos/happstack-tutorial.</p> <p>The reason I cabalized happs-tutorial was for the dependency chasing you get with cabal install,-not for actually running it.+not for actually running it.</p> <p>Cabal installs an executable somewhere that you can run, but the tutorial pages won't display because the executable needs template files to display pages correctly. To actually run the tutorial locally, copy the -happs-tutorial.tar.gz distribution file that cabal downloaded -- probably somewhere under ~/.cabal if you're on linux: +happs-tutorial.tar.gz distribution file that cabal downloaded -- probably somewhere under ~/.cabal if you're on linux.+ The following command </p> -<p><i>find ~/.cabal | grep -i happs-tutorial</i>+<p><i>find ~/.cabal | grep -i happs-tutorial</i> </p> -<p>should show you a tar file. Or you can just download the tar file from+<p>should show you a tar file. Otherwise, you can just download the tar file from <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/happs-tutorial">hackage</a>.-Once you have the tar file, untar this somewhere, cd into that, build and run here as described below.-Or, you could darcs get happs-tutorial and run there. +Once you have the tar file, untar this somewhere, cd into that, build and run here as described below. Finally, you could darcs get happs-tutorial and run there.</p> -<p>To run the app, either do ./hackInGhci.sh and then execute runInGhci inside Main.hs or run the happs-tutorial- executable created by cabal install, with the caveat that you do need to be in the base directory of happs-tutorial.+<p>To run the app, either do ./hackInGhci.sh and then execute runInGhci inside Main.hs or run the happs-tutorial executable created by cabal install, with the caveat that you do need to be in the base directory of happs-tutorial. You shouldn't need to run inside of ghci, but the option is available.-<p>-Shutdown with ctrl-c.+<p>Suggested runtime options: <i>happs-tutorial 5001 True True</i></p>+<p>Shutdown with ctrl-c.</p> <p>-You should now be able to browse this tutorial offline by running the executable, and opening http://localhost:5001 in your browser.+You should now be able to browse this tutorial offline by running the executable, and opening http://localhost:5001 in your browser.</p> -<p>Every so often, when starting via runInGhci, you may get an error message like:+<p>Every so often, when starting via runInGhci, you may get an error message like:</p> <p>*Main> runInGhci happs tutorial running in ghci. exit :q ghci completely and reenter ghci, before restarting. *** Exception: _local/happs-tutorial_state/events-0000000006: openFile: resource busy (file is locked)--<p>Don't worry about it. Every time I get this error I simply run runInGhci again, and the second time it always works.--<p>As far as I know, this issue does not occur when you run the tutorial from a compiled executable, which is of course- how you should be running for a production application.+</p> -<p>-You may also want to <a href="start-happstack-on-boot">start Happstack on boot</a>.+<p>Don't worry about it. Every time I get this error I simply run runInGhci again, and the second time it always works.</p> -<p>Next up is the <a href="/tutorial/main-function">Happstack server main function</a>.</p>+<p>This issue does not occur when you run the tutorial from a compiled executable, which is of course how you should be running for a production application.</p>+<p>You may also want to <a href="start-happstack-on-boot">start Happstack on boot</a>.</p> +<p>Next up is a first example of using <a href="/tutorial/your-first-happstack">Happstack</a>.</p>
templates/templatesdontrepeatyourself.st view
@@ -5,7 +5,7 @@ <p>This is why you need a templating system.</p> -<p>Happstack doesn't care much what templating system you use. I use the+<p>Again, Happstack doesn't care much what templating system you use. I use the <a href="http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HStringTemplate">HStringTemplate</a> package to get the job done, so that's the syntax you'll be seeing in what follows. </p>
templates/toc.st view
@@ -3,23 +3,24 @@ , ("/tutorial/getting-started","getting started with happstack") , ("/tutorial/prerequisites","prerequisites") , ("/tutorial/run-tutorial-locally","cabal install me")- , ("/tutorial/main-function","main")+ , ("/tutorial/your-first-happstack","first shot at happstack") , ("/tutorial/basic-url-handling", "url handling")+ , ("/tutorial/basic-html","basic HTML inclusion") , ("/tutorial/templates-dont-repeat-yourself","templates") , ("/tutorial/stringtemplate-basics","stringtemplate basics") , ("/tutorial/debugging","debugging") , ("/tutorial/get-and-post","form data: get and post") , ("/tutorial/file-uploads","form data: file uploads") , ("/tutorial/cookies","cookies")- , ("/tutorial/introductiontomacid","introduction to macid") + , ("/tutorial/introductiontomacid","introduction to macid")+ , ("/tutorial/yourfirstmacid","first steps with macid")+ , ("/tutorial/multimaster", "scaling with multimaster") , ("/tutorial/macid-data-safety","using macid safely") , ("/tutorial/macid-dummy-data","macid dummy data")- , ("/tutorial/macid-updates-and-queries","macid updates and queries") , ("/tutorial/macid-migration","changing the data model") , ("/tutorial/macid-stress-test","macid stress test") , ("/tutorial/macid-limits","limitations of macid") , ("/tutorial/foreignchars","foreign characters") , ("/tutorial/start-happstack-on-boot","cron jobs") , ("/tutorial/thanks","thanks")- , ("/tutorial/ghci-floundering-askdatastore","appendix (floundering in ghci)")-]+ , ("/tutorial/ghci-floundering-askdatastore","appendix (floundering in ghci)")]
templates/whyhappstackiscool.st view
@@ -2,31 +2,26 @@ <p>There are a lot of advantages to programming in a typed functional language like Haskell. Certain bugs, like misuse of global variables, are virtually impossible unless you bend over backwards- to do things wrong. Code tends to be incredibly short, and modular. The haskell community is very + to do things wrong. Code tends to be incredibly short, and modular. The Haskell community is very friendly, and with coders in every time zone the #haskell irc channel seems well populated seemingly 24 hours a day.</ p> -<p>But we're here to talk about Happstack, not Haskell.</ p>+<p>However, in this tutorial we'll be talking about Happstack, not Haskell in general.</ p> <p>Happstack has its origins in the HAppS project. Happstack is a successor to HAppS under the -leadership of Matthew Elder and the work of the Happstack team</ p>+leadership of Matthew Elder and the work of the Happstack team.</ p> -<p>What got me interested in HAppS was a strongly held feeling that as-modern software systems tend toward ever increasing complexity,+<p>An argument for Happstack is that as modern software systems tend toward ever increasing complexity, database usage is an unnecessary source of complication that-<a href=http://gilesbowkett.blogspot.com/2007/05/sql-unnecessary-in-haskells-happs.html>should be factored out</a> where possible.+<a href=http://gilesbowkett.blogspot.com/2007/05/sql-unnecessary-in-haskells-happs.html>should be factored out</a> where possible.</p> <p>Ruby's <a href="http://rubyonrails.com/">Rails</a> and Python's <a href="http://www.djangoproject.com">Django</a> have become popular largely because of their <a href="http://en.wikipedia.org/wiki/Object-relational_mapping">object relational mapping</a> systems, which hide the complexity of database engines by converting application data manipulation logic into sql. When I first used an ORM, it felt like a huge improvement over writing sql statements every time I wanted to manipulate-an application's state. But pretty soon ORMs started seeming hackish to me too. At some point,+an application's state. Pretty soon ORMs started seeming hackish to me too. At some point, the metaphors I wanted to use just <a href="http://en.wikipedia.org/wiki/Object-Relational_impedance_mismatch">broke down</a>. --$!Or to put it another way, that <a-href=http://gilesbowkett.blogspot.com/2007/05/sql-unnecessary-in-haskells-happs.html>sql-is an ugly hack</a>. !$ <p> Happstack is Haskell's answer to Rails and Django (and Perl's <a href="http://www.catalystframework.org/">Catalyst</a>, and <a href="http://www.php.net">PHP</a>).@@ -37,25 +32,22 @@ transparently using <a href="http://www.google.com/search?q=scrap+your+boilerplate">powerful</a> machinery</a> that's running <a href="http://www.haskell.org/th/">behind the- scenes</a>. And if there are existing databases that you need to connect to, you can do that too - -- you're not locked in to using macid for everything.+ scenes</a>. If there are existing databases that you need to connect to, you can do that too + -- you're not locked in to using Happstack's state management system, MACID, for everything.</p> -<p>MACID,-the Happstack storage mechanism, is no vanilla serialization layer that will-start acting in weird ways when an application has many concurrent users doing possibly conflicting things. -By <a href="http://research.microsoft.com/~simonpj/papers/stm/">leveraging Haskell's type system</a> -(see composable memory transactions paper),-you get the same <a href="http://en.wikipedia.org/wiki/ACID">ACID</a> guarantees that-normally only come with a database. </p>+<p>Still, MACID is no vanilla serialization layer that will+start acting in weird ways when an application has many concurrent users doing possibly conflicting things. +By leveraging Haskell's type system, you get the same +<a href="http://en.wikipedia.org/wiki/ACID">ACID</a> guarantees that normally only come with a database.</p> -<p>There are some <a href="/tutorial/macid-stress-test">limitations</a> to using macid +<p>There are some <a href="/tutorial/macid-stress-test">limitations</a> to using MACID as a datastore that you should familiarize yourself with if you are looking into using Happstack for heavy-usage transactional applications.- But long term, Happstack with macid looks promising enough that the original author started+ In the long term, Happstack with MACID looks promising enough that the original author started using it as a platform for building commercial web 2.0 type apps such as- <a href=http://www.patch-tag.com>patch-tag</a>+ <a href=http://www.patch-tag.com>patch-tag</a>.</p> -<p>In short, Happstack is awesome, and webmonkeys everywhere should use it.+<p>In short, Happstack is awesome, and webmonkeys everywhere should use it.</p> -<p>Let's get <a href="/tutorial/getting-started">started</a>.+<p>Let's get <a href="/tutorial/getting-started">started</a>.</p>
+ templates/yourfirsthappstack.st view
@@ -0,0 +1,86 @@+<h3>A first application with Happstack</h3>++<p>Before we dive straight into the code that actually runs this tutorial, I want to take some time to walk+you through the very basics of writing & running a Happstack application.</p>++<p>So first, fire up that trusty GHCi and import Happstack.Server. Then follow along with the steps below.+<br>+<br>ghci>:i simpleHTTP+<br>simpleHTTP :: (ToMessage a) => Conf -> ServerPartT IO a -> IO ()+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>ghci>:i Conf+<br>data Conf+<br> = Conf {port :: Int, validator :: Maybe (Response -> IO Response)}+<br> -- Defined in Happstack.Server.HTTP.Types+<br>ghci> simpleHTTP (Conf 8080 Nothing) (return "Hello World!")+</p>+<p>Now if you check your localhost:8080 you should see the text "Hello World!". Congratuations, you've now succesfully written & run a Happstack application. Now we'll take a little bit of time and explain what just happened.</p>++<p>First, look again at the type of simpleHTTP. Conceptually, we can already take a stab at what this means. simpleHTTP is a function that will take in a Conf and handler and then run the Happstack webserver. +A Conf is, as can be seen, a fairly simple data type. It consists of the port number to listen on and a default validator to use for the application. We'll come back to using validators in a future chapter, but for now let's just say that they can be a convenient debugging tool and probably not something you want to use in a live application.</p>+<p>Now let's take a look at what makes up a ServerPartT:+<br>ghci>:i ServerPartT +<br>newtype ServerPartT m a+<br> = ServerPartT {unServerPartT :: ReaderT Request (WebT m) a}+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => Monad (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => Functor (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => MonadPlus (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] MonadTrans ServerPartT+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (MonadIO m) => MonadIO (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m, MonadReader r m) => MonadReader r (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m, MonadError e m) => MonadError e (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => Monoid (ServerPartT m a)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => ServerMonad (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => WebMonad Response (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m) => FilterMonad Response (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+<br>instance [overlap ok] (Monad m, Functor m) => Applicative (ServerPartT m)+<br> -- Defined in Happstack.Server.SimpleHTTP+</p>+<p>My Goodness! That's a lot of instances! Some important ones we'll be using+are the <i>Monoid</i>, <i>Functor</i>, <i>MonadIO</i>, and <i>MonadTrans</i>+instances. The others will transparently enable much of the machinery of +Happstack but don't require us to actively think about them.</p>+<p>I want to make one final note about simpleHTTP: did you notice the type restriction+(ToMessage a) on the return type of the ServerPartT? Let's again whip out ghci and+take a look at this class.</p>+<p>ghci>:i ToMessage+<br>class ToMessage a where+<br> toContentType :: a -> Data.ByteString.Internal.ByteString+<br> toMessage :: a -> Data.ByteString.Lazy.Internal.ByteString+<br> toResponse :: a -> Response+</p>+<p>You many not need to call these methods explicitly for your own applications,+but the ToMessage instance for the return type of your ServerPartT is going+to determine how your handler's response will be displayed.</p>+<p>The minimal complete definition of ToMessage is toMessage. The default content type+will be "text/plain".</p> +<p>Now, we'll move on to a slightly more complicated example and the slightly+uglier cousin of simpleHTTP: simpleHTTP'</p>+<p>ghci>:i simpleHTTP'+<br>(Monad m, ToMessage b) => (m (Maybe (Either Response a, FilterFun Response)) -> IO (Maybe (Either Response b, FilterFun Response)))+<br>-> Conf+<br>-> ServerPartT m a+<br>-> IO ()+</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>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)+function, hence the state is restarted every time.+</p>+<p>This example isn't the most useful because of its simplicity, but for complicated computations in the request handling the ability to have an inner monad other than IO can be convenient.</p>+<p>Next we'll be talking about a number of the conveniant combinators in an extended <a href="/tutorial/basic-url-handling">example</a>.</p>
+ templates/yourfirstmacid.st view
@@ -0,0 +1,14 @@+<h3>Your first applications with Happstack.State</h3>+<p>Now we're getting into the very basics of how to make an application with Happstack.State.</p>+<p>Take a look at the application defined in <a href="/src/FirstMacid.hs">FirstMacid.hs</a>, read+the comments, and copy it somewhere you feel comfortable running it.</p>+<p>Play with it at the command prompt for a bit. Choose various values to add to the state.+Close the program, and then reload it. Check the state and everything should be saved right where+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>Next we'll talk about creating +<a href="/tutorial/multimaster">distributed</a> applications using Happstack.State.