hpaste

{-# 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,MonadState)
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 User = User {
  username :: String,
  password :: String
} deriving (Show,Read,Typeable,Data)
data State = State {
  sessions :: Sessions SessionData,
  users :: M.Map String User
} 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 :: MonadState State m =>
            (M.Map String User -> M.Map String User) -> m ()
modUsers f = modify (\s -> (State (sessions s) (f $ users s)))

modSessions :: MonadState State m =>
               (Sessions SessionData -> Sessions SessionData) -> m ()
modSessions f = modify (\s -> (State (f $ sessions s) (users s)))
isUser :: MonadReader State m => String -> m Bool
isUser name = liftM (M.member name) askUsers

addUser :: MonadState State m => String -> User -> m ()
addUser name u = modUsers $ M.insert name u

authUser :: MonadReader State m => String -> String -> m Bool
authUser name pass = do
                     u <- liftM (M.lookup name) askUsers
                     liftM2 (==) (liftM password u) (return pass)

listUsers :: MonadReader State m => m [String]
listUsers = liftM M.keys askUsers
setSession :: (MonadState State m) => SessionKey -> SessionData -> m ()
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])

{-# 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,MonadState)
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 User = User {
  username :: String,
  password :: String
} deriving (Show,Read,Typeable,Data)
data State = State {
  sessions :: Sessions SessionData,
  users :: M.Map String User
} 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 :: MonadState State m =>
            (M.Map String User -> M.Map String User) -> m ()
modUsers f = modify (\s -> (State (sessions s) (f $ users s)))

modSessions :: MonadState State m =>
               (Sessions SessionData -> Sessions SessionData) -> m ()
modSessions f = modify (\s -> (State (f $ sessions s) (users s)))
isUser :: MonadReader State m => String -> m Bool
isUser name = liftM (M.member name) askUsers

addUser :: MonadState State m => String -> User -> m ()
addUser name u = modUsers $ M.insert name u

delUser :: MonadState State m => String -> m ()                                                                                                                          
delUser name = modUsers $ M.delete name                                                                                                                                  
                                                                                                                                                                    
authUser :: MonadReader State m => String -> String -> m Bool
authUser name pass = do
                     u <- liftM (M.lookup name) askUsers
                     liftM2 (==) (liftM password u) (return pass)

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

numUsers ::  MonadReader State m => m Int                                                                                                                                
numUsers = liftM length listUsers                                                                                                                                        

isSession :: MonadReader State m => SessionKey -> m Bool                                                                                                                 
isSession key = liftM ((M.member key) . unsession) askSessions                                                                                                           

setSession :: (MonadState State m) => SessionKey -> SessionData -> m ()
setSession key u = do
  modSessions $ Sessions . (M.insert key u) . unsession
  return ()

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

delSession :: (MonadState State m) => SessionKey -> m ()                                                                                                                 
delSession key = do                                                                                                                                                      
  modSessions $ Sessions . (M.delete key) . unsession                                                                                                                    
  return ()                                                                                                                                                              

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, 'delUser, 'authUser, 'isUser, 'listUsers, 'numUsers,
             'isSession, 'setSession, 'getSession, 'newSession, 'delSession, 'numSessions])

{-# 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,MonadState)
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 User = User {
  username :: String,
  password :: String
} deriving (Show,Read,Typeable,Data)
data State = State {
  sessions :: Sessions SessionData,
  users :: M.Map String User
} 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 :: MonadState State m =>
            (M.Map String User -> M.Map String User) -> m ()
modUsers f = modify (\s -> (State (sessions s) (f $ users s)))

modSessions :: MonadState State m =>
               (Sessions SessionData -> Sessions SessionData) -> m ()
modSessions f = modify (\s -> (State (f $ sessions s) (users s)))
isUser :: MonadReader State m => String -> m Bool
isUser name = liftM (M.member name) askUsers

addUser name u = do
                 exists <- isUser name
                 unless exists $ modUsers $ M.insert name u
                 return exists

delUser :: MonadState State m => String -> m ()                                                                                                                          
delUser name = modUsers $ M.delete name                                                                                                                                  
                                                                                                                                                                    
authUser :: MonadReader State m => String -> String -> m Bool
authUser name pass = do
                     u <- liftM (M.lookup name) askUsers
                     liftM2 (==) (liftM password u) (return pass)

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

numUsers ::  MonadReader State m => m Int                                                                                                                                
numUsers = liftM length listUsers                                                                                                                                        

isSession :: MonadReader State m => SessionKey -> m Bool                                                                                                                 
isSession key = liftM ((M.member key) . unsession) askSessions                                                                                                           

setSession :: (MonadState State m) => SessionKey -> SessionData -> m ()
setSession key u = do
  modSessions $ Sessions . (M.insert key u) . unsession
  return ()

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

delSession :: (MonadState State m) => SessionKey -> m ()                                                                                                                 
delSession key = do                                                                                                                                                      
  modSessions $ Sessions . (M.delete key) . unsession                                                                                                                    
  return ()                                                                                                                                                              

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, 'delUser, 'authUser, 'isUser, 'listUsers, 'numUsers,
             'isSession, 'setSession, 'getSession, 'newSession, 'delSession, 'numSessions])

Powered by HAppS. Copyright (c) 2007 glguy @ #haskell. Source via darcs.