module Happstack.Auth
(
register
, changePassword
, setPassword
, updateTimeout
, performLogin
, performLogout
, loginHandler
, logoutHandler
, withSession
, loginGate
, getSessionData
, getSessionKey
, clearSessionCookie
, addUser
, getUser
, getUserById
, delUser
, updateUser
, authUser
, isUser
, listUsers
, numUsers
, askUsers
, newSession
, getSession
, setSession
, delSession
, clearAllSessions
, numSessions
, getSessions
, clearExpiredSessions
, User (), userName, userId
, Username
, Password
, UserId
, SessionData (..)
, SessionKey
, Minutes
, AuthState
, authProxy
) where
#if MIN_VERSION_happstack(0,5,1)
import Control.Applicative
#endif
import Control.Monad.Reader
import Data.Maybe
import System.Time
import qualified Data.ByteString.Char8 as BS8
import Data.Convertible
import Happstack.Server
#if MIN_VERSION_happstack(0,5,1)
import Happstack.Server.HTTP.Cookie
#endif
import Happstack.State
import Happstack.Auth.Internal
import Happstack.Auth.Internal.Data hiding (Username, User, SessionData)
import qualified Happstack.Auth.Internal.Data as D
#if MIN_VERSION_happstack(0,5,1)
queryPolicy :: BodyPolicy
queryPolicy = defaultBodyPolicy "/tmp/happstack-auth" 0 4096 4096
#endif
sessionCookie :: String
sessionCookie = "sid"
type Username = String
type Password = String
data User = User
{ userId :: UserId
, userName :: Username
, _userPass :: SaltedHash
}
fromDUser :: D.User -> User
fromDUser (D.User i (D.Username n) p) = User i n p
instance Convertible D.User User where
safeConvert = Right . fromDUser
toDUser :: User -> D.User
toDUser (User i n p) = D.User i (D.Username n) p
instance Convertible User D.User where
safeConvert = Right . toDUser
maybeUser :: MonadIO m => m (Maybe D.User) -> m (Maybe User)
maybeUser m = m >>= return . fmap fromDUser
data SessionData = SessionData
{ sessionUserId :: UserId
, sessionUsername :: Username
, sessionTimeout :: ClockTime
, sessionFingerprint :: (Either String BS8.ByteString, Maybe BS8.ByteString)
}
fromDSession :: D.SessionData -> SessionData
fromDSession (D.SessionData i (D.Username n) t f) = SessionData i n t f
instance Convertible D.SessionData SessionData where
safeConvert = Right . fromDSession
toDSession :: SessionData -> D.SessionData
toDSession (SessionData i n t f) = D.SessionData i (D.Username n) t f
instance Convertible SessionData D.SessionData where
safeConvert = Right . toDSession
authProxy :: Proxy AuthState
authProxy = Proxy
addUser :: (MonadIO m) => Username -> Password -> m (Maybe User)
addUser u p = do
s <- liftIO $ buildSaltAndHash p
case s of
Just s' -> maybeUser . update $ AddUser (D.Username u) s'
Nothing -> return Nothing
getUser :: (MonadIO m) => Username -> m (Maybe User)
getUser u = maybeUser . query $ GetUser (D.Username u)
getUserById :: (MonadIO m) => UserId -> m (Maybe User)
getUserById i = maybeUser . query $ GetUserById i
delUser :: (MonadIO m) => Username -> m ()
delUser u = update $ DelUser (D.Username u)
authUser :: (MonadIO m) => Username -> Password -> m (Maybe User)
authUser u p = maybeUser . query $ AuthUser u p
isUser :: (MonadIO m) => Username -> m Bool
isUser u = query $ IsUser (D.Username u)
listUsers :: (MonadIO m) => m [Username]
listUsers = query ListUsers >>= return . map D.unUser
numUsers :: (MonadIO m) => m Int
numUsers = query NumUsers
updateUser :: (MonadIO m) => User -> m ()
updateUser u = update $ UpdateUser (toDUser u)
askUsers :: (MonadIO m) => m UserDB
askUsers = query AskUsers
clearAllSessions :: (MonadIO m) => m ()
clearAllSessions = update ClearAllSessions
setSession :: (MonadIO m) => SessionKey -> SessionData -> m ()
setSession k d = update $ SetSession k (toDSession d)
getSession :: (MonadIO m) => SessionKey -> m (Maybe SessionData)
getSession k = query (GetSession k) >>= return . fmap fromDSession
newSession :: (MonadIO m) => SessionData -> m SessionKey
newSession d = update $ NewSession (toDSession d)
delSession :: (MonadIO m) => SessionKey -> m ()
delSession k = update $ DelSession k
numSessions :: (MonadIO m) => m Int
numSessions = query $ NumSessions
getFingerprint :: (MonadIO m, ServerMonad m) => m (Either String BS8.ByteString, Maybe BS8.ByteString)
getFingerprint = do
userAgent <- getHeaderM "user-agent"
forwarded <- getHeaderM "x-forwarded-for"
case forwarded of
Just f -> return (Right f, userAgent)
Nothing -> do
(ip, _) <- askRq >>= return . rqPeer
return (Left ip, userAgent)
getSessions :: (MonadIO m) => m (Sessions D.SessionData)
getSessions = query GetSessions
type Minutes = Int
updateTimeout :: (MonadIO m, FilterMonad Response m, MonadPlus m, ServerMonad m)
=> Minutes
-> m ()
updateTimeout mins = withSessionId action
where
action Nothing = return ()
action (Just sid) = do
c <- liftIO getClockTime
let c' = addToClockTime noTimeDiff { tdMin = mins } c
cookie = mkCookie sessionCookie (show sid)
update $ UpdateTimeout sid c'
addCookie (mins * 60) cookie
performLogin :: (MonadIO m, FilterMonad Response m, ServerMonad m)
=> Minutes
-> User
-> m a
-> m a
performLogin mins user action = do
f <- getFingerprint
c <- liftIO getClockTime
let clock = addToClockTime noTimeDiff { tdMin = mins } c
key <- newSession $ SessionData (userId user) (userName user) clock f
let cookie = mkCookie sessionCookie (show key)
addCookie (mins * 60) cookie
localRq (\r -> r { rqCookies = (rqCookies r) ++ [(sessionCookie, cookie)] }) action
loginHandler :: (MonadIO m, FilterMonad Response m, MonadPlus m, ServerMonad m)
=> Minutes
-> Maybe String
-> Maybe String
-> m a
-> (Maybe Username -> Maybe Password -> m a)
-> m a
loginHandler mins muname mpwd okR failR = do
#if MIN_VERSION_happstack(0,5,1)
dat <- getDataFn queryPolicy . body $ do
#else
dat <- getDataFn $ do
#endif
un <- look $ fromMaybe "username" muname
#if MIN_VERSION_happstack(0,5,1)
pw <- optional . look $ fromMaybe "password" mpwd
#else
pw <- (Just `fmap` (look $ fromMaybe "password" mpwd)) `mplus` return Nothing
#endif
return (un,pw)
case dat of
#if MIN_VERSION_happstack(0,5,1)
Right (u, Just p) -> authUser u p
#else
Just (u, Just p) -> authUser u p
#endif
>>= maybe (failR (Just u) (Just p))
(\user -> performLogin mins user okR)
#if MIN_VERSION_happstack(0,5,1)
Right (u, mp) -> failR (Just u) mp
#else
Just (u, mp) -> failR (Just u) mp
#endif
_ -> failR Nothing Nothing
performLogout :: (MonadIO m, FilterMonad Response m) => SessionKey -> m ()
performLogout sid = do
clearSessionCookie
delSession sid
logoutHandler :: (ServerMonad m, MonadPlus m, MonadIO m, FilterMonad Response m)
=> m a
-> m a
logoutHandler target = withSessionId handler
where
handler (Just sid) = do
performLogout sid
target
handler Nothing = target
clearSessionCookie :: (FilterMonad Response m) => m ()
clearSessionCookie = addCookie' 0 (mkCookie sessionCookie "0")
where
addCookie' sec = (setHeaderM "Set-Cookie") . mkCookieHeader sec
clearExpiredSessions :: (MonadIO m) => m ()
clearExpiredSessions = liftIO getClockTime >>= update . ClearExpiredSessions
getSessionData :: (MonadIO m, MonadPlus m, ServerMonad m)
=> m (Maybe SessionData)
getSessionData = do
d <- withSessionId action
f <- getFingerprint
case d of
Just sd | f == sessionFingerprint sd ->
return $ Just sd
_ ->
return Nothing
where
action (Just sid) = getSession sid
action Nothing = return Nothing
getSessionKey :: (MonadIO m, MonadPlus m, ServerMonad m)
=> m (Maybe SessionKey)
getSessionKey = withSessionId return
withSessionId :: (Read a, MonadIO m, MonadPlus m, ServerMonad m)
=> (Maybe a -> m r)
-> m r
withSessionId f = do
clearExpiredSessions
#if MIN_VERSION_happstack(0,5,1)
withDataFn queryPolicy getSessionId f
#else
withDataFn getSessionId f
#endif
where
getSessionId :: (Read a) => RqData (Maybe a)
#if MIN_VERSION_happstack(0,5,1)
getSessionId = optional $ readCookieValue sessionCookie
#else
getSessionId = (Just `fmap` readCookieValue sessionCookie) `mplus` return Nothing
#endif
withSession :: (MonadIO m)
=> (SessionData -> ServerPartT m a)
-> ServerPartT m a
-> ServerPartT m a
withSession f guestSPT = withSessionId action
where
action (Just sid) = getSession sid >>= maybe noSession f
action Nothing = guestSPT
noSession = clearSessionCookie >> guestSPT
loginGate :: (MonadIO m)
=> ServerPartT m a
-> ServerPartT m a
-> ServerPartT m a
loginGate reg guest = withSession (\_ -> reg) guest
register :: (MonadIO m, FilterMonad Response m, ServerMonad m)
=> Minutes
-> Username
-> Password
-> m a
-> m a
-> m a
register mins user pass uExists good = do
u <- addUser user pass
case u of
Just u' -> performLogin mins u' good
Nothing -> uExists
changePassword :: (MonadIO m)
=> Username
-> Password
-> Password
-> m Bool
changePassword user oldpass newpass = do
ms <- liftIO $ buildSaltAndHash newpass
case ms of
Just s -> update $ ChangePassword user oldpass s
_ -> return False
setPassword :: MonadIO m
=> Username
-> Password
-> m Bool
setPassword un p = do
ms <- liftIO $ buildSaltAndHash p
case ms of
Just s -> update $ SetPassword (D.Username un) s
_ -> return False