module Network.CGI.Session
(
Session(..)
,Sessions
,SessionName
,SessionM
,makeSessions
,initSession
,updateSession
,sessionId
,runSessionCGI
,runSession
,sessionIns
,sessionDel
,sessionGet
,makeSession
,getSession)
where
import Control.Applicative
import Control.Concurrent.MVar (MVar,modifyMVar,readMVar,modifyMVar_,newMVar)
import Control.Monad.Trans (liftIO,lift)
import Control.Monad.State (StateT,evalStateT,get,modify,gets)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Storable (peek,sizeOf)
import Data.Function
import Data.List (nub)
import Data.Map (Map)
import qualified Data.Map as M
import System.IO (openBinaryFile,IOMode(ReadMode),hGetBuf,hClose)
import System.Random (mkStdGen,StdGen,randomRs)
import qualified Network.CGI as CGI
import Network.CGI.Monad (MonadCGI(cgiGet,cgiAddHeader))
type SessionM = StateT Session (CGI.CGIT IO)
instance MonadCGI SessionM where
cgiAddHeader = (lift .) . cgiAddHeader
cgiGet = lift . cgiGet
runSessionCGI :: SessionName
-> (CGI.CGI CGI.CGIResult -> IO ())
-> SessionM CGI.CGIResult
-> IO ()
runSessionCGI name run m = do
sessions <- makeSessions
run $ CGI.handleErrors $ do
session <- initSession name sessions
runSession sessions m session
runSession :: Sessions -> SessionM a -> Session -> CGI.CGI a
runSession _ = evalStateT
sessionGet :: Read a => String -> SessionM (Maybe a)
sessionGet k = get >>= \Session{sess_values=vs} ->
return $ read <$> M.lookup k vs
sessionIns :: (Read a,Show a) => String -> a -> (a -> a -> a) -> SessionM ()
sessionIns k v f =
modify $ \s@Session{sess_values = vs} ->
s {sess_values = M.insertWith lf k (show v) vs }
where lf = (show .) . (f `on` read)
sessionDel :: String -> SessionM ()
sessionDel k =
modify $ \s@Session{sess_values = vs} ->
s {sess_values = M.delete k vs }
sessionId :: SessionM Integer
sessionId = gets sess_id
data Session = Session
{ sess_id :: Integer
, sess_values :: Map String String
} deriving (Eq,Show)
type Sessions = MVar ([Integer],Map Integer Session)
type SessionName = String
makeSessions :: IO Sessions
makeSessions = genIds >>= newMVar . flip (,) M.empty
genIds :: IO [Integer]
genIds = nub . randomRs (1,1000^(20::Int)) <$> betterStdGen
betterStdGen :: IO StdGen
betterStdGen = alloca $ \p -> do
h <- openBinaryFile "/dev/urandom" ReadMode
_ <- hGetBuf h p $ sizeOf (undefined :: Int)
hClose h
mkStdGen <$> peek p
initSession :: SessionName -> Sessions -> CGI.CGI Session
initSession sessionName var = do
s <- getSession sessionName var
case s of
Just s' -> return s'
Nothing -> makeSession sessionName var
makeSession :: SessionName -> Sessions -> CGI.CGI Session
makeSession sessionName var = do
sess <- liftIO $ modifyMVar var $ \(id':ids,sessions) ->
let session = Session id' M.empty
newState = (ids,M.insert id' session sessions)
in return (newState,session)
CGI.setCookie (CGI.newCookie sessionName $ show $ sess_id sess)
{ CGI.cookiePath = Just "/" }
return sess
getSession :: SessionName -> Sessions -> CGI.CGI (Maybe Session)
getSession sessionName var = do
sId <- CGI.readCookie sessionName
(_,sessions) <- liftIO $ readMVar var
return $ sId >>= flip M.lookup sessions
updateSession :: Sessions -> Session -> CGI.CGI ()
updateSession var session@(Session id' _) = do
liftIO $ modifyMVar_ var $ \(ids,sessions) -> do
return (ids,M.insert id' session sessions)