happs-tutorial-0.1: src/Session.hs

{-# OPTIONS -fglasgow-exts #-}
{-# LANGUAGE TemplateHaskell , FlexibleInstances, UndecidableInstances, OverlappingInstances,
             MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}

module Session where  

import qualified Data.Map as M
import Control.Monad
import Control.Monad.Reader
import Control.Monad.State (modify,put,get,gets)
import Data.Generics hiding ((:+:))
import HAppS.Server
import HAppS.State
import HAppS.Data

type SessionKey = Integer                                                                   

data SessionData = SessionData {                                                            
  sesUser :: String
} deriving (Read,Show,Eq,Typeable,Data)                                                     

data Sessions a = Sessions {unsession::M.Map SessionKey a}                                  
  deriving (Read,Show,Eq,Typeable,Data)
  
data State = State {                                                                        
  sessions :: Sessions SessionData,                                                         
  users :: M.Map String User
} deriving (Show,Read,Typeable,Data)                                                        

data User = User {                                                                          
  username :: String,                                                                       
  password :: String
} deriving (Show,Read,Typeable,Data)                                                        

instance Version SessionData                                                                
instance Version (Sessions a)                                                               

$(deriveSerialize ''SessionData)                                                            
$(deriveSerialize ''Sessions)

instance Version State                                                                      
instance Version User

$(deriveSerialize ''User)                                                                   
$(deriveSerialize ''State)                                                                  

instance Component State where                                                              
  type Dependencies State = End                                                             
  initialValue = State (Sessions M.empty) M.empty                                           
  
askUsers :: MonadReader State m => m (M.Map String User)                                    
askUsers = return . users =<< ask

askSessions::MonadReader State m => m (Sessions SessionData)                                
askSessions = return . sessions =<< ask

modUsers f = modify (\s -> (State (sessions s) (f $ users s)))                              
modSessions f = modify (\s -> (State (f $ sessions s) (users s)))                           

isUser name = liftM (M.member name) askUsers                                                

addUser name u = modUsers $ M.insert name u                                                 

authUser name pass = do
  users <- askUsers
  return $ (Just pass) == liftM password (M.lookup name users)

listUsers :: MonadReader State m => m [String]
listUsers = liftM M.keys askUsers

setSession key u = do
  modSessions $ Sessions . (M.insert key u) . unsession
  return ()

newSession u = do
  key <- getRandom
  setSession key u
  return key

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

numSessions:: Proxy State -> Query State Int
numSessions = proxyQuery $ liftM (M.size . unsession) askSessions

$(mkMethods ''State ['addUser, 'authUser, 'isUser, 'listUsers, 'setSession, 'getSession, 'newSession, 'numSessions])