happs-tutorial-0.3: src/Model.hs

{-# OPTIONS -XPatternSignatures -fno-monomorphism-restriction #-}
module Model where

import Control.Monad
import HAppS.State
import HAppS.Server
import Session
import Misc
import SessionState
-- import UserState
import Control.Monad.Trans

-------state
data UserAuthInfo = UserAuthInfo String String
data NewUserInfo = NewUserInfo String String String

instance FromData UserAuthInfo where
    fromData = liftM2 UserAuthInfo (look "username")
                                   (look "password" `mplus` return "nopassword")

instance FromData NewUserInfo where
    fromData = liftM3 NewUserInfo (look "username")
                                  (look "password" `mplus` return "nopassword")
                                  (look "password2" `mplus` return "nopassword2")

-- getMbSessKey rq = readData (readCookieValue "sid") rq
getMbSessKey :: Request -> Maybe SessionKey
getMbSessKey rq | traceTrue "getMbSessKey, rq" = traceWith ( ("sidCookie: " ++) . show ) $ readData (readCookieValue "sid") (traceReadableMsg "rq: " rq)

getmbLoggedInUser :: Request -> IO (Maybe String)
getmbLoggedInUser rq = do
  mbSd <- getMbSessData rq
  return $ do
    sd <- mbSd
    Just . sesUser $ sd

getMbSessData :: Request -> IO (Maybe SessionData)                          
getMbSessData rq = do
  let mbSk = getMbSessKey rq
  maybe ( return Nothing )
        ( query . GetSession )
        mbSk