{-# 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
-- 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
-- SPs: ServerParts
-- main controller
controller :: Bool -> [ServerPartT IO Response]
controller allowStressTests = {- debugFilter $ -} map cookieFixer $
( tutorial allowStressTests ) ++ simpleHandlers ++ [ myFavoriteAnimal ] ++ staticfiles
++ [ msgToSp "Quoth this server... 404." ]
tutorial :: Bool -> [ServerPartT IO Response]
tutorial allowStressTests = [ ServerPartT $ \rq -> do
ts <- liftIO getTemplates
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
]
tutorialCommon :: Bool -> RenderGlobals -> [ServerPartT IO Response]
tutorialCommon allowStressTests rglobs =
[ exactdir "/" [ ServerPartT $ \_ -> ( 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 <- safeRead numusers
stressTest' insertf n rglobs
else return $ tutlayoutU rglobs [("errormsg", failmsgStressTest)] "errortemplate"
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)"
staticfiles = [ staticserve "static"
, staticserve "userdata"
, browsedir "projectroot" "."
, browsedirHS "templates" "templates"
, browsedirHS "src" "src"
]
staticserve d = dir d [ fileServe [] d ]