happs-tutorial-0.3: src/Session.hs

{-# LANGUAGE TemplateHaskell, FlexibleInstances, FlexibleContexts, 
             MultiParamTypeClasses, DeriveDataTypeable, TypeFamilies,
             TypeSynonymInstances #-}

module Session where  

import qualified Data.Map as M
import Control.Monad.Reader
import Control.Monad.State (modify,put,get,gets)
import Data.Generics
import HAppS.State
import SessionState
import UserState

  
data TutorialState = TutorialState {                                                                        
  sessions :: Sessions SessionData,                                                         
  users :: M.Map String User
} deriving (Show,Read,Typeable,Data)                                                        

instance Version TutorialState                                                                      

$(deriveSerialize ''TutorialState)                                                                  

instance Component TutorialState where                                                              
  type Dependencies TutorialState = End                                                             
  initialValue = TutorialState { sessions = (Sessions M.empty),
                         users = M.empty }                                           

authUser :: String -> String -> Query TutorialState Bool  
authUser name pass = do
  users <- askUsers
  return $ (Just pass) == liftM password (M.lookup name users)


askUsers :: Query TutorialState (M.Map String User)                                    
askUsers = return . users =<< ask

askSessions :: Query TutorialState (Sessions SessionData)
askSessions = return . sessions =<< ask

modUsers :: ( M.Map String User -> M.Map String User ) -> Update TutorialState ()
modUsers f = modify (\s -> (TutorialState (sessions s) (f $ users s)))                              



modSessions :: (Sessions SessionData -> Sessions SessionData) -> Update TutorialState ()
modSessions f = modify (\s -> (TutorialState (f $ sessions s) (users s)))                           

isUser :: String -> Query TutorialState Bool
isUser name = liftM (M.member name) askUsers                                                


addUser :: String -> User -> Update TutorialState ()
addUser name u = modUsers $ M.insert name u                                                 



listUsers :: Query TutorialState [String]
listUsers = liftM M.keys askUsers

newSession :: SessionData -> Update TutorialState SessionKey
newSession u = do
  key <- getRandom
  modSessions $ Sessions . (M.insert key u) . unsession
  return key

delSession :: SessionKey -> Update TutorialState ()
delSession sk = modSessions $ Sessions . (M.delete sk) . unsession


getSession::SessionKey -> Query TutorialState (Maybe SessionData)
getSession key = liftM (M.lookup key . unsession) askSessions

numSessions :: Query TutorialState Int
numSessions  =  liftM (M.size . unsession) askSessions

-- define types which are upper case of methods below, eg AddUser, AuthUser...
-- these types work with HApppS query/update machinery
-- in ghci, try :i AddUser
$(mkMethods ''TutorialState
    ['addUser
     ,'authUser
     ,'isUser
     , 'listUsers
     , 'getSession
     , 'newSession
     , 'delSession
     , 'numSessions]
 )