{-# LANGUAGE NoMonomorphismRestriction, ScopedTypeVariables #-}

module Controller where

import Control.Monad.State
import qualified Data.Map as M
import Happstack.Server 
import Text.StringTemplate
import System.FilePath
import Data.Char
import StateVersions.AppState1
import View

import ControllerBasic
import ControllerPostActions
import ControllerGetActions
import ControllerMisc
import ControllerStressTests

import Happstack.Helpers
import Misc 
import Text.StringTemplate.Helpers
import Data.Monoid

staticfiles :: ServerPartT IO Response
staticfiles = msum [ 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      
   `mappend` tutorial tDirGroups dynamicTemplateReload allowStressTests  
   `mappend` simpleHandlers 
   `mappend` myFavoriteAnimal         
   `mappend` (return . toResponse $  "Quoth this server... 404.")

-- with directoryGroupsOld (lazy readFile), appkiller.sh causes crash
-- directoryGroupsHAppS is defined in happstack-helpers.  This is where
-- the assumption that all the templates lie in a subdirectory called
-- templates comes from
getTemplateGroups :: (Stringable a) => IO (M.Map FilePath (STGroup a))
getTemplateGroups = directoryGroupsHAppS "templates" 

tutorial :: STDirGroups String -> Bool -> Bool -> ServerPartT IO Response
tutorial tDirGroups' dynamicTemplateReload allowStressTests = 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.
  rq <- askRq
  tDirGroups <- liftIO $ if dynamicTemplateReload
    then getTemplateGroups 
    else return tDirGroups' 
  
  mbSess <- liftIO $ getmbSession rq
  tutorialCommon allowStressTests  $ RenderGlobals rq tDirGroups mbSess
  
tutorialCommon :: Bool -> RenderGlobals -> ServerPartT IO Response
tutorialCommon allowStressTests rglobs = msum 
   [ exactdir "/" (( return . tutlayoutU rglobs [] ) "home")
     , dir "tutorial" $ msum [
           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) `mappend` 
                                        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" $ msum 
                 [ dir "login" (methodSP POST $ loginPage rglobs)
                   , dir "newuser" (methodSP POST $ newUserPage rglobs) 
                 ]
         , dir "initializedummydata" (spAddDummyData rglobs)
         , dir "stresstest" $ msum 
             [ -- 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 :: (Monad m) => RenderGlobals -> ServerPartT m Response
spJustShowTemplate rglobs = lastPathPartSp0 $ const (return . tutlayoutU rglobs []) 

spStressTest :: (MonadIO m) => Bool -> 
                (String, Users -> WebT m a) -> 
                RenderGlobals -> ServerPartT m Response
spStressTest allowStressTest insertf rglobs = 
  if allowStressTest 
    then lastPathPartSp0 $ \_ numusers -> do
         n <- Misc.safeRead numusers
         withRequest $ const $ stressTest' insertf n rglobs
    else return $ tutlayoutU rglobs [("errormsg", failmsgStressTest)] "errortemplate"

failmsgStressTest :: String
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)"