Permalink
Browse files

Save progress on auth

  • Loading branch information...
1 parent 3257efa commit 492e04555891e15da4d6e297635f2b1dcb79fd91 @ozataman ozataman committed Jul 31, 2011
Showing with 390 additions and 376 deletions.
  1. +1 −0 .ghci
  2. +138 −62 src/Snap/Snaplet/Auth.hs
  3. +174 −0 src/Snap/Snaplet/Auth/Backends/JsonFile.hs
  4. +77 −314 src/Snap/Snaplet/Auth/Types.hs
View
1 .ghci
@@ -1,3 +1,4 @@
:set -isrc
:set -hide-package MonadCatchIO-mtl
+:set -hide-package monads-fd
:set -XOverloadedStrings
View
200 src/Snap/Snaplet/Auth.hs
@@ -1,67 +1,143 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE TypeFamilies #-}
-{-|
-
- This module provides simple and secure high-level authentication
- functionality for Snap applications.
-
--}
-module Snap.Snaplet.Auth
- (
-
- -- * Higher Level Functions
- -- $higherlevel
- mkAuthCredentials
- , performLogin
- , performLogout
- , currentAuthUser
- , isLoggedIn
- , authenticatedUserId
-
- -- * MonadAuth Class
- , MonadAuth(..)
- , MonadAuthUser(..)
- , AuthEnv(..)
- , defaultAuthEnv
-
- -- * Types
- , AuthUser(..)
- , emptyAuthUser
- , UserId(..)
- , Password(..)
- , AuthFailure(..)
-
- -- * Crypto Stuff You May Need
- , HashFunc
-
- , authInit
-
- ) where
+{-# LANGUAGE ExistentialQuantification #-}
+
+module Snap.Snaplet.Auth where
+
+import Control.Monad.State
+import Crypto.PasswordStore
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString (ByteString)
+import Data.Time
-import Snap.Snaplet
-import Snap.Snaplet.Auth.Handlers
-import Snap.Snaplet.Auth.Password
import Snap.Snaplet.Auth.Types
-import Snap.Snaplet.Session.Types
+import Snap.Snaplet
+import Snap.Snaplet.Session
+
+
+
+-- $higherlevel
+-- These are the key functions you will use in your handlers.
+
+
+loginFromRememberToken :: Handler b (AuthManager b) Bool
+loginFromRememberToken = undefined
+
+------------------------------------------------------------------------------
+-- | Remember user from remember token if possible.
+rememberUser :: Handler b (AuthManager b) (Maybe UserId)
+rememberUser = do
+ to <- gets authRememberPeriod
+ uid <- undefined
+ case uid of
+ Nothing -> return Nothing
+ Just uid' -> setSessionUserId uid' >> return uid'
+
+
+logout :: Handler b (AuthManager b) ()
+logout = undefined
+
+
+currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
+currentUser = undefined
+
+
+isLoggedIn :: Handler b (AuthManager b) Bool
+isLoggedIn = undefined
+
+
+------------------------------------------------------------------------------
+-- | Mutate an 'AuthUser', marking failed authentication now.
+markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
+markAuthFail u = do
+ (AuthManager r _ _ _ _ _) <- get
+ proc u >>= liftIO . save r
+ where
+ proc = incFailCtr >=> checkLockout
+ incFailCtr = undefined
+ checkLockout = undefined
+
+
+------------------------------------------------------------------------------
+-- | Mutate an 'AuthUser', marking successful authentication now.
+markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
+markAuthSuccess u = do
+ (AuthManager r _ _ _ _ _) <- get
+ proc u >>= liftIO . save r
+ where
+ proc = incLoginCtr >=> updateIp >=> updateLoginTS >=>
+ setRememberToken >=> resetFailCtr
+ incLoginCtr = undefined
+ updateIp = undefined
+ updateLoginTS = undefined
+ setRememberToken = undefined
+ resetFailCtr = undefined
+
+
+------------------------------------------------------------------------------
+-- | Authenticate and log the user into the current session if successful.
+--
+-- This is a mid-level function exposed to allow roll-your-own ways of looking
+-- up a user from the database.
+--
+-- This function will:
+--
+-- 1. Check the password
+--
+-- 2. Login the user into the current session
+--
+-- 3. Mark success/failure of the authentication trial on the user record
+loginByPassword
+ :: AuthUser
+ -> ByteString
+ -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
+loginByPassword u pw =
+ case authenticatePassword u pw of
+ Just e -> do
+ markAuthFail u
+ return $ Left e
+ Nothing -> do
+ forceLoginUser u
+ u' <- markAuthSuccess u
+ return $ Right u'
+
+
+------------------------------------------------------------------------------
+-- | Login and persist the given 'AuthUser' in the active session
+--
+-- Meant to be used if you have other means of being sure that the person is
+-- who she says she is.
+forceLoginUser :: AuthUser -> Handler b (AuthManager b) Bool
+forceLoginUser u = do
+ AuthManager _ s _ _ _ _ <- get
+ case userId u of
+ Just x -> withTop s (setSessionUserId x) >> return True
+ Nothing -> return False
+
+
+------------------------------------------------------------------------------
+-- | Set the current user's 'UserId' in the active session
+setSessionUserId :: UserId -> Handler b SessionManager ()
+setSessionUserId (UserId t) = setInSession "__user_id" t
+
+
+------------------------------------------------------------------------------
+-- | Get the current user's 'UserId' from the active session
+getSessionUserId :: Handler b SessionManager (Maybe UserId)
+getSessionUserId = do
+ uid <- getFromSession "__user_id"
+ return $ uid >>= return . UserId
+
------------------------------------------------------------------------------
--- | Initializes the auth snaplet.
-authInit :: (MonadAuthUser (Handler b b))
- => FilePath
- -> AuthEnv
- -> Maybe (AuthHandlerConfig b)
- -> Initializer b (Snaplet AuthEnv)
-authInit dir env ahc = makeSnaplet "auth" $ do
- case ahc of
- Nothing -> return env
- (Just (AuthHandlerConfig a b c d e)) -> do
- -- We don't call "with authLens" here so we can avoid needing the
- -- lens passed into this function. Might as well let the end user
- -- do it in a context where the lens is already available.
- addRoutes [ ("login", loginHandler a b c d)
- , ("logout", logoutHandler e)
- ]
- return env
+-- | Check password for a given user.
+authenticatePassword
+ :: AuthUser -- ^ Looked up from the back-end
+ -> ByteString -- ^ Check against this password
+ -> Maybe AuthFailure
+authenticatePassword u pw = auth
+ where
+ auth = case userPassword u of
+ Nothing -> Just PasswordMissing
+ Just (ClearText x) -> check $ pw == x
+ Just (Encrypted x) -> check $ verifyPassword pw x
+ check b = if b then Nothing else Just IncorrectPassword
View
174 src/Snap/Snaplet/Auth/Backends/JsonFile.hs
@@ -0,0 +1,174 @@
+{-# LANGUAGE TypeSynonymInstances #-}
+
+module Snap.Snaplet.Auth.Backends.JsonFile where
+
+
+import Control.Applicative
+import Control.Concurrent.MVar
+import Data.Aeson
+import qualified Data.ByteString.Lazy as LB
+import qualified Data.Map as HM
+import Data.Map (Map)
+import Data.Maybe (isNothing)
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Snap.Snaplet.Auth.Types
+
+
+type UserIdCache = Map UserId AuthUser
+
+instance ToJSON UserIdCache where
+ toJSON m = toJSON $ HM.toList m
+
+instance FromJSON UserIdCache where
+ parseJSON = fmap HM.fromList . parseJSON
+
+type LoginUserCache = Map Text UserId
+
+
+type RemTokenUserCache = Map Text UserId
+
+
+data UserCache = UserCache {
+ uidCache :: UserIdCache
+ , loginCache :: LoginUserCache
+ , tokenCache :: RemTokenUserCache
+ , uidCounter :: Int
+}
+
+instance ToJSON UserCache where
+ toJSON uc = object
+ [ "uidCache" .= uidCache uc
+ , "loginCache" .= loginCache uc
+ , "tokenCache" .= tokenCache uc
+ , "uidCounter" .= uidCounter uc]
+
+instance FromJSON UserCache where
+ parseJSON (Object v) =
+ UserCache
+ <$> v .: "uidCache"
+ <*> v .: "loginCache"
+ <*> v .: "tokenCache"
+ <*> v .: "uidCounter"
+
+
+data JsonFileAuthManager = JsonFileAuthManager {
+ memcache :: MVar UserCache
+ , dbfile :: FilePath
+}
+
+
+instance IAuthBackend JsonFileAuthManager where
+
+ -- this is currently wrong. Some fields in AuthUser should change as a result
+ -- of saving - like a unique ID being assigned.
+ save mgr u = modifyMVar (memcache mgr) f
+
+ where
+
+ -- Atomically update the cache and dump to disk
+ f cache = dumpToDisk new >> return (new, getLastUser new)
+ where new = updateCache cache
+
+ dumpToDisk c = LB.writeFile (dbfile mgr) (encode c)
+
+ updateCache cache = cache { uidCache = uidc
+ , loginCache = lc
+ , tokenCache = tc
+ , uidCounter = ctr }
+ where
+ -- Assign a userid if it is missing in the given user.
+ uid' = maybe (UserId . showT $ uidCounter cache + 1) id $ userId u
+
+ -- New user might have a newly assigned userid field
+ u' = u { userId = Just uid' }
+
+ -- Update caches
+ uidc = HM.insert uid' u' $ uidCache cache
+ lc = HM.insert (userLogin u') uid' $ loginCache cache
+ tc = case userRememberToken u' of
+ Nothing -> tokenCache cache
+ Just x -> HM.insert x uid' $ tokenCache cache
+
+ -- Increment counter if a new id has been assigned
+ ctr = if isNothing (userId u) then
+ uidCounter cache + 1
+ else uidCounter cache
+
+ -- Get's the last added user
+ getLastUser cache = maybe e id $ getUser cache uid
+ where uid = UserId . showT $ uidCounter cache
+ e = error "getLastUser failed. This should not happen."
+
+ destroy = undefined
+
+ lookupByUserId mgr uid = withCache mgr f
+ where f cache = return $ getUser cache uid
+
+ lookupByLogin mgr login = withCache mgr f
+ where
+ f cache = return $ getUid >>= getUser cache
+ where getUid = HM.lookup login (loginCache cache)
+
+ lookupByRememberToken mgr token = withCache mgr f
+ where
+ f cache = return $ getUid >>= getUser cache
+ where getUid = HM.lookup token (tokenCache cache)
+
+
+withCache mgr f = withMVar (memcache mgr) f
+getUser cache uid = HM.lookup uid (uidCache cache)
+
+
+
+instance ToJSON AuthUser where
+ toJSON u = object
+ [ "uid" .= userId u
+ , "login" .= userLogin u
+ , "pw" .= userPassword u
+ , "activated_at" .= userActivatedAt u
+ , "suspended_at" .= userSuspendedAt u
+ , "remember_token" .= userRememberToken u
+ , "login_count" .= userLoginCount u
+ , "failed_login_count" .= userFailedLoginCount u
+ , "locked_at" .= userLockedOutAt u
+ , "current_login_at" .= userCurrentLoginAt u
+ , "last_login_at" .= userLastLoginAt u
+ , "current_ip" .= userCurrentLoginIp u
+ , "last_ip" .= userLastLoginIp u
+ , "created_at" .= userCreatedAt u
+ , "updated_at" .= userUpdatedAt u
+ , "meta" .= userMeta u ]
+
+
+instance FromJSON AuthUser where
+ parseJSON (Object v) = AuthUser
+ <$> v .: "uid"
+ <*> v .: "login"
+ <*> v .: "pw"
+ <*> v .: "activated_at"
+ <*> v .: "suspended_at"
+ <*> v .: "remember_token"
+ <*> v .: "login_count"
+ <*> v .: "failed_login_count"
+ <*> v .: "locked_at"
+ <*> v .: "current_login_at"
+ <*> v .: "last_login_at"
+ <*> v .: "current_ip"
+ <*> v .: "last_ip"
+ <*> v .: "created_at"
+ <*> v .: "updated_at"
+ <*> return []
+ <*> v .: "meta"
+
+
+instance ToJSON Password where
+ toJSON (ClearText _) = error "ClearText passwords can't be serialized into JSON"
+ toJSON (Encrypted x) = toJSON x
+
+instance FromJSON Password where
+ parseJSON = fmap Encrypted . parseJSON
+
+
+showT = T.pack . show
View
391 src/Snap/Snaplet/Auth/Types.hs
@@ -1,27 +1,22 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
-{-|
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
- This module provides simple and secure high-level authentication
- functionality for Snap applications.
-
--}
module Snap.Snaplet.Auth.Types where
-import Control.Monad.Reader
-import Control.Monad.State
-import Data.ByteString.Char8 (ByteString)
-import qualified Data.ByteString as B
+import Data.Aeson
+import qualified Data.ByteString.Char8 as B
+import Data.ByteString (ByteString)
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HM
+import Data.Hashable (Hashable)
+import Data.Record.Label
import Data.Time
+import Data.Text (Text)
+import Crypto.PasswordStore
-import Snap.Types
import Snap.Snaplet
-import Snap.Snaplet.Auth.Password
import Snap.Snaplet.Session
-import Snap.Snaplet.Session.Common
-import Snap.Snaplet.Session.SecureCookie
-import Snap.Snaplet.Session.Types
------------------------------------------------------------------------------
@@ -33,329 +28,97 @@ data Password = ClearText ByteString
------------------------------------------------------------------------------
+-- Turn a 'ClearText' password into an 'Encrypted' password, ready to be
+-- stuffed into a database.
+encryptPassword :: Password -> IO Password
+encryptPassword p@(Encrypted {}) = return p
+encryptPassword (ClearText p) = do
+ hashed <- makePassword p 12
+ return $ Encrypted hashed
+
+
+------------------------------------------------------------------------------
-- | Authentication failures indicate what went wrong during authentication.
-- They may provide useful information to the developer, although it is
-- generally not advisable to show the user the exact details about why login
-- failed.
-data AuthFailure = ExternalIdFailure
- | PasswordFailure
- deriving (Read, Show, Ord, Eq)
-
-------------------------------------------------------------------------------
--- | Type representing the concept of a User in your application.
-data AuthUser = AuthUser
- { userId :: Maybe UserId
- , userUsername :: Maybe ByteString
- , userEmail :: Maybe ByteString
- , userPassword :: Maybe Password
- , userSalt :: Maybe ByteString
- , userActivatedAt :: Maybe UTCTime
- , userSuspendedAt :: Maybe UTCTime
- {-, userPerishableToken :: Maybe ByteString-}
- , userPersistenceToken :: Maybe ByteString
- {-, userSingleAccessToken :: Maybe ByteString-}
- , userLoginCount :: Int
- , userFailedLoginCount :: Int
- , userCurrentLoginAt :: Maybe UTCTime
- , userLastLoginAt :: Maybe UTCTime
- , userCurrentLoginIp :: Maybe ByteString
- , userLastLoginIp :: Maybe ByteString
- , userCreatedAt :: Maybe UTCTime
- , userUpdatedAt :: Maybe UTCTime
- } deriving (Read,Show,Ord,Eq)
-
-
-------------------------------------------------------------------------------
--- | A blank 'User' as a starting point
-emptyAuthUser :: AuthUser
-emptyAuthUser = AuthUser
- { userId = Nothing
- , userUsername = Nothing
- , userEmail = Nothing
- , userPassword = Nothing
- , userSalt = Nothing
- , userActivatedAt = Nothing
- , userSuspendedAt = Nothing
- {-, userPerishableToken = Nothing-}
- , userPersistenceToken = Nothing
- {-, userSingleAccessToken = Nothing-}
- , userLoginCount = 0
- , userFailedLoginCount = 0
- , userCurrentLoginAt = Nothing
- , userLastLoginAt = Nothing
- , userCurrentLoginIp = Nothing
- , userLastLoginIp = Nothing
- , userCreatedAt = Nothing
- , userUpdatedAt = Nothing
- }
-
-
-------------------------------------------------------------------------------
--- | Make 'SaltedHash' from 'AuthUser'
-mkSaltedHash :: AuthUser -> SaltedHash
-mkSaltedHash u = SaltedHash s p'
- where s = Salt . B.unpack $ s'
- s' = maybe (error "No user salt") id $ userSalt u
- p' = case p of
- ClearText _ ->
- error "Can't mkSaltedHash with a ClearText user password"
- Encrypted x -> B.unpack x
- p = maybe (error "Can't mkSaltedHash with empty password") id $
- userPassword u
-
-------------------------------------------------------------------------------
--- | Typeclass for authentication and user session functionality.
---
--- Your have to make your Application's monad a member of this typeclass.
---
--- - Your app monad has to be a 'MonadSnap'.
---
--- - Your app monad has to be a 'MonadSession'. See 'Snap.Snaplet.Session'.
--- This is needed so we can persist your users' login in session.
-class (MonadSnap m, MonadSession m, MonadAuth m) => MonadAuthUser m where
- type Extra m :: *
-
- --------------------------------------------------------------------------
- -- | Define a function that can resolve to a 'AuthUser' from an internal
- -- 'UserId'.
- --
- -- The 'UserId' is persisted in your application's session
- -- to check for the existence of an authenticated user in your handlers.
- -- A typical 'UserId' would be the unique database key given to your user's
- -- record.
- getUserInternal :: UserId -> m (Maybe (AuthUser, (Extra m)))
-
- --------------------------------------------------------------------------
- -- | Define a function that can resolve to a 'AuthUser'
- --
- -- This is typically passed directly from the POST request.
- getUserExternal :: m (Maybe (AuthUser, (Extra m)))
-
- --------------------------------------------------------------------------
- -- | A way to find users by the remember token.
- getUserByRememberToken :: ByteString -> m (Maybe (AuthUser, (Extra m)))
-
- --------------------------------------------------------------------------
- -- | Implement a way to save given user in the DB.
- saveAuthUser :: (AuthUser, (Extra m)) -> m (Maybe AuthUser)
-
-
-
-type instance Base (Handler b AuthEnv) = b
-
-class MonadAuth m where
- withAuth :: Handler (Base m) AuthEnv a -> m a
-
-instance MonadAuth (Handler b AuthEnv) where
- withAuth = id
+data AuthFailure =
+ FindFailure
+ | IncorrectPassword
+ | PasswordMissing
+ | LockedOut Int -- ^ Locked out with given seconds to go
+ deriving (Read, Show, Ord, Eq)
------------------------------------------------------------------------------
--- | Typeclass for authentication and user session functionality.
---
--- Your have to make your Application's monad a member of this typeclass.
--- Minimum complete definition: 'getUserInternal', 'getUserExternal'
+-- | Internal representation of a 'User'. By convention, we demand that the
+-- application is able to directly fetch a 'User' using this identifier.
--
--- Requirements:
---
--- - Your app monad has to be a 'MonadSnap'.
---
--- - Your app monad has to be a 'MonadSession'. See 'Snap.Snaplet.Session'.
--- This is needed so we can persist your users' login in session.
-data AuthEnv = AuthEnv
-
- { authHash :: HashFunc
- -- ^ Define a hash function to be used. Defaults to 'defaultHash', which
- -- should be quite satisfactory for most purposes.
-
- , authUserTable :: String
- -- ^ Name of the table that will store user data
-
- , authMinPasswordLength :: Int
- -- ^ Password length range
-
- , authAuthenticationKeys :: [ByteString]
- -- ^ What are the database fields and the user-supplied
- -- fields that are going to be used to find a user?
-
- , authRememberCookieName :: ByteString
- -- ^ Cookie name for the remember token
-
- , authRememberPeriod :: Int
- -- ^ Remember period in seconds. Defaults to 2 weeks.
+-- Think of this type as a secure, authenticated user. You should normally
+-- never see this type unless a user has been authenticated.
+newtype UserId = UserId { unUid :: Text }
+ deriving (Read,Show,Ord,Eq,FromJSON,ToJSON,Hashable)
- , authRememberAcrossBrowsers :: Bool
- -- ^ Should it be possible to login multiple times?
- , authEmailValidationRegex :: ByteString
-
- , authLockoutStrategy :: Maybe (Int, Int)
- -- ^ Lockout after x tries, re-allow entry after y seconds
- }
-
-
-defaultAuthEnv :: AuthEnv
-defaultAuthEnv = AuthEnv
- { authHash = defaultHash
- , authUserTable = "users"
- , authMinPasswordLength = 7
- , authAuthenticationKeys = ["email"]
- , authRememberCookieName = "auth_remember_token"
- , authRememberPeriod = 60 * 60 * 24 * 14
- , authRememberAcrossBrowsers = True
- , authEmailValidationRegex =
- "^([\\w\\.%\\+\\-]+)@([\\w\\-]+\\.)+([\\w]{2,})$"
- , authLockoutStrategy = Nothing
- }
+-- | This will be replaced by Greg's role-based permission system.
+data Role = Role ByteString
+ deriving (Read,Show,Ord,Eq)
------------------------------------------------------------------------------
--- | Authenticates a user.
---
--- Returns the internal 'UserId' if successful, 'Nothing' otherwise.
--- Note that this will not persist the authentication. See 'performLogin' for
--- that.
-authenticate :: MonadAuthUser m
- => ByteString -- ^ Password
- -> Bool -- ^ Remember user?
- -> m (Either AuthFailure (AuthUser, Extra m))
-authenticate password remember = do
- hf <- withAuth $ gets authHash
- user <- getUserExternal
- case user of
- Nothing -> return $ Left ExternalIdFailure
- Just user'@(u', _) -> case check hf password u' of
- True -> do
- markLogin user'
- return $ Right user'
- False -> do
- markLoginFail user'
- return $ Left PasswordFailure
- where
- check hf p u = checkSalt hf p $ mkSaltedHash u
-
- markLoginFail (u,d) = do
- u' <- incFailLogCtr u
- saveAuthUser (u', d)
-
- markLogin :: (MonadAuthUser m) => (AuthUser, Extra m) -> m (Maybe AuthUser)
- markLogin (u,d) = do
- u' <- (incLogCtr >=> updateIP >=> updateLoginTS >=>
- setPersistenceToken) u
- saveAuthUser (u', d)
-
- incLogCtr :: (MonadAuthUser m) => AuthUser -> m AuthUser
- incLogCtr u = return $ u { userLoginCount = userLoginCount u + 1 }
-
- incFailLogCtr :: (MonadAuthUser m) => AuthUser -> m AuthUser
- incFailLogCtr u = return $
- u { userFailedLoginCount = userFailedLoginCount u + 1 }
-
- updateIP :: (MonadAuthUser m) => AuthUser -> m AuthUser
- updateIP u = do
- ip <- getRequest >>= return . rqRemoteAddr
- return $
- u { userCurrentLoginIp = Just ip
- , userLastLoginIp = userCurrentLoginIp u }
-
- updateLoginTS :: (MonadAuthUser m) => AuthUser -> m AuthUser
- updateLoginTS u = do
- t <- liftIO getCurrentTime
- return $
- u { userCurrentLoginAt = Just t
- , userLastLoginAt = userCurrentLoginAt u }
-
- setPersistenceToken u = do
- multi_logon <- withAuth $ gets authRememberAcrossBrowsers
- to <- withAuth $ gets authRememberPeriod
- site_key <- secureSiteKey
- cn <- withAuth $ gets 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 }
+-- | Type representing the concept of a User in your application.
+data AuthUser = AuthUser
+ { userId :: Maybe UserId
+ , userLogin :: Text
+ , userPassword :: Maybe Password
+ , userActivatedAt :: Maybe UTCTime
+ , userSuspendedAt :: Maybe UTCTime
+ , userRememberToken :: Maybe Text
+ , userLoginCount :: Int
+ , userFailedLoginCount :: Int
+ , userLockedOutAt :: Maybe UTCTime
+ , userCurrentLoginAt :: Maybe UTCTime
+ , userLastLoginAt :: Maybe UTCTime
+ , userCurrentLoginIp :: Maybe ByteString
+ , userLastLoginIp :: Maybe ByteString
+ , userCreatedAt :: Maybe UTCTime
+ , userUpdatedAt :: Maybe UTCTime
+ , userRoles :: [Role]
+ , userMeta :: HashMap Text Value
+ } deriving (Show,Eq)
--- $higherlevel
--- These are the key functions you will use in your handlers. Once you have set
--- up your application's monad with 'MonadAuth', you really should not need to
--- use anything other than what is in this section.
+data AuthManager b = forall r. IAuthBackend r => AuthManager {
+ backend :: r
+ -- ^ Storage back-end
+ , session :: (b :-> Snaplet SessionManager)
-------------------------------------------------------------------------------
--- | Authenticates the user and persists the authentication in the session if
--- successful.
-performLogin :: MonadAuthUser m
- => ByteString -- ^ Password
- -> Bool -- ^ Remember user?
- -> m (Either AuthFailure (AuthUser, Extra m))
-performLogin p r = authenticate p r >>= either (return . Left) login
- where
- login x@(user, _) = do
- setSessionUserId (userId user)
- return (Right x)
+ , minPasswdLen :: Int
+ -- ^ Password length range
+ , rememberCookieName :: ByteString
+ -- ^ Cookie name for the remember token
-------------------------------------------------------------------------------
--- | Logs a user out from the current session.
-performLogout :: MonadAuthUser m => m ()
-performLogout = do
- cn <- withAuth $ gets authRememberCookieName
- let ck = Cookie cn "" Nothing Nothing (Just "/")
- modifyResponse $ addResponseCookie ck
- setSessionUserId Nothing
+ , rememberPeriod :: Int
+ -- ^ Remember period in seconds. Defaults to 2 weeks.
+ , lockout :: Maybe (Int, Int)
+ -- ^ Lockout after x tries, re-allow entry after y seconds
+ }
-------------------------------------------------------------------------------
--- | Takes a clean-text password and returns a fresh pair of password and salt
--- to be stored in your app's DB.
-mkAuthCredentials :: MonadAuthUser m
- => ByteString
- -- ^ A given password
- -> m (ByteString, ByteString)
- -- ^ (Salt, Encrypted password)
-mkAuthCredentials pwd = do
- hf <- withAuth $ gets authHash
- SaltedHash (Salt s) pwd' <- liftIO $ buildSaltAndHash hf pwd
- return $ (B.pack s, B.pack pwd')
+class IAuthBackend r where
+
+ save :: r -> AuthUser -> IO AuthUser
-------------------------------------------------------------------------------
--- | True if a user is present in current session.
-isLoggedIn :: MonadAuthUser m => m Bool
-isLoggedIn = authenticatedUserId >>= return . maybe False (const True)
+ lookupByUserId :: r -> UserId -> IO (Maybe AuthUser)
+ lookupByLogin :: r -> Text -> IO (Maybe AuthUser)
-------------------------------------------------------------------------------
--- | Get the current 'AuthUser' if authenticated, 'Nothing' otherwise.
-currentAuthUser :: MonadAuthUser m => m (Maybe (AuthUser, Extra m))
-currentAuthUser = authenticatedUserId >>= maybe (return Nothing) getUserInternal
+ lookupByRememberToken :: r -> Text -> IO (Maybe AuthUser)
+ destroy :: r -> AuthUser -> IO ()
-------------------------------------------------------------------------------
--- | Return if there is an authenticated user id. Try to remember the user
--- if possible.
-authenticatedUserId :: MonadAuthUser m => m (Maybe UserId)
-authenticatedUserId = getSessionUserId >>= maybe rememberUser (return . Just)
-
-------------------------------------------------------------------------------
--- | Remember user from remember token if possible.
-rememberUser :: MonadAuthUser m => m (Maybe UserId)
-rememberUser = do
- to <- withAuth $ gets authRememberPeriod
- key <- secureSiteKey
- cn <- withAuth $ gets 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

0 comments on commit 492e045

Please sign in to comment.