{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}
module Controller where
import Control.Monad
import Control.Monad.Trans
import Data.List
import qualified Data.Map as M
import qualified Data.Set as S
import Data.Maybe
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
import View
import ControllerBasic
import ControllerPostActions
import ControllerGetActions
import ControllerMisc
import ControllerStressTests
import HAppS.Helpers.DirBrowse
import Misc
--import Debug.Trace
--import Data.ByteString (pack,unpack)
import Data.ByteString.Internal
import HAppS.Server.CookieFixer
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 :: 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." ]
-- 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 tDirGroups mbSess ) rq
]
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 ]
, 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" $
[ dir "login" [ methodSP POST $ loginPage rglobs ]
, dir "newuser" [ methodSP POST $ newUserPage rglobs ]
-- , dir "upload" [ methodSP POST $ uploadFilePage rglobs ]
]
, dir "initializedummydata" [ spAddDummyData rglobs ]
, dir "stresstest"
[ -- more realistic, higher stress
dir "atomicinserts" [ spStressTest allowStressTests ("atomic inserts",atomic_inserts) rglobs]
-- faster, insert all users and all jobs in one transaction
-- fast for small numbers of users, but slow for >1000
, dir "onebiginsert" [ spStressTest allowStressTests ("one big insert",insertus) rglobs]
, dir "atomicinsertsalljobs" [ spStressTest allowStressTests ("atomic inserts, all jobs at once",insertusAllJobs) rglobs]
]
, spJustShowTemplate rglobs
] ]
spJustShowTemplate rglobs = lastPathPartSp0 (\_ tmpl -> return $ tutlayoutU rglobs [] tmpl )
spStressTest allowStressTest insertf rglobs =
if allowStressTest
then lastPathPartSp0 $ \_ numusers -> do
n <- Misc.safeRead numusers
stressTest' insertf n rglobs
else return $ tutlayoutU rglobs [("errormsg", failmsgStressTest)] "errortemplate"
failmsgStressTest = "
-- Stress is blocked from happening on this happs server.\
\
-- For your own stress testinr, run like ./happs-tutorial 5001 True (the second arg controls the stress test)"