Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Authentication process now returns an Either with details of where

authentication failed
  • Loading branch information...
commit 7726bd4682e267a7bd2ca4f3433d97bee8006129 1 parent 1705d5a
@norm2782 norm2782 authored
View
32 src/Snap/Auth.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
{-|
This module provides simple and secure high-level authentication
@@ -26,6 +28,7 @@ module Snap.Auth
, UserId(..)
, ExternalUserId(..)
, Password(..)
+ , AuthFailure(..)
-- * Crypto Stuff You May Need
, HashFunc
@@ -63,6 +66,16 @@ data Password = ClearText ByteString
| Encrypted ByteString
deriving (Read, Show, Ord, Eq)
+
+------------------------------------------------------------------------------
+-- | 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
@@ -193,7 +206,7 @@ class (MonadSnap m, MonadSession m) => MonadAuth m where
authAuthenticationKeys :: m [ByteString]
authAuthenticationKeys = return ["email"]
-
+
-- | Cookie name for the remember token
authRememberCookieName :: m ByteString
authRememberCookieName = return "auth_remember_token"
@@ -220,6 +233,7 @@ class (MonadSnap m, MonadSession m) => MonadAuth m where
+
------------------------------------------------------------------------------
-- | Authenticates a user using user-supplied 'ExternalUserId'.
--
@@ -230,19 +244,19 @@ authenticate :: MonadAuthUser m t
=> ExternalUserId -- ^ External user identifiers
-> ByteString -- ^ Password
-> Bool -- ^ Remember user?
- -> m (Maybe (AuthUser, t))
+ -> m (Either AuthFailure (AuthUser, t))
authenticate uid password remember = do
hf <- authHash
user <- getUserExternal uid
case user of
- Nothing -> return Nothing
+ Nothing -> return $ Left ExternalIdFailure
Just user'@(u', _) -> case check hf password u' of
True -> do
markLogin user'
- return user
+ return $ Right user'
False -> do
markLoginFail user'
- return Nothing
+ return $ Left PasswordFailure
where
check hf p u = checkSalt hf p $ mkSaltedHash u
@@ -292,7 +306,7 @@ authenticate uid password remember = do
setSecureCookie cn site_key token (Just to)
return $ u { userPersistenceToken = Just token }
-
+
-- $higherlevel
-- These are the key functions you will use in your handlers. Once you have set
@@ -307,12 +321,12 @@ 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
+ -> m (Either AuthFailure (AuthUser, t))
+performLogin euid p r = authenticate euid p r >>= either (return . Left) login
where
login x@(user, _) = do
setSessionUserId (userId user)
- return (Just x)
+ return (Right x)
------------------------------------------------------------------------------
View
10 src/Snap/Auth/Handlers.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
{-|
Provides generic, somewhat customizable handlers that can be plugged
@@ -29,7 +31,7 @@ loginHandler :: MonadAuthUser m t
-- ^ The password param field
-> Maybe ByteString
-- ^ Remember field; Nothing if you want to remember function.
- -> m a
+ -> (AuthFailure -> m a)
-- ^ Upon failure
-> m a
-- ^ Upon success
@@ -40,9 +42,9 @@ loginHandler pwdf remf loginFailure loginSuccess = do
remember <- maybe (return Nothing) getParam remf
let r = maybe False (=="1") remember
mMatch <- case password of
- Nothing -> return Nothing
- Just p -> performLogin euid p r
- maybe loginFailure (const loginSuccess) mMatch
+ Nothing -> return $ Left PasswordFailure
+ Just p -> performLogin euid p r
+ either loginFailure (const loginSuccess) mMatch
------------------------------------------------------------------------------
View
2  src/Snap/Extension/Session/SecureCookie.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
{-|
This is a support module meant to back all session back-end implementations.
Please sign in to comment.
Something went wrong with that request. Please try again.