diff --git a/happs-tutorial.cabal b/happs-tutorial.cabal --- a/happs-tutorial.cabal +++ b/happs-tutorial.cabal @@ -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 diff --git a/src/Controller.hs b/src/Controller.hs --- a/src/Controller.hs +++ b/src/Controller.hs @@ -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 ] - diff --git a/src/ControllerBasic.hs b/src/ControllerBasic.hs --- a/src/ControllerBasic.hs +++ b/src/ControllerBasic.hs @@ -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") diff --git a/src/ControllerMisc.hs b/src/ControllerMisc.hs --- a/src/ControllerMisc.hs +++ b/src/ControllerMisc.hs @@ -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" diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/View.hs b/src/View.hs --- a/src/View.hs +++ b/src/View.hs @@ -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" diff --git a/templates/base.st b/templates/base.st --- a/templates/base.st +++ b/templates/base.st @@ -8,8 +8,6 @@ - - $ headerarea $
diff --git a/templates/googleanalytics.st b/templates/googleanalytics.st --- a/templates/googleanalytics.st +++ b/templates/googleanalytics.st @@ -3,7 +3,7 @@ document.write(unescape("%3Cscript src='" + gaJsHost + "google-analytics.com/ga.js' type='text/javascript'%3E%3C/script%3E")); +} catch(err) {} diff --git a/templates/home.st b/templates/home.st --- a/templates/home.st +++ b/templates/home.st @@ -16,7 +16,7 @@ database usage is an unnecessary source of complication that should be factored out where possible. -

Ruby's rails and python's django have become popular largely because of their object relational mapping systems, +

Ruby's rails and python's django have become popular largely because of their object relational mapping 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, diff --git a/templates/mainfunction.st b/templates/mainfunction.st --- a/templates/mainfunction.st +++ b/templates/mainfunction.st @@ -4,7 +4,9 @@

In particular, notice the line -

smartserver (Conf p Nothing) "happs-tutorial" (controller allowStressTests) stateProxy +

smartserver (Conf p Nothing) "happs-tutorial" + (controller tDirGroups dynamicTemplateReload allowStressTests) + stateProxy

This is a library function, which can be looked up via the ghci info directive (or i for short):
@@ -24,7 +26,11 @@ at the executable name, which in the case of ghci is something weird.)

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.

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.

$ tocarea $