happs-tutorial 0.5.1 → 0.6.0
raw patch · 10 files changed
+107/−67 lines, 10 filesdep +DebugTraceHelpers
Dependencies added: DebugTraceHelpers
Files
- happs-tutorial.cabal +2/−2
- src/Controller.hs +47/−20
- src/ControllerBasic.hs +1/−1
- src/ControllerMisc.hs +15/−8
- src/Main.hs +12/−9
- src/View.hs +18/−19
- templates/base.st +0/−2
- templates/googleanalytics.st +3/−3
- templates/home.st +1/−1
- templates/mainfunction.st +8/−2
happs-tutorial.cabal view
@@ -1,5 +1,5 @@ Name: happs-tutorial-Version: 0.5.1+Version: 0.6.0 Synopsis: A HAppS Tutorial that is is own demo Description: A nice way to learn how to build web sites with HAppS @@ -44,7 +44,7 @@ Build-Depends: base>=3.0.3.0, HStringTemplate, HStringTemplateHelpers, mtl, bytestring, HAppS-Server, HAppS-Data, HAppS-State, containers, pretty, pureMD5, directory, filepath, hscolour >= 1.10.1, HTTP, safe,- old-time, parsec, HAppSHelpers+ old-time, parsec, HAppSHelpers, DebugTraceHelpers
src/Controller.hs view
@@ -8,13 +8,15 @@ import qualified Data.Map as M import qualified Data.Set as S import Data.Maybe -import HAppS.Server+import HAppS.Server import HAppS.State import Text.StringTemplate import System.FilePath import System.Directory import Data.Char+import Debug.Trace.Helpers +import HSH -- state import StateVersions.AppState1@@ -28,32 +30,66 @@ import HAppS.Helpers.DirBrowse import Misc -import Debug.Trace+--import Debug.Trace --import Data.ByteString (pack,unpack) import Data.ByteString.Internal import HAppS.Server.CookieFixer+import Text.StringTemplate.Helpers -- SPs: ServerParts ++staticfiles = [ staticserve "static"+ , staticserve "userdata"+ , browsedir "projectroot" "."+ , browsedirHS "templates" "templates"+ , browsedirHS "src" "src" + ] + where staticserve d = dir d [ fileServe [] d ]+ -- main controller-controller :: Bool -> [ServerPartT IO Response]-controller allowStressTests = {- debugFilter $ -} map cookieFixer $ - ( tutorial allowStressTests ) ++ simpleHandlers ++ [ myFavoriteAnimal ] ++ staticfiles +controller :: STDirGroups String -> Bool -> Bool -> [ServerPartT IO Response]+controller tDirGroups dynamicTemplateReload allowStressTests = map cookieFixer $ + -- 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,+ -- but has the problem when staticfiles handler goes after tutorial handler)+ -- Also interesting: the order doesn't matter when dynamicTemplateReload is false+ -- This still feels to me like a bug: it was quite a headache to diagnose, and why should+ -- 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." ] -tutorial :: Bool -> [ServerPartT IO Response]-tutorial allowStressTests = [ ServerPartT $ \rq -> do- ts <- liftIO getTemplates+-- with diretoryGroups (lazy readFile), appkiller.sh causes crash+getTemplateGroups = directoryGroups2 "templates" -- directoryGroups "templates" ++tutorial :: STDirGroups String -> Bool -> Bool -> [ServerPartT IO Response]+tutorial tDirGroups' dynamicTemplateReload allowStressTests = [ ServerPartT $ \rq -> 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.+ 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 ts mbSess ) rq+ unServerPartT ( multi . (tutorialCommon allowStressTests ) $ RenderGlobals rq tDirGroups mbSess ) rq ] +++ tutorialCommon :: Bool -> RenderGlobals -> [ServerPartT IO Response] tutorialCommon allowStressTests rglobs =- [ exactdir "/" [ ServerPartT $ \_ -> ( return . tutlayoutU rglobs [] ) "home" ]+ [ exactdir "/" [ ServerPartT $ \rq -> ( return . tutlayoutU rglobs [] ) "home" ] , dir "tutorial" [ dir "consultants" [ methodSP GET $ viewConsultants rglobs] , dir "consultantswanted" [ methodSP GET $ viewConsultantsWanted rglobs ]@@ -95,7 +131,7 @@ spStressTest allowStressTest insertf rglobs = if allowStressTest then lastPathPartSp0 $ \_ numusers -> do- n <- safeRead numusers+ n <- Misc.safeRead numusers stressTest' insertf n rglobs else return $ tutlayoutU rglobs [("errormsg", failmsgStressTest)] "errortemplate" @@ -105,12 +141,3 @@ -staticfiles = [ staticserve "static"- , staticserve "userdata"- , browsedir "projectroot" "."- , browsedirHS "templates" "templates"- , browsedirHS "src" "src" - ] --staticserve d = dir d [ fileServe [] d ]-
src/ControllerBasic.hs view
@@ -134,7 +134,7 @@ myFavoriteAnimal = exactdir "/usingtemplates/my-favorite-animal" [ ServerPartT $ \rq ->- liftIO $ do templates <- directoryGroupSafer "templates"+ liftIO $ do templates <- directoryGroup "templates" let fp2 :: String fp2 = renderTemplateGroup templates [("favoritePlantTwo","Venus Fly Trap")] "favoritePlant" r = renderTemplateGroup templates [("favoriteAnimal", "Tyrannasaurus Rex")
src/ControllerMisc.hs view
@@ -7,6 +7,7 @@ import View import StateVersions.AppState1 import Text.StringTemplate+import System.Directory (doesFileExist) import HAppS.State import Control.Monad@@ -14,7 +15,7 @@ import Control.Monad.Error import HAppS.Helpers import qualified Data.ByteString.Char8 as B-import Text.StringTemplate.Helpers+--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.@@ -61,13 +62,6 @@ return newuser --- IO action: templates are loaded from templates dir for every handle.--- Alternative is to read templates once at application start time,--- but then if you make changes in the templates dir they won't be reflected unless you stop/start the server--- Option b might be appropriate for situations where there is high traffic and changes to templates rarely happen--- and it's ok to stop/start server if necessary.-getTemplates :: IO (STGroup String)-getTemplates = directoryGroupSafer "templates" logoutPage :: RenderGlobals -> ServerPartT IO Response@@ -81,3 +75,16 @@ ) (getMbSessKey rq) ( return . tutlayoutU newRGlobs [] ) "home"++avatarimage un = do+ uap <- urlavatarpath un+ return $ simpleImage (uap,(B.unpack . unusername $ un) ++ " image") ("100","100")+ where + urlavatarpath un = do+ let p = writeavatarpath $ un+ e <- doesFileExist p+ if e+ then return $ "/" ++ p+ else return $ "/static/defaultprofileimage.png"++writeavatarpath un = "userdata/" ++ ( B.unpack . unusername $ un) ++ "/" ++ "profileimage"
src/Main.hs view
@@ -11,24 +11,27 @@ import StateVersions.AppState1 import System.Time import HAppS.Server.Helpers+import Text.StringTemplate.Helpers main = do- -- let p = 5001 - let usageMessage = "usage example: happs-tutorial 5001 True (starts the app on port 5001, allows stress tests)" args <- getArgs case args of- [port, allowStressTests] -> do+ [port, dynamicTemplateReload', allowStressTests'] -> do p <- safeRead port- allowStressTests <- safeRead allowStressTests- smartserver (Conf p Nothing) "happs-tutorial" (controller allowStressTests) stateProxy- otherwise -> do- putStrLn usageMessage+ allowStressTests <- safeRead allowStressTests'+ dynamicTemplateReload <- safeRead 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, \+ \templates reload dynamically on every request, allows stress tests)" runInGhci = do putStrLn $ "happs tutorial running in ghci. \n" ++ "exit :q ghci completely and reenter ghci, before restarting."- smartserver (Conf 5001 Nothing) "happs-tutorial" (controller True) stateProxy-+ tDirGroups <- getTemplateGroups+ smartserver (Conf 5001 Nothing) "happs-tutorial" (controller tDirGroups True True) stateProxy stateProxy :: Proxy AppState stateProxy = Proxy
src/View.hs view
@@ -14,7 +14,7 @@ import HAppS.Helpers.HtmlOutput import Text.StringTemplate.Helpers import Network.HTTP (urlEncode)-import System.Directory (doesFileExist)+ import Data.Maybe import StateVersions.AppState1 @@ -38,21 +38,28 @@ data RenderGlobals = RenderGlobals { origrq :: Request- , templates :: STGroup String+ , templates :: STDirGroups String -- STGroup String -- STDirGroups String -- , mbSession :: Maybe SessionData } deriving Show ++++++ tutlayout :: RenderGlobals -> [([Char], [Char])] -> String -> String-tutlayout (RenderGlobals rq ts mbSess) attrs tmpl0 = - let tmpl = cleanTemplateName tmpl0+tutlayout (RenderGlobals rq ts' mbSess) attrs tmpl0 = + let ts = getTemplateGroup "." ts'+ tmpl = cleanTemplateName tmpl0 mbU = return . sesUser =<< mbSess rendertut :: [(String,String)] -> String -> String rendertut attrs file = ( renderTemplateGroup ts ) attrs file -- should use readM, or whatever it's called, from Data.Safe --readtut :: (Monad m, Read a) => String -> m a- readtut file = (safeRead . rendertut [] . concatMap escapequote $ file)+ readtut file = (Misc.safeRead . rendertut [] . concatMap escapequote $ file) where escapequote char = if char=='"' then "\\\"" else [char] readTutTuples :: String -> [(String,String)] readTutTuples f = either (const [("readTutTuples error","")]) id@@ -90,12 +97,14 @@ --paintProfile :: RenderGlobals -> String -> UserProfile -> String paintProfile rglobs user cp userimagepath =- let attrs = [("username",user) + let ts = getTemplateGroup "." . templates $ rglobs+ + attrs = [("username",user) , ("userimage", userimagepath ) -- avatarimage (UserName . B.pack $ user) , ("blurb",newlinesToHtmlLines . B.unpack . blurb $ cp) --, ("jobsPosted",paintJobsTable n rglobs $ js) , ("contact", newlinesToHtmlLines . B.unpack . contact $ cp)]- in renderTemplateGroup (templates rglobs) attrs "consultantprofile"+ in renderTemplateGroup ts attrs "consultantprofile" @@ -112,24 +121,14 @@ joblink postedBy j = simpleLink ("/tutorial/viewjob?user="++(B.unpack postedBy)++"&job=" ++ j,j) userlink pBy = simpleLink ("/tutorial/viewprofile?user=" ++ (B.unpack pBy),(B.unpack pBy) ) paintjob rglobs (UserName pBy) (JobName jN, Job jBud jBlu) =- let + 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) , ("jobblurb",B.unpack jBlu) , ("postedBy",userlink pBy)] - in renderTemplateGroup (templates rglobs) attrs "job"+ in renderTemplateGroup ts attrs "job" -avatarimage un = do- uap <- urlavatarpath un- return $ simpleImage (uap,(B.unpack . unusername $ un) ++ " image") ("100","100") -urlavatarpath un = do- let p = writeavatarpath $ un- e <- doesFileExist p- if e- then return $ "/" ++ p- else return $ "/static/defaultprofileimage.png"-writeavatarpath un = "userdata/" ++ ( B.unpack . unusername $ un) ++ "/" ++ "profileimage"
templates/base.st view
@@ -8,8 +8,6 @@ </head> <body>-- $ headerarea $ <div id="content"> <table> <tr> <td valign=top width = 200> $ tocarea $ </td>
templates/googleanalytics.st view
@@ -3,7 +3,7 @@ document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E")); </script> <script type="text/javascript">-var pageTracker = _gat._getTracker("UA-4801425-2");-pageTracker._initData();+try {+var pageTracker = _gat._getTracker("UA-4801425-5"); pageTracker._trackPageview();-</script>+} catch(err) {}</script>
templates/home.st view
@@ -16,7 +16,7 @@ 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. -<p>Ruby's <a href="http://rubyonrails.com/">rails</a> and python's <a href="http://www.djangoproject.com">django</a> have become popular largely because of their <a href="">object relational mapping</a> systems,+<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,
templates/mainfunction.st view
@@ -4,7 +4,9 @@ <p>In particular, notice the line -<p>smartserver (Conf p Nothing) "happs-tutorial" (controller allowStressTests) stateProxy+<p>smartserver (Conf p Nothing) "happs-tutorial"+ (controller tDirGroups dynamicTemplateReload allowStressTests)+ stateProxy <p>This is a library function, which can be looked up via the ghci info directive (or i for short): <br>@@ -24,7 +26,11 @@ at the executable name, which in the case of ghci is something weird.) <p>The third argument tells HAppS what to use as a controller, in the MVC sense.- Basically, how to handle http requests.+ Basically, how to handle http requests. If dynamicTemplateReload is true, HAppS reloads+ reloads the templates from the template directory on every request, otherwise it just does this+ once at app startup. The former is nice for development because you can change content on the fly,+ the latter is better when you want to maximize server performance uner heavy load and the content+ has stabilized. <p>The fourth argument tells happs what data structure to use for application state. We'll cover about the HAppS state system in depth, but later.</p>