{-# OPTIONS_GHC -fallow-overlapping-instances #-}
module Hawl.Session.Operations (newSession, deleteSession,
                                updateSession,
                                getSession, setSessionUser,
                                purgeSessions, listSessions) where

import Database.HaskellDB

import Control.Monad.Trans (MonadIO, liftIO)
import Data.FunctorM (fmapM)
import Data.Maybe (isJust)
import System.Random
import System.Time

import Hawl.User.Types
import Hawl.Session.Types
import Hawl.HaskellDB.Util
import Hawl.Util.Time

import Hawl.Session.DB.Sessions as S
import Hawl.Session.DB.Sessions_meta as SM

--
-- * Exported operations
--

-- | Starts a new session and stores it in the database.
newSession :: MonadIO m => Database -> Maybe UserID -> m Session
newSession db muid = liftIO $ 
    do
    sid <- genSessionID db
    now <- timeNow
    insert db S.sessions (S.sessionid <<- sid #
                          S.userid <<- muid #
                          S.started <<- now #
                          S.last_use <<- now)
    let s = Session { 
                     sessionID = sid,
                     sessionUser = muid,
                     sessionStarted = now,
                     sessionLastUse = now
                    }
    return s

-- | Ends a session by removing it from the database.
deleteSession :: MonadIO m => Database -> SessionID -> m ()
deleteSession db sid = liftIO $
    delete db S.sessions (\r -> r!S.sessionid .==. constant sid)

-- | Update the stored session information for the given session.
updateSession :: MonadIO m => Database -> Session -> m ()
updateSession db s = liftIO $
    update db S.sessions (\r -> r!S.sessionid .==. constant (sessionID s))
                         (\_ -> S.userid <<- sessionUser s
                              # S.started <<- sessionStarted s
                              # S.last_use <<- sessionLastUse s)

-- | Gets session information, and updates the last use
--   information. The 'sessionLastUse' field will contain
--   the last use information as it was before this call.
--   If the session has expired, the session is removed and
--   'Nothing' is returned. If the session does not exist,
--   'Nothing' is returned.
getSession :: MonadIO m => 
              Database 
           -> SessionID    -- ^ The ID of the session to get.
           -> m (Maybe Session)
getSession db sid = liftIO $ 
    do msess <- findSession db sid 
       maybe (return Nothing) endExpired msess
  where
  endExpired s = do
                 exp <- isExpired db s
                 if exp then do
                             deleteSession db sid
                             return Nothing
                        else return $ Just s

-- | Sets the 'UserID' associated with a session.
setSessionUser :: MonadIO m => 
                  Database 
               -> Session
               -> Maybe UserID 
               -> m (Session)
setSessionUser db sess muid = 
    do liftIO $ updateSession db sess'
       return sess'
  where sess' = sess { sessionUser = muid } 

purgeSessions :: MonadIO m => Database -> m ()
purgeSessions db = liftIO $
    do
    (min_started, min_last_use) <- getMinTimes db
    let too_old r = r!S.started  .<. constant min_started
        too_idle r = r!S.last_use .<. constant min_last_use
    delete db S.sessions (\r -> too_old r .||. too_idle r)

--
-- * Formatting session IDs
--



--
-- * Debugging operations
--

listSessions :: MonadIO m => Database -> m [Session]
listSessions db = liftIO $
    do
    rs <- query db $ table S.sessions
    return $ map mkSession rs

--
-- * Private operations
--

genSessionID :: Database -> IO SessionID
genSessionID db = 
    do
    sid <- randomRIO (0,maxBound)
    ms <- findSession db sid
    case ms of
            Nothing -> return sid
            Just _  -> genSessionID db

findSession :: Database -> SessionID -> IO (Maybe Session)
findSession db sid =
    do
    rs <- query db $ do
                     s <- table S.sessions
                     restrict (s!S.sessionid .==. constant sid)
                     return s
    case rs of
            []  -> return Nothing
            [r] -> return $ Just $ mkSession r
            _   -> fail $ "Multiple sessions with ID " ++ show sid

mkSession r = Session { 
                       sessionID = r!S.sessionid,
                       sessionUser = r!S.userid,
                       sessionStarted = r!S.started,
                       sessionLastUse = r!S.last_use
                      }

isExpired :: Database -> Session -> IO Bool
isExpired db sess =
    do
    (min_started, min_last_use) <- getMinTimes db
    return (sessionStarted sess < min_started 
         || sessionLastUse sess < min_last_use)

getMinTimes :: Database -> IO (CalendarTime,CalendarTime)
getMinTimes db = do
    max_age <- getMaxAge db
    max_idle <- getMaxIdle db
    now <- timeNow
    let min_started
            | max_age <= 0  = epoch
            | otherwise     = max_age `minutesBefore` now
        min_last_use 
            | max_idle <= 0 = epoch
            | otherwise = max_idle `minutesBefore` now
    return (min_started, min_last_use)

--
-- * Session max idle and max age
--

defaultMaxAge :: Minutes
defaultMaxAge = 0

defaultMaxIdle :: Minutes
defaultMaxIdle = 0

getMaxAge :: Database -> IO Minutes
getMaxAge db = 
    do
    rs <- query db $ table SM.sessions_meta
    case rs of
            []  -> return defaultMaxAge
            [r] -> return $ r!SM.max_age
            _   -> fail "Multiple records in sessions_meta"

getMaxIdle :: Database -> IO Minutes
getMaxIdle db = 
    do
    rs <- query db $ table SM.sessions_meta
    case rs of
            []  -> return defaultMaxIdle
            [r] -> return $ r!SM.max_idle
            _   -> fail "Multiple records in sessions_meta"

setMaxAge :: Database -> Minutes -> IO ()
setMaxAge db x = update db SM.sessions_meta (\r -> constant True) (\r -> SM.max_age <<- x)

setMaxIdle :: Database -> Minutes -> IO ()
setMaxIdle db x = update db SM.sessions_meta (\r -> constant True) (\r -> SM.max_idle <<- x)