happs-tutorial-0.1: src/Model.hs

module Model where

import Control.Monad
import HAppS.State
import HAppS.Server
import Session
import Misc
import View

-------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")

entryPoint :: Proxy State
entryPoint = Proxy

-- handlers that affect state
loginPage (UserAuthInfo user pass) = [anyRequest $ do
  allowed <- query $ AuthUser user pass
  if allowed
    then performLogin user
    else msgToWeb "Incorrect password"
  ]

performLogin user = do
  key <- update $ NewSession (SessionData user)
  addCookie (-1) (mkCookie "sid" (show key))
  msgToWeb $ "UserAuthInfo: " ++ show (user)

checkAndAdd user pass = do
  exists <- query $ IsUser user
  if exists
    then msgToWeb $ "User already exists"
    else do
      update $ ( AddUser user $ User user pass )
      msgToWeb $ "User created."

viewPage (Just sid) = [anyRequest $ do
  ses <- query $ (GetSession $ sid)
  ( ( ioMsgToWeb . withBaseContentW ) $ "Cookie value: " ++ (maybe "not logged in" show (ses :: Maybe SessionData)) :: WebT IO Response)]
viewPage Nothing =
  [ msgToSp "Not logged in"]

newUserPage (NewUserInfo user pass1 pass2)
  | pass1 == pass2 = [anyRequest $ do (checkAndAdd user pass1)]
  | otherwise = [ msgToSp "Passwords did not match"]

userListPage :: [ServerPartT IO Response]
userListPage = [anyRequest $ do u <- query ListUsers
                                ( ioMsgToWeb . withBaseContentW ) $ "Users: " ++ (show u)]