happs-tutorial-0.5.0: src/ControllerMisc.hs

module ControllerMisc where

import HAppS.Server

import Misc

import View
import StateVersions.AppState1
import Text.StringTemplate

import HAppS.State
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Error
import HAppS.Helpers
import qualified Data.ByteString.Char8 as B
import Text.StringTemplate.Helpers
--  (User(..))
-- 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
tutlayoutU rglobs attrs tmpl = ( toResponse . HtmlString . tutlayout rglobs attrs ) tmpl

getmbSession :: Request -> IO (Maybe SessionData)
getmbSession rq = maybe ( return Nothing ) ( query . GetSession ) ( getMbSessKey rq )


-- to do: make it so keeps your current page if you login/logout
-- probably modify RenderGlobals to keep track of that bit of state
--startsess' :: RenderGlobals -> UserName -> WebT IO Response

-- The user argument could be bytestring rather than say, UserName, to keep things generic
-- This way we could have different types of users, say UserName users and AdminUserName users.
-- But for now, keep UserName.
startsess' ::
  --(HAppS.Server.SURI.ToSURI uri) =>
  (Request -> String) -> RenderGlobals -> UserName -> WebT IO Response
startsess' getLandingpage (RenderGlobals origRq ts _) user = do
  let sd = SessionData user
  key <- update $ NewSession sd
  addCookie (3600) (mkCookie "sid" (show key))
  let newRGlobs = RenderGlobals origRq ts (Just sd) 
  let lp = getLandingpage origRq
  redirectToUrl lp 

getLoggedInUserInfos :: RenderGlobals -> ErrorT String (WebT IO) (UserName,UserInfos)
getLoggedInUserInfos (RenderGlobals _ _ Nothing) = fail "getLoggedInUserInfos, not logged in"
getLoggedInUserInfos (RenderGlobals _ _ (Just (SessionData uN))) = do
  loggedInUserInfos <- ErrorT . return .
                               maybe (Left $ "bad user" ++ (B.unpack . unusername $ uN)) Right
                                 =<< (query $ GetUserInfos uN)
  return (uN,loggedInUserInfos)


getMbSessKey :: Request -> Maybe SessionKey
getMbSessKey rq = runReaderT (readCookieValue "sid") (rqInputs rq,rqCookies rq)

updateuser olduser newuser = do
  --update (UpdateUser olduser newuser)
  undefined
  return newuser


-- IO action: templates are loaded from templates dir for every handle.
-- Alternative is to read templates once at application start time,
-- but then if you make changes in the templates dir they won't be reflected unless you stop/start the server
-- Option b might be appropriate for situations where there is high traffic and changes to templates rarely happen
-- and it's ok to stop/start server if necessary.
getTemplates :: IO (STGroup String)
getTemplates = directoryGroupSafer "templates"


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