Permalink
Browse files

Add remember me functionality to authentication

  • Loading branch information...
1 parent 97c4ed6 commit 914f9741e7ed1877be0033f60e85b354911113f7 @ozataman ozataman committed Jan 10, 2011
View
@@ -10,11 +10,11 @@ module Snap.Auth
-- * Higher Level Functions
-- $higherlevel
mkAuthCredentials
- , authLogin
+ , performLogin
, performLogout
- , requireUser
, currentAuthUser
, isLoggedIn
+ , authenticatedUserId
-- * MonadAuth Class
, MonadAuth(..)
@@ -43,6 +43,8 @@ import Data.Time
import Snap.Auth.Password
import Snap.Types
import Snap.Extension.Session
+import Snap.Extension.Session.Common
+import Snap.Extension.Session.SecureCookie
import Snap.Extension.Session.Types
------------------------------------------------------------------------------
@@ -71,7 +73,7 @@ data AuthUser = AuthUser
, userActivatedAt :: Maybe UTCTime
, userSuspendedAt :: Maybe UTCTime
{-, userPerishableToken :: Maybe ByteString-}
- {-, userPersistanceToken :: Maybe ByteString-}
+ , userPersistenceToken :: Maybe ByteString
{-, userSingleAccessToken :: Maybe ByteString-}
, userLoginCount :: Int
, userFailedLoginCount :: Int
@@ -95,7 +97,7 @@ emptyAuthUser = AuthUser
, userActivatedAt = Nothing
, userSuspendedAt = Nothing
{-, userPerishableToken = Nothing-}
- {-, userPersistanceToken = Nothing-}
+ , userPersistenceToken = Nothing
{-, userSingleAccessToken = Nothing-}
, userLoginCount = 0
, userFailedLoginCount = 0
@@ -145,15 +147,16 @@ class (MonadAuth m) => MonadAuthUser m t | m -> t where
--------------------------------------------------------------------------
+ -- | A way to find users by the remember token.
+ getUserByRememberToken :: ByteString -> m (Maybe (AuthUser, t))
+
+
+ --------------------------------------------------------------------------
-- | Implement a way to save given user in the DB.
saveAuthUser :: (AuthUser, t) -> m (Maybe AuthUser)
-
-
-
-
------------------------------------------------------------------------------
-- | Typeclass for authentication and user session functionality.
--
@@ -175,23 +178,33 @@ class (MonadSnap m, MonadSession m) => MonadAuth m where
authHash = return defaultHash
+ -- | Name of the table that will store user data
authUserTable :: m String
authUserTable = return "users"
+ -- | Password length range
authPasswordRange :: m (Int, Int)
authPasswordRange = return (7, 25)
+ -- | What are the database fields and the user-supplied ExternalUserId
+ -- fields that are going to be used to find a user?
authAuthenticationKeys :: m [ByteString]
authAuthenticationKeys = return ["email"]
+
+ -- | Cookie name for the remember token
+ authRememberCookieName :: m ByteString
+ authRememberCookieName = return "auth_remember_token"
+
-- | Remember period in seconds. Defaults to 2 weeks.
authRememberPeriod :: m Int
authRememberPeriod = return $ 60 * 60 * 24 * 14
+ -- | Should it be possible to login multiple times?
authRememberAcrossBrowsers :: m Bool
authRememberAcrossBrowsers = return True
@@ -216,8 +229,9 @@ class (MonadSnap m, MonadSession m) => MonadAuth m where
authenticate :: MonadAuthUser m t
=> ExternalUserId -- ^ External user identifiers
-> ByteString -- ^ Password
+ -> Bool -- ^ Remember user?
-> m (Maybe (AuthUser, t))
-authenticate uid password = do
+authenticate uid password remember = do
hf <- authHash
user <- getUserExternal uid
case user of
@@ -238,7 +252,8 @@ authenticate uid password = do
markLogin :: (MonadAuthUser m t) => (AuthUser, t) -> m (Maybe AuthUser)
markLogin (u,d) = do
- u' <- (incLogCtr >=> updateIP >=> updateLoginTS) u
+ u' <- (incLogCtr >=> updateIP >=> updateLoginTS >=>
+ setPersistenceToken) u
saveAuthUser (u', d)
incLogCtr :: (MonadAuthUser m t) => AuthUser -> m AuthUser
@@ -261,6 +276,22 @@ authenticate uid password = do
return $
u { userCurrentLoginAt = Just t
, userLastLoginAt = userCurrentLoginAt u }
+
+ setPersistenceToken u = do
+ multi_logon <- authRememberAcrossBrowsers
+ to <- authRememberPeriod
+ site_key <- secureSiteKey
+ cn <- authRememberCookieName
+ rt <- liftIO $ randomToken 15
+ token <- case userPersistenceToken u of
+ Nothing -> return rt
+ Just x -> if multi_logon then return x else return rt
+ case remember of
+ False -> return u
+ True -> do
+ setSecureCookie cn site_key token (Just to)
+ return $ u { userPersistenceToken = Just token }
+
-- $higherlevel
@@ -272,11 +303,12 @@ authenticate uid password = do
------------------------------------------------------------------------------
-- | Given an 'ExternalUserId', authenticates the user and persists the
-- authentication in the session if successful.
-authLogin :: MonadAuthUser m t
- => ExternalUserId -- ^ External user identifiers
- -> ByteString -- ^ Password
- -> m (Maybe (AuthUser, t))
-authLogin euid p = authenticate euid p >>= maybe (return Nothing) login
+performLogin :: MonadAuthUser m t
+ => ExternalUserId -- ^ External user identifiers
+ -> ByteString -- ^ Password
+ -> Bool -- ^ Remember user?
+ -> m (Maybe (AuthUser, t))
+performLogin euid p r = authenticate euid p r >>= maybe (return Nothing) login
where
login x@(user, _) = do
setSessionUserId (userId user)
@@ -286,7 +318,11 @@ authLogin euid p = authenticate euid p >>= maybe (return Nothing) login
------------------------------------------------------------------------------
-- | Logs a user out from the current session.
performLogout :: MonadAuthUser m t => m ()
-performLogout = setSessionUserId Nothing
+performLogout = do
+ cn <- authRememberCookieName
+ let ck = Cookie cn "" Nothing Nothing (Just "/")
+ modifyResponse $ addResponseCookie ck
+ setSessionUserId Nothing
------------------------------------------------------------------------------
@@ -306,23 +342,32 @@ mkAuthCredentials pwd = do
------------------------------------------------------------------------------
-- | True if a user is present in current session.
isLoggedIn :: MonadAuthUser m t => m Bool
-isLoggedIn = getSessionUserId >>= return . maybe False (const True)
+isLoggedIn = authenticatedUserId >>= return . maybe False (const True)
------------------------------------------------------------------------------
-- | Get the current 'AuthUser' if authenticated, 'Nothing' otherwise.
currentAuthUser :: MonadAuthUser m t => m (Maybe (AuthUser, t))
-currentAuthUser = getSessionUserId >>= maybe (return Nothing) getUserInternal
+currentAuthUser = authenticatedUserId >>= maybe (return Nothing) getUserInternal
------------------------------------------------------------------------------
--- | Require that an authenticated 'AuthUser' is present in the current session.
---
--- This function has no DB cost - only checks to see if a user_id is present in
--- the current session.
-requireUser :: MonadAuthUser m t => m a
- -- ^ Do this if no authenticated user is present.
- -> m a
- -- ^ Do this if an authenticated user is present.
- -> m a
-requireUser bad good = getSessionUserId >>= maybe bad (const good)
+-- | Return if there is an authenticated user id. Try to remember the user
+-- if possible.
+authenticatedUserId :: MonadAuthUser m t => m (Maybe UserId)
+authenticatedUserId = getSessionUserId >>= maybe rememberUser (return . Just)
+
+------------------------------------------------------------------------------
+-- | Remember user from remember token if possible.
+rememberUser :: MonadAuthUser m t => m (Maybe UserId)
+rememberUser = do
+ to <- authRememberPeriod
+ key <- secureSiteKey
+ cn <- authRememberCookieName
+ remToken <- getSecureCookie cn key (Just to)
+ u <- maybe (return Nothing) getUserByRememberToken remToken
+ case u of
+ Nothing -> return Nothing
+ Just (au, _) -> do
+ setSessionUserId $ userId au
+ return $ userId au
View
@@ -12,6 +12,7 @@
module Snap.Auth.Handlers
( loginHandler
, logoutHandler
+ , requireUser
) where
import Data.ByteString (ByteString)
@@ -22,22 +23,25 @@ import Snap.Auth
------------------------------------------------------------------------------
-- | A 'MonadSnap' handler that processes a login form.
--
--- The request paremeters are passed to 'authLogin' function as
--- 'ExternalUserId'.
+-- The request paremeters are passed to 'performLogin'
loginHandler :: MonadAuthUser m t
=> ByteString
-- ^ The password param field
+ -> Maybe ByteString
+ -- ^ Remember field; Nothing if you want to remember function.
-> m a
-- ^ Upon failure
-> m a
-- ^ Upon success
-> m a
-loginHandler pwdf loginFailure loginSuccess = do
+loginHandler pwdf remf loginFailure loginSuccess = do
euid <- getParams >>= return . EUId
password <- getParam pwdf
+ remember <- maybe (return Nothing) getParam remf
+ let r = maybe False (=="1") remember
mMatch <- case password of
Nothing -> return Nothing
- Just p -> authLogin euid p
+ Just p -> performLogin euid p r
maybe loginFailure (const loginSuccess) mMatch
@@ -48,3 +52,16 @@ logoutHandler :: MonadAuthUser m t
-- ^ What to do after logging out
-> m a
logoutHandler target = performLogout >> target
+
+
+------------------------------------------------------------------------------
+-- | Require that an authenticated 'AuthUser' is present in the current session.
+--
+-- This function has no DB cost - only checks to see if a user_id is present in
+-- the current session.
+requireUser :: MonadAuthUser m t => m a
+ -- ^ Do this if no authenticated user is present.
+ -> m a
+ -- ^ Do this if an authenticated user is present.
+ -> m a
+requireUser bad good = authenticatedUserId >>= maybe bad (const good)
@@ -33,6 +33,11 @@ class MonadSnap m => MonadSession m where
----------------------------------------------------------------------------
+ -- | Return a secure encryption key specific to this application.
+ secureSiteKey :: m ByteString
+
+
+ ----------------------------------------------------------------------------
updateSessionShell :: (SessionShell -> SessionShell) -> m ()
updateSessionShell f = do
ssh <- getSessionShell
@@ -56,7 +61,7 @@ class MonadSnap m => MonadSession m where
csrf <- liftM sesCSRFToken getSessionShell
case csrf of
Nothing -> do
- t <- liftIO randomToken
+ t <- liftIO $ randomToken 15
updateSessionShell (\s -> s { sesCSRFToken = Just t })
return t
Just t -> return t
@@ -15,9 +15,9 @@ import qualified Data.ByteString.Char8 as B
------------------------------------------------------------------------------
-- | Generates a random salt.
-randomToken :: IO ByteString
-randomToken = do
- chars <- sequence $ take 15 $ repeat $
+randomToken :: Int -> IO ByteString
+randomToken n = do
+ chars <- sequence $ take n $ repeat $
randomRIO (0::Int,15) >>= return . flip showHex ""
return $ B.pack $ concat chars
@@ -59,7 +59,7 @@ data CookieSessionState = CookieSessionState
{ csSiteKey :: Key -- ^ Cookie encryption key
, csKeyPath :: FilePath -- ^ Where the encryption key is stored
, csCookieName :: ByteString -- ^ Cookie name for your app's session
- , csTimeout :: Maybe Int -- ^ Replay-attack timeout in minutes
+ , csTimeout :: Maybe Int -- ^ Replay-attack timeout in seconds
}
@@ -76,7 +76,7 @@ defCookieSessionState = CookieSessionState
{ csKeyPath = "site_key.txt"
, csSiteKey = ""
, csCookieName = "snap-session"
- , csTimeout = Just 30
+ , csTimeout = Just (30 * 60)
}
@@ -117,18 +117,22 @@ instance HasCookieSessionState s => MonadSession (SnapExtend s) where
-- | Serialize the session, inject into cookie, modify response.
setSessionShell t = do
cs <- asks getCookieSessionState
- setSecureCookie (csCookieName cs) (csSiteKey cs) t
+ key <- secureSiteKey
+ setSecureCookie (csCookieName cs) key t (csTimeout cs)
----------------------------------------------------------------------------
-- | Read the session from the cookie. If none is present, return default
-- (empty) session.
getSessionShell = do
cs <- asks getCookieSessionState
+ key <- secureSiteKey
let cn = csCookieName cs
- let key = csSiteKey cs
let timeout = csTimeout cs
d <- getSecureCookie cn key timeout
return $ maybe defSessionShell id d
+ secureSiteKey = fmap csSiteKey $ asks getCookieSessionState
+
+
@@ -9,7 +9,7 @@
* Check the timestamp for session expiration everytime you read from the
cookie. This will limit intercept-and-replay attacks by disallowing cookies
- older than the timeout threshould from being effective in your application.
+ older than the timeout threshold.
-}
@@ -47,7 +47,7 @@ type SecureCookie t = (UTCTime, t)
getSecureCookie :: (MonadSnap m, Serialize t)
=> ByteString -- ^ Cookie name
-> Key -- ^ Encryption key
- -> Maybe Int -- ^ Timeout
+ -> Maybe Int -- ^ Timeout in seconds
-> m (Maybe t)
getSecureCookie name key timeout = do
rqCookie <- getCookie name
@@ -70,11 +70,13 @@ setSecureCookie :: (MonadSnap m, Serialize t)
=> ByteString -- ^ Cookie name
-> Key -- ^ Encryption key
-> t -- ^ Serializable payload
+ -> Maybe Int -- ^ Max age in seconds
-> m ()
-setSecureCookie name key val = do
+setSecureCookie name key val to = do
t <- liftIO getCurrentTime
+ let expire = to >>= Just . flip addUTCTime t . fromIntegral
let val' = encrypt key . encode $ (t, val)
- let nc = Cookie name val' Nothing Nothing (Just "/")
+ let nc = Cookie name val' expire Nothing (Just "/")
modifyResponse $ addResponseCookie nc
@@ -90,4 +92,4 @@ checkTimeout (Just x) t0 =
let x' = fromIntegral x
in do
t1 <- liftIO getCurrentTime
- return $ t1 > addUTCTime (x' * 60) t0
+ return $ t1 > addUTCTime x' t0

0 comments on commit 914f974

Please sign in to comment.