module Network.HTTP.RedHandler.Session (
SessionState,
getSessionedStateWithCookie,
newSessionedStateWithCookie,
updateSessionedStateWithCookie,
deleteSessionedStateWithCookie
) where
import System.IO.Unsafe (unsafePerformIO)
import System.Time
import qualified Data.Map as Map
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar
import Network.HTTP.RedHandler.HTTP_Fork.HTTP
import Network.CGI.Cookie(findCookie, newCookie, showCookie, deleteCookie)
type SessionMap a = TVar (Map.Map String a)
type SessionState = Integer
sessionMap :: SessionMap SessionState
sessionMap = unsafePerformIO $ newTVarIO $ Map.empty
addSession :: SessionState -> IO String
addSession x =
do tok <- getNewToken
updateSession tok x
return tok
where
getNewToken = getClockTime >>= toCalendarTime >>= (return . show . ctPicosec)
updateSession :: String -> SessionState -> IO ()
updateSession tok x =
atomically (readTVar sessionMap
>>= return . Map.insert tok x
>>= writeTVar sessionMap)
readSession :: String -> IO (Maybe SessionState)
readSession tok = atomically (readTVar sessionMap >>= return . Map.lookup tok)
deleteSession :: String -> IO ()
deleteSession tok = atomically (readTVar sessionMap
>>= return . Map.delete tok
>>= writeTVar sessionMap)
exportSessionMap :: IO [(String,SessionState)]
exportSessionMap = atomically (readTVar sessionMap) >>= return . Map.toList
lookupCookieValue :: HasHeaders a => String-> a-> Maybe String
lookupCookieValue cookname rq = do cookstr <- findHeader HdrCookie rq
findCookie cookname cookstr
setCookie :: HasHeaders a => String -> String -> a -> a
setCookie cookname cookvalue =
insertHeaders [Header HdrSetCookie (showCookie $ newCookie cookname cookvalue)]
removeCookie :: HasHeaders a => String -> a -> a
removeCookie cookname =
insertHeaders [Header HdrSetCookie (showCookie $ deleteCookie $ newCookie cookname "")]
getSessionedStateWithCookie :: HasHeaders request => String -> request -> IO (Maybe SessionState)
getSessionedStateWithCookie cookieName req
= case (lookupCookieValue cookieName req) of
Nothing -> return Nothing
Just tok -> readSession tok
newSessionedStateWithCookie :: HasHeaders response => String -> SessionState -> IO (response -> response)
newSessionedStateWithCookie cookieName st
= do tok <- addSession st
return $ setCookie cookieName tok
updateSessionedStateWithCookie :: HasHeaders request => String -> request -> SessionState -> IO ()
updateSessionedStateWithCookie cookieName req st
= case lookupCookieValue cookieName req of
Nothing -> return ()
Just tok -> updateSession tok st
deleteSessionedStateWithCookie :: (HasHeaders request, HasHeaders response) => String -> request -> IO (response -> response)
deleteSessionedStateWithCookie cookieName req
= do removeSession
return $ removeCookie cookieName
where
removeSession :: IO ()
removeSession = case lookupCookieValue cookieName req of
Nothing -> return ()
Just tok -> deleteSession tok