Session.hs

module Network.Salvia.Handlers.Session (
    hSession

  , SessionID
  , Session (..)
  , TSession
  , SessionHandler
  , Sessions

  , mkSessions
  ) where

import Control.Applicative hiding (empty)
import Control.Concurrent.STM
import Control.Monad.State
import Data.Time.LocalTime
import Prelude hiding (lookup)
import System.Random
import qualified Data.Map as M

import Network.Salvia.Handlers.Cookie
import Network.Salvia.Httpd hiding (start)
import Network.Protocol.Cookie hiding (empty)
import Misc.Misc (safeRead, atomModTVar, atomReadTVar, now, later)

-------------------------------------------------------------------------------

-- A session identifier. Should be unique for every session.
newtype SessionID = SID Integer
  deriving (Eq, Ord)

-- The session data type with polymorph payload.
data Session a = Session {
    sID     :: SessionID
  , start   :: LocalTime
  , expire  :: LocalTime
  , payload :: Maybe a
  }

-- A shared session.
type TSession a = TVar (Session a)

-- A handler that expects a session.
type SessionHandler a b = TSession a -> Handler b

-- Create a new, empty, shared session.
mkSession :: SessionID -> LocalTime -> IO (TSession a)
mkSession sid e = do
  s <- now
  atomically $ newTVar $ Session sid s e Nothing

-------------------------------------------------------------------------------

type Sessions a = TVar (M.Map SessionID (TSession a))

instance Show SessionID where
  show (SID sid) = show sid

mkSessions :: IO (Sessions a)
mkSessions = atomically $ newTVar M.empty

-------------------------------------------------------------------------------

{-
The session handler. This handler will try to return an existing session from
the sessions map based on a session identifier found in the HTTP cookie. When
such a session can be found the expiration date will be updated to a number of
seconds in the future. When no session can be found a new one will be created.
A cookie will be set that informs the client of the current session.
-}

hSession :: Sessions a -> Integer -> Handler (TSession a)
hSession smap expiration = do

  -- Get the session identifier from an existing cookie or create a new one.
  prev <- getSessionID <$> hGetCookies

  -- Compute current time and expiration time.
  (n, ex) <- lift $ liftM2 (,) now (later expiration)

  -- Either create a new session or try to reuse current one.
  tsession <- 
    maybe
    (newSession smap ex)
    (existingSession smap ex n)
    prev

  setSessionCookie tsession ex
  return tsession

-------------------------------------------------------------------------------

{-
Given the (possible wrong) request cookie, try to recover the existing --
session identifier.
-}

getSessionID :: Maybe Cookies -> Maybe SessionID
getSessionID prev = do
  ck  <- prev
  sid <- cookie "sid" ck
  sid' <- safeRead $ value sid
  return (SID sid')
  
{-
Generate a fresh, random session identifier using the default system random
generator.
-}

genSessionID :: IO SessionID
genSessionID = do
  g <- getStdGen
  let (sid, g') = random g
  setStdGen g'
  return (SID (abs sid))


{-
This handler sets the HTTP cookie for the specified session. It will use a
default cookie with an additional `sid' attribute with the session identifier
as value. The session expiration date will be used as the cookie expire field.
-}

setSessionCookie :: TSession a -> LocalTime -> Handler ()
setSessionCookie tsession ex = do
  ck <- newCookie ex
  sid <- lift $ liftM sID $ atomReadTVar tsession
  hSetCookies $
    cookies [ck {
      name  = "sid"
    , value = show sid
    }]

{-
Handler when no (valid) session is available. Create a new session with a
specified expiration date. The session will be stored in the session map.
-}

newSession :: Sessions a -> LocalTime -> Handler (TSession a)
newSession sessions ex = lift $ do

  -- Fresh session identifier.
  sid <- genSessionID

  -- Fresh session.
  session <- mkSession sid ex

  -- Place in session mapping usinf session identifier as key.
  atomModTVar (M.insert sid session) sessions
  return session

{-
Handler for existing sessions. Given an existing session identifier lookup a
session from the session map. When no session is available, or the session is
expired, create a new one using the `newSession' function. Otherwise the
expiration date of the existing session is updated.
-}

existingSession ::
     Sessions a -> LocalTime -> LocalTime
  -> SessionID -> Handler (TSession a)
existingSession sessions ex n sid = do

  -- Lookup the session in the session map given the session identifier.
  mtsession <- lift $ liftM (M.lookup sid) (atomReadTVar sessions)
  case mtsession of

    -- Unrecognized session identifiers are penalised by a fresh session.
    Nothing -> newSession sessions ex
    Just tsession -> do
      expd <- lift $ liftM expire (atomReadTVar tsession)
      if expd < n

        -- Session is expired, create a new one.
        then newSession sessions ex

        -- Existing session, update expiration date.
        else lift $ do
          atomModTVar (\s -> s {expire = ex}) tsession
          return tsession