Session.hs

{-# LANGUAGE OverloadedStrings #-}
module Session
  ( sessionCookie
  , withSession
  , newSessionCookie
  , session
  )  where

import           Control.Monad.Trans (liftIO)
import           Control.Applicative
import qualified Data.ByteString.Char8 as B
import           System.UUID.V4 (uuid)
import           Data.List (find)
import           Data.Time (addUTCTime, getCurrentTime, NominalDiffTime)
import           Snap.Types
import           Happstack.State
import           AuthState

-- | Session specific helpers

type SessionSnap = (SessionKey, SessionData) -> Snap ()

sidName :: B.ByteString
sidName = B.pack "sid"

cookieTimeout :: NominalDiffTime
cookieTimeout = (60 * 60 * 24 * 30)

sessionCookie :: Snap Cookie
sessionCookie = withRequest $ \req -> maybe pass return (maybeCookie req)
    where maybeCookie r = find ((== sidName) . cookieName) (rqCookies r)

session :: Snap (SessionKey, SessionData)
session = do
  sess <- maybeSession
  maybe pass return sess
    where maybeSession = do
            cookie <- sessionCookie
            let k = SessionKey (B.unpack $ cookieValue cookie)
            s <- liftIO $ query $ GetSession k
            return $ ((,) k) `fmap` s

withSession :: SessionSnap -> Snap () -> Snap ()
withSession f otherwise' = 
  do cookie  <- sessionCookie
     let key = SessionKey (B.unpack $ cookieValue cookie)
     session <- liftIO $ query $ GetSession key
     maybe otherwise' f $ (,) key `fmap` session

newSessionCookie :: Snap Cookie
newSessionCookie = do
  now <- liftIO (getCurrentTime)
  sessionId <- liftIO $ B.pack . show <$> uuid
  let cookie = Cookie { cookieName  = sidName
                      , cookieValue = sessionId
                      , cookieExpires = Just $ addUTCTime cookieTimeout now
                      , cookieDomain = Nothing
                      , cookiePath = Just $ B.pack "/"
                      }
  modifyResponse $ addCookie cookie
  return cookie