happs-tutorial-0.6.0: src/Controller.hs

{-# 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 = "<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)"