Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse code

Merge branch 'master' of https://github.com/norm2782/snap-auth into n…

…orm2782-master
  • Loading branch information...
commit 137f9f096642ba3130e6386d5fa172f7c616dbbc 2 parents 96d218e + 7726bd4
Ozgun Ataman authored April 14, 2011
32  src/Snap/Auth.hs
... ...
@@ -1,3 +1,5 @@
  1
+{-# LANGUAGE OverloadedStrings #-}
  2
+
1 3
 {-| 
2 4
 
3 5
   This module provides simple and secure high-level authentication
@@ -26,6 +28,7 @@ module Snap.Auth
26 28
   , UserId(..)
27 29
   , ExternalUserId(..)
28 30
   , Password(..)
  31
+  , AuthFailure(..)
29 32
 
30 33
   -- * Crypto Stuff You May Need
31 34
   , HashFunc
@@ -63,6 +66,16 @@ data Password = ClearText ByteString
63 66
               | Encrypted ByteString
64 67
               deriving (Read, Show, Ord, Eq)
65 68
 
  69
+
  70
+------------------------------------------------------------------------------
  71
+-- | Authentication failures indicate what went wrong during authentication.
  72
+-- They may provide useful information to the developer, although it is
  73
+-- generally not advisable to show the user the exact details about why login
  74
+-- failed.
  75
+data AuthFailure = ExternalIdFailure
  76
+                 | PasswordFailure
  77
+                 deriving (Read, Show, Ord, Eq)
  78
+
66 79
 ------------------------------------------------------------------------------
67 80
 -- | Type representing the concept of a User in your application.
68 81
 data AuthUser = AuthUser 
@@ -193,7 +206,7 @@ class (MonadSnap m, MonadSession m) => MonadAuth m where
193 206
     authAuthenticationKeys :: m [ByteString]
194 207
     authAuthenticationKeys = return ["email"]
195 208
 
196  
-    
  209
+
197 210
     -- | Cookie name for the remember token
198 211
     authRememberCookieName :: m ByteString
199 212
     authRememberCookieName = return "auth_remember_token"
@@ -225,6 +238,7 @@ class (MonadSnap m, MonadSession m) => MonadAuth m where
225 238
 
226 239
 
227 240
 
  241
+
228 242
 ------------------------------------------------------------------------------
229 243
 -- | Authenticates a user using user-supplied 'ExternalUserId'.
230 244
 --
@@ -235,19 +249,19 @@ authenticate :: MonadAuthUser m t
235 249
              => ExternalUserId        -- ^ External user identifiers
236 250
              -> ByteString            -- ^ Password
237 251
              -> Bool                  -- ^ Remember user?
238  
-             -> m (Maybe (AuthUser, t))      
  252
+             -> m (Either AuthFailure (AuthUser, t))      
239 253
 authenticate uid password remember = do
240 254
     hf <- authHash
241 255
     user <- getUserExternal uid
242 256
     case user of
243  
-      Nothing -> return Nothing
  257
+      Nothing            -> return $ Left ExternalIdFailure
244 258
       Just user'@(u', _) -> case check hf password u' of
245 259
         True -> do
246 260
           markLogin user'
247  
-          return user
  261
+          return $ Right user'
248 262
         False -> do
249 263
           markLoginFail user'
250  
-          return Nothing
  264
+          return $ Left PasswordFailure
251 265
     where
252 266
       check hf p u = checkSalt hf p $ mkSaltedHash u
253 267
 
@@ -297,7 +311,7 @@ authenticate uid password remember = do
297 311
             setSecureCookie cn site_key token (Just to)
298 312
             return $ u { userPersistenceToken = Just token }
299 313
 
300  
-        
  314
+
301 315
 
302 316
 -- $higherlevel
303 317
 -- These are the key functions you will use in your handlers. Once you have set
@@ -312,12 +326,12 @@ performLogin :: MonadAuthUser m t
312 326
              => ExternalUserId        -- ^ External user identifiers
313 327
              -> ByteString            -- ^ Password
314 328
              -> Bool                  -- ^ Remember user?
315  
-             -> m (Maybe (AuthUser, t))      
316  
-performLogin euid p r = authenticate euid p r >>= maybe (return Nothing) login
  329
+             -> m (Either AuthFailure (AuthUser, t))      
  330
+performLogin euid p r = authenticate euid p r >>= either (return . Left) login
317 331
   where 
318 332
     login x@(user, _) = do
319 333
       setSessionUserId (userId user) 
320  
-      return (Just x)
  334
+      return (Right x)
321 335
 
322 336
 
323 337
 ------------------------------------------------------------------------------
10  src/Snap/Auth/Handlers.hs
... ...
@@ -1,3 +1,5 @@
  1
+{-# LANGUAGE OverloadedStrings #-}
  2
+
1 3
 {-|
2 4
 
3 5
   Provides generic, somewhat customizable handlers that can be plugged 
@@ -34,7 +36,7 @@ loginHandler :: MonadAuthUser m t
34 36
              -- ^ The password param field
35 37
              -> Maybe ByteString
36 38
              -- ^ Remember field; Nothing if you want to remember function.
37  
-             -> m a 
  39
+             -> (AuthFailure -> m a)
38 40
              -- ^ Upon failure
39 41
              -> m a 
40 42
              -- ^ Upon success
@@ -45,9 +47,9 @@ loginHandler pwdf remf loginFailure loginSuccess = do
45 47
     remember <- maybe (return Nothing) getParam remf
46 48
     let r = maybe False (=="1") remember
47 49
     mMatch <- case password of
48  
-      Nothing -> return Nothing
49  
-      Just p -> performLogin euid p r
50  
-    maybe loginFailure (const loginSuccess) mMatch
  50
+      Nothing -> return $ Left PasswordFailure
  51
+      Just p  -> performLogin euid p r
  52
+    either loginFailure (const loginSuccess) mMatch
51 53
 
52 54
 
53 55
 ------------------------------------------------------------------------------
2  src/Snap/Extension/Session/SecureCookie.hs
... ...
@@ -1,3 +1,5 @@
  1
+{-# LANGUAGE OverloadedStrings #-}
  2
+
1 3
 {-|
2 4
 
3 5
   This is a support module meant to back all session back-end implementations.

0 notes on commit 137f9f0

Please sign in to comment.
Something went wrong with that request. Please try again.