happs-tutorial-0.4.3: src/Controller.hs

{-# options_ghc -XPatternSignatures -fno-monomorphism-restriction #-}
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 Misc 
import ControllerMisc

import Text.StringTemplate

import System.FilePath

-- colorizing
import System.Directory
import Data.Char
import qualified Language.Haskell.HsColour.HTML as HTML
import Language.Haskell.HsColour.Colourise (readColourPrefs)

-- state
import StateStuff
import ViewStuff

import ControllerBasic
import ControllerPostActions
import ControllerGetActions

import Debug.Trace
--import Data.ByteString (pack,unpack)
import Data.ByteString.Internal 
-- SPs: ServerParts

-- main controller
controller :: [ServerPartT IO Response]
controller = {- debugFilter $ -} 
    tutorial ++ simpleHandlers ++ [ myFavoriteAnimal ] ++ staticfiles 
      ++ [ msgToSp "Quoth this server... 404." ]




fileservedir d = dir d [ fileServe [] d ]


tutorial :: [ServerPartT IO Response]
tutorial = [ ServerPartT $ \rq -> do
  ts <- liftIO getTemplates
  mbUName <- liftIO . getmbLoggedInUser $ rq
  mbU <- case mbUName of
           Nothing -> return Nothing
           Just un -> query . GetUser $ un
                         
  unServerPartT ( multi . tutorialCommon  $ RenderGlobals ts mbU ) rq
  ] 
  
tutorialCommon :: RenderGlobals -> [ServerPartT IO Response]
tutorialCommon rglobs =
   [ exactdir "/" [ ServerPartT $ \_ -> ( return . tutlayoutU rglobs [] ) "home"  ]
     , dir "tutorial" [
           dir "consultants" $ viewConsultants rglobs 
         , dir "consultantswanted" $ viewConsultantsWanted rglobs 
         , dir "jobs"   [ methodSP GET . viewJobs $ rglobs]
         , dir "logout" [ (logoutPage rglobs)] 
         , dir "changepassword" [ methodSP POST $ changePasswordSP rglobs ]

         , dir "editconsultantprofile" [ methodSP GET . viewEditConsultantProfile $ rglobs ]         
         , dir "editconsultantprofile" [ 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 "initializedummydata" [ spAddDummyData rglobs ]
         , dir "actions" $
             [ dir "login" [ methodSP POST . loginPage $ rglobs ]
               , dir "newuser" [ methodSP POST . newUserPage $ rglobs ]
             ]
         , lastPathPartSp0 (\rq tmpl -> ( return . tutlayoutU rglobs []) tmpl ) 
     ]
   ]             

viewConsultants :: RenderGlobals -> [ServerPartT IO Response]
viewConsultants rglobs = [ ServerPartT $ \rq -> do
  consultants :: [String] <- return . map username
                               =<< return . filter (consultant . consultantprofile) . S.toList
                                  =<< query AskDatastore
  let consultantlist =
        paintVMenu . map (\c -> simpleLink (templates rglobs) ("/tutorial/viewprofile?user="++c,c) ) $ consultants
      -- if not logged in, you get an invite to register as a consultant
      -- basically an incentive to register
      tmplattrs = maybe (def ++ [("registerAsConsultant","list yourself as a HAppS developer")])
                        (\_ -> def )
                        (mbUser rglobs)
        where def = [("consultantList", consultantlist)]
  return . tutlayoutU rglobs tmplattrs $ "consultants"
  ]

viewConsultantsWanted :: RenderGlobals -> [ServerPartT IO Response]
viewConsultantsWanted rglobs = [ ServerPartT $ \rq -> do
  consultantswanted :: [String] <- return . map username
                                     =<< return . filter (not . null . jobs) . S.toList
                                       =<< query AskDatastore
  let ulist =
        paintVMenu . map (\c -> simpleLink (templates rglobs) ("/tutorial/viewprofile?user="++c,c) ) $ consultantswanted
      
      -- an incentive to register
      tmplattrs = maybe (def ++ [("postJob","post a HAppS job")])
                        (\_ -> def )
                        (mbUser rglobs)
        where def = [("ulist", ulist)]
  return . tutlayoutU rglobs tmplattrs $ "consultantswanted"
  ]

--logoutPage :: RenderGlobals -> ServerPartT IO Response
logoutPage rglobs@(RenderGlobals ts mbU) = 
  withRequest $ \rq -> do
    let mbSk = getMbSessKey rq
    newRGlobs <-
      maybe 
         ( return rglobs )
         ( \sk -> do update . DelSession $ sk
                     return (RenderGlobals ts Nothing)
         )
         mbSk
    ( return . tutlayoutU newRGlobs [] ) "home" 


spAddDummyData rglobs = do
  withRequest $ \rq -> (update InitializeDummyData) 
  ( return . tutlayoutU rglobs [] ) "home" 

staticfiles = [ haskellFile [withRequest colorize] 
                , fileservedir "src" 
                , fileservedir "static" ] 
  where 
    -- Takes the request and tries to find a file from the current directory
    -- based on the request path. Colorizes the file as Haskell and returns the
    -- HTML.
    colorize rq = do
      currDir <- liftIO $ getCurrentDirectory
      let sep = [pathSeparator] -- eg '/' or '\' or whatever 
          path = intercalate sep ([currDir ++ sep ] ++ rqPaths rq)
      file <- liftIO $ readFile path
      prefs <- liftIO $ readColourPrefs
      let color :: String
          color = HTML.hscolour prefs False False file file
      return . toResponse . HtmlString $ color

    -- Detects if a request ends in a .hs.
    haskellFile = spsIf endsInHS
      where endsInHS rq =
              let url = rqURL rq
                  extension = drop (length url - 3) url
              in extension == ".hs"