happs-tutorial-0.6.4: src/ControllerMisc.hs

module ControllerMisc where

import HAppS.Server

import Misc

import View
import StateVersions.AppState1
import Text.StringTemplate
import System.Directory (doesFileExist)

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 )

-- 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' :: (MonadIO m) => RenderGlobals -> UserName -> String -> WebT m Response
startsess' ( RenderGlobals origRq ts _ ) user landingpage = do  
  let sd = SessionData user
  key <- update $ NewSession sd
  addCookie 3600 (mkCookie "sid" (show key))
  return $ RenderGlobals origRq ts (Just sd) 
  --let lp = getLandingpage origRq
  --return () 
  redirectToUrl landingpage 

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




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"

avatarimage un = do
  uap <- urlavatarpath un
  return $ simpleImage (uap,(B.unpack . unusername $ un) ++ " image") ("100","100")
  where 
    urlavatarpath un = do
      let p = writeavatarpath $ un
      e <- doesFileExist p
      if e
        then return $ "/" ++ p
        else return $ "/static/defaultprofileimage.png"

writeavatarpath un = "userdata/" ++ ( B.unpack . unusername $ un) ++ "/" ++ "profileimage"