{-# 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 StateVersions.AppState1
import View
import ControllerBasic
import ControllerPostActions
import ControllerGetActions
import ControllerMisc
import ControllerStressTests
import HAppS.Helpers
import Misc
import Data.ByteString.Internal
import Text.StringTemplate.Helpers
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 =
-- 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 diretoryGroupsOld (lazy readFile), appkiller.sh causes crash
getTemplateGroups = directoryGroupsHAppS "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)"
-- tEmail = runIO $ echo "this is an email" -|- "mailx -s \"O HAI SUBJECT LINE\" thomashartman1@gmail.com"