Authentication.hs

module Bein.Web.Authentication where

import Bein.Web.Types
import Bein.Web.Commands
import Database.HDBC
import Control.Monad.Reader
import Happstack.Server
import Happstack.Crypto.SHA1

sessionCookie :: String
sessionCookie = "beinsid"

sessionTimeout :: Int
sessionTimeout = 30*60 -- 30 minutes

getSession :: RqData (Maybe String)
getSession = liftM Just (lookCookieValue sessionCookie) `mplus` return Nothing

getRequestUser :: BeinServerPart (Maybe User)
getRequestUser = hostAuthentication `mmplus` cookieAuthentication

hostAuthentication :: BeinServerPart (Maybe User)
hostAuthentication = askRq >>= return . fst . rqPeer >>= \h -> lift $ getUser (WithHost h)

cookieAuthentication :: BeinServerPart (Maybe User)
cookieAuthentication = withDataFn getSession f
  where f Nothing    = return Nothing
        f (Just sid) = userOfSession sid

userOfSession :: String -> BeinServerPart (Maybe User)
userOfSession sid = do
  r <- lift $ query "select uid from sessions where key = ?" [toSql sid]
  case (fmap (fromSql.head) . safeHead) r of
    Nothing -> do addCookie 0 (mkCookie sessionCookie "0")
                  return Nothing
    Just thisUid -> do lift $ update "select touch_session(?)" [toSql sid]
                       addCookie sessionTimeout (mkCookie sessionCookie sid)
                       lift $ getUser (WithUid thisUid)

ensureSession :: BeinServerPart a -> BeinServerPart a -> (String,String) -> BeinServerPart a
ensureSession onFail onSucceed (givenUsername,givenPassword) = lift (getUser (WithUserName givenUsername)) >>= \u -> case u of 
  Nothing -> onFail
  Just user -> if authType user == Password (sha1 givenPassword)
                 then do sid <- liftM (fromSql.head.head) $ lift $ updateWithResponse "select new_session(?)" [toSql (uid user)]
                         addCookie sessionTimeout (mkCookie sessionCookie sid)
                         onSucceed `withUser` user
                 else do onFail



clearSession :: BeinServerPart ()
clearSession = withDataFn getSession logOut'
  where logOut' c = do addCookie 0 (mkCookie sessionCookie "0")
                       lift $ update "delete from sessions where key = ?" [toSql c]
                       setHeaderM "Content-Type" "text/html; charset=utf-8"