happs-tutorial-0.3: src/Controller.hs

{-# OPTIONS_GHC -XPatternSignatures -fno-monomorphism-restriction #-}
module Controller where

import Control.Monad
import Control.Monad.Trans
import Data.List

import HAppS.Server

import Misc 

-- state
import HAppS.State
import Session
import SessionState
import UserState

import View

import Model

import ControllerBasic

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

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


staticfiles = [ fileservedir "src" 
                , fileservedir "static" ] 

fileservedir d = dir d [ fileServe [] d ]


tutorial = [
    exactdir "/" [ tutlayoutSp1 [] "home" ]
    , dir "tutorial" [
        exactdir "/view-all-users" [ viewAllUsers ]
        , lastPathPartSp (\rq tmpl -> ( tutlayoutReq rq []) tmpl ) -- tutlayoutSp [] 
        , dir "actions" [
            dir "login" [ methodSP POST $ withData loginPage  ]
            , dir "newuser" [ methodSP POST $ do withData newUserPage ]
            , dir "logout" [ logoutPage ] 
        ]
      ]
    ]

viewAllUsers = do
  users <- anyRequest $  query ListUsers
  tutlayoutSp1 [("userList", (paint users))] "view-all-users"
  where paint xs = intercalate "<p>" xs

-- A handler that renders a template with the template name specified in the argument
tutlayoutSp1 attrs tmpl = withRequest $ \rq -> ( tutlayoutReq rq attrs ) tmpl 

-- Render a template when the request has exactly one path segment left.
-- The template that gets rendered is that path segment
tutlayoutSp attrs = ServerPartT $ \rq -> 
  case rqPaths rq of
    [tmpl] -> ( tutlayoutReq rq attrs ) tmpl 
    _ -> noHandle

-- The final value is HtmlString so that the HAppS machinery does the right thing with toMessage.
--   If the final value was left as a String, the page would display as text, not html.
tutlayoutReq :: Request -> [([Char], String)] -> String -> WebT IO Response
tutlayoutReq rq attrs tmpl = liftIO $ do
  mbUser <- getmbLoggedInUser rq
  attrs <- return $ maybe attrs (\user -> ("loggedInUser",user):attrs) mbUser
  return . toResponse . HtmlString =<< tutlayout attrs tmpl 

loginPage :: UserAuthInfo -> [ ServerPartT IO Response ] 
loginPage (UserAuthInfo user pass) = [
  ServerPartT $ \rq -> do
    allowed <- query $ AuthUser user pass
    if allowed 
      then do startsess user ( {-traceWith dbg -} rq )
      else ( tutlayoutReq rq [("errormsg","login error: invalid username or password")] ) "home"
  ]
  -- where dbg rq = "loginheaders: " ++ (show . {- rqHeaders -} getHeader "referer" $ rq) 



startsess :: String -> Request -> WebT IO Response
startsess user rq = do
  key <- update $ NewSession (SessionData user)
  addCookie (3600) (mkCookie "sid" (show key)) 
  ( tutlayoutReq rq [("loggedInUser",user)] "home" )

logoutPage :: ServerPartT IO Response
logoutPage = 
  withRequest $ \rq -> do
    let mbSk = getMbSessKey rq
    maybe 
         ( return () )
         ( update . DelSession )
         mbSk
    ( tutlayoutReq rq [] ) "home"   



newUserPage :: NewUserInfo -> [ServerPartT IO Response]
newUserPage (NewUserInfo user pass1 pass2) =
  [ ServerPartT $ \rq -> 
          if pass1 == pass2 
             then do exists <- query $ IsUser user
                     if exists
                          then errW "User already exists" rq
                          else do
                            update $ ( AddUser user $ User user pass1 )
                            startsess user rq
             else errW "passwords did not match" rq
  ]
  where errW msg rq = ( tutlayoutReq rq [("errormsgRegister", msg)] ) "register"