Session.hs

module Network.CGI.Session 
    (-- * Types
     Session(..)
    ,Sessions
    ,SessionName
    ,SessionM
     -- * Initialising and querying/updating
    ,makeSessions
    ,initSession
    ,updateSession
    ,sessionId
    -- * A simple Session monad.
    ,runSessionCGI
    ,runSession
    ,sessionIns
    ,sessionDel
    ,sessionGet
    -- * Utilities
    ,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))

--------------------------------------------------------------------------------
-- Section: Sessions implementation
-- Keywords: sessions
-- Description: A poor man's implementation of sessions for CGI.

-- | A simple Session monad. Recommend you define your own.
type SessionM = StateT Session (CGI.CGIT IO)

instance MonadCGI SessionM where
    cgiAddHeader = (lift .) . cgiAddHeader
    cgiGet = lift . cgiGet

-- | Initialise a session state and start a F/CGI process. This is a
--   bit of a pattern so I've included it here for convenience.
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

-- | Simple session runner.
runSession :: Sessions -> SessionM a -> Session -> CGI.CGI a
runSession _ = evalStateT

-- | Session value getter.
sessionGet :: Read a => String -> SessionM (Maybe a)
sessionGet k = get >>= \Session{sess_values=vs} ->
           return $ read <$> M.lookup k vs

-- | Session value inserter/updater.
sessionIns :: (Read a,Show a) => String -> a -> (a -> a -> a) -> SessionM ()
sessionIns k v f =
    -- Technically the other two accessors could be defined in terms of this
    -- but it might confuse (me).
    modify $ \s@Session{sess_values = vs} ->
         s {sess_values = M.insertWith lf k (show v) vs }
            where lf = (show .) . (f `on` read)

-- | Session value deleter.
sessionDel ::  String -> SessionM ()
sessionDel k =
    modify $ \s@Session{sess_values = vs} ->
        s {sess_values = M.delete k vs }

-- | Session value getter.
sessionId :: SessionM Integer
sessionId = gets sess_id

-- | A session consists of a unique id and a map.
data Session = Session
    { sess_id     :: Integer
    , sess_values :: Map String String
    } deriving (Eq,Show)

-- | Sessions and unique ids are stored in an MVar.
type Sessions = MVar ([Integer],Map Integer Session)

-- | The cookie prefix (e.g. MYHASKELLCOOKIE).
type SessionName = String

-- | Make the sessions state.
makeSessions :: IO Sessions
makeSessions = genIds >>= newMVar . flip (,) M.empty

-- | Generate random.
genIds :: IO [Integer]
genIds = nub . randomRs (1,1000^(20::Int)) <$> betterStdGen

-- | An OK-ish random generator.
betterStdGen :: IO StdGen
betterStdGen = alloca $ \p -> do
    h <- openBinaryFile "/dev/urandom" ReadMode
    hGetBuf h p $ sizeOf (undefined :: Int)
    hClose h
    mkStdGen <$> peek p

-- | Grab the session or create a new one.
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

-- | Create a new session and update the Mvar.
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

-- | Try to get the current session.
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

-- | Update a session in the map.
updateSession :: Sessions -> Session -> CGI.CGI ()
updateSession var session@(Session id' _) = do
  liftIO $ modifyMVar_ var $ \(ids,sessions) -> do
    return (ids,M.insert id' session sessions)