Session.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  HSP.Data.Session
-- Copyright   :  (c) Niklas Broberg 2004,
-- License     :  BSD-style (see the file LICENSE.txt)
-- 
-- Maintainer  :  Niklas Broberg, d00nibro@dtek.chalmers.se
-- Stability   :  experimental
-- Portability :  requires undecidable and overlapping instances
--
-- Defines the Session object available to HSP pages.
-----------------------------------------------------------------------------
module HSP.Data.Session (
	  Session	-- ^ Abstract
	-- * Functions used in HSP
	, getVarValue	-- ^ :: Session -> Key -> IO (Maybe Value)
	, setVarValue	-- ^ :: Session -> Key -> Value -> IO ()
	, deleteVar	-- ^ :: Session -> Key -> IO ()
	, abandon	-- ^ :: Session -> IO ()
	, setExpires	-- ^ :: Session -> CalendarTime -> IO ()
	-- * Functions used by the RTS
	, isSession	-- ^ :: Session -> IO Bool
	, getSessionId  -- ^ :: Session -> IO (Maybe SessionId)
	, getExpires	-- ^ :: Session -> IO Expires
	, initSession	-- ^ :: [(Key, Value)] -> IO Session
	, noSession	-- ^ :: IO Session
	, getNewVars	-- ^ :: Session -> IO [(Key, (Value, Expires))]
	, getUpdatedVars -- ^ :: Session -> IO [(Key, (Value, Expires))]
	, getDeletedVars -- ^ :: Session -> IO [Key]
	) where

import qualified Data.HashTable as HT
import Control.Concurrent.MVar

import System.Time

-------------------------------------
-- Help types

type Expires = Maybe CalendarTime
type Key = String
type Value = String
type SessionId = Int

neverExpire :: Expires
neverExpire = Nothing

expire :: CalendarTime -> Expires
expire = Just

data Status = New | Orig | Updated | Deleted
	deriving (Eq)

updateStatus :: Status -> Status
updateStatus s = case s of
	New -> New
	_   -> Updated

----------------------------------------
-- The main datatypes

-- | The 'Session' datatype is basically a data repository.
-- To keep tracks of updates, we use an extra repository.
newtype Session = MkSession (MVar (Maybe SessionData))

data SessionData = MkSessionData {
	sessionId :: MVar (Maybe SessionId), 
	expires :: MVar Expires,
	dataRep :: HT.HashTable Key (Value,Expires,Status)
	}

-- | Create a new 'Session' object with initial data.
initSession :: SessionId -> Expires -> [(Key, (Value, Expires))] -> IO Session
initSession sid exps initData = do
	let dat = map (\(k,(v,e)) -> (k,(v,e,Orig))) initData 
	rep <- HT.fromList HT.hashString dat
	exp <- newMVar exps
	si  <- newMVar $ Just sid
	let sd = MkSessionData { 
			dataRep = rep,
			expires = exp, 
			sessionId = si }
	mvSess <- newMVar $ Just sd
	return $ MkSession mvSess

noSession :: IO Session
noSession = do
	mvs <- newMVar Nothing
	return $ MkSession mvs

---------------------------------------
-- Operate on sessions
			 
-- | Retrieve the value of a variable in the repository.
getVarValue :: Session -> Key -> IO (Maybe Value)
getVarValue (MkSession mvSess) k = do
	msess <- takeMVar mvSess
	res <- case msess of
	 	Just sd -> do mv <- HT.lookup (dataRep sd) k
		       	      case mv of
				Nothing -> return Nothing
				Just (v,_,st) | st /= Deleted 
					-> return $ Just v
	 	_ -> return $ Nothing
	putMVar mvSess msess 
	return res

setVarValue :: Session -> Key -> Value -> IO ()
setVarValue (MkSession mvSess) k v = do
	msess <- takeMVar mvSess
	case msess of
	 Nothing -> do 
		dr <- HT.fromList HT.hashString [(k, (v, neverExpire, New))]
		exp <- newMVar neverExpire
		si  <- newMVar Nothing
		putMVar mvSess $ Just $ MkSessionData si exp dr
	 Just sd -> do
		mv <- HT.lookup (dataRep sd) k
		case mv of
		 Nothing -> HT.insert (dataRep sd) k (v, neverExpire, New)
		 Just (_,e,st) -> HT.insert (dataRep sd) k (v, e, updateStatus st)
		putMVar mvSess msess
		
deleteVar :: Session -> Key -> IO ()
deleteVar (MkSession mvSess) k = do
	msess <- takeMVar mvSess
	case msess of
	 Nothing -> return ()
	 Just sd -> HT.delete (dataRep sd) k
	putMVar mvSess msess

abandon :: Session -> IO ()
abandon (MkSession mvs) = modifyMVar_ mvs (\_ -> return Nothing)

setExpires :: Session -> CalendarTime -> IO ()
setExpires (MkSession mvs) ct = do
	msess <- takeMVar mvs
	case msess of
	 Nothing -> do 
		dr <- HT.new (==) HT.hashString
		si <- newMVar Nothing
		exp <- newMVar $ expire ct
		putMVar mvs (Just $ MkSessionData si exp dr)
	 Just sd -> do 
		modifyMVar_ (expires sd) (\_ -> return $ expire ct)
		putMVar mvs msess

-----------------------------------------
-- Used by HSPR

isSession :: Session -> IO Bool
isSession s = withSession s $ \ms ->
	case ms of
	 Nothing -> return False
	 Just _  -> return True


getSessionId :: Session -> IO (Maybe SessionId)
getSessionId s = withSession s $ \ms ->
	case ms of
	 Nothing -> return Nothing
	 Just s  -> readMVar (sessionId s)

getExpires :: Session -> IO Expires
getExpires s = withSession s $ \ms ->
	case ms of
	 Nothing -> return Nothing
	 Just s  -> readMVar (expires s)




getVars :: Status -> Session -> IO [(Key, (Value, Expires))]
getVars status s = withSession s $ \msess ->
	case msess of
	 Nothing -> return []
	 Just sd -> do
		vals <- HT.toList (dataRep sd)
		let newVals = filter (\(_,(_,_,st)) -> st == status) vals
		return $ map (\(k,(v,e,_)) -> (k,(v,e))) newVals

getNewVars, getUpdatedVars :: Session -> IO [(Key, (Value, Expires))]
getNewVars = getVars New
getUpdatedVars = getVars Updated

getDeletedVars :: Session -> IO [Key]
getDeletedVars s = do 
	vals <- getVars Deleted s
	return $ map fst vals


withSession :: Session -> (Maybe SessionData -> IO a) -> IO a
withSession (MkSession mvs) f = do
	ms <- takeMVar mvs
	r <- f ms
	putMVar mvs ms
	return r