Skip to content
This repository
Browse code

Restructured auth snaplet to improve haddock structure. Other misc wo…

…rk on

docs and tests.
  • Loading branch information...
commit e88b397294af2fcb7adbf5e4604e3022a91e056d 1 parent b494ed1
Doug Beardsley authored October 11, 2011
3  examples/App.hs
@@ -17,8 +17,7 @@ import           Snap.Snaplet
17 17
 import           Snap.Snaplet.Heist
18 18
 import           Snap.Snaplet.Session
19 19
 import           Snap.Snaplet.Session.Backends.CookieSession
20  
-import           Snap.Snaplet.Auth
21  
-import           Snap.Snaplet.Auth.Handlers
  20
+import           Snap.Snaplet.Auth hiding (session)
22 21
 import           Snap.Snaplet.Auth.Backends.JsonFile
23 22
 import           Text.Templating.Heist
24 23
 
36  snap.cabal
@@ -51,10 +51,6 @@ Library
51 51
     Snap.Snaplet,
52 52
     Snap.Snaplet.Heist,
53 53
     Snap.Snaplet.Auth,
54  
-    Snap.Snaplet.Auth.AuthManager,
55  
-    Snap.Snaplet.Auth.Types,
56  
-    Snap.Snaplet.Auth.Handlers,
57  
-    Snap.Snaplet.Auth.SpliceHelpers,
58 54
     Snap.Snaplet.Auth.Backends.JsonFile,
59 55
     Snap.Snaplet.Session,
60 56
     Snap.Snaplet.Session.Backends.CookieSession
@@ -62,7 +58,11 @@ Library
62 58
   other-modules:
63 59
     Snap.Loader.Devel.Evaluator,
64 60
     Snap.Loader.Devel.Signal,
65  
-    Snap.Loader.Devel.TreeWatcher
  61
+    Snap.Loader.Devel.TreeWatcher,
  62
+    Snap.Snaplet.Auth.AuthManager,
  63
+    Snap.Snaplet.Auth.Types,
  64
+    Snap.Snaplet.Auth.Handlers,
  65
+    Snap.Snaplet.Auth.SpliceHelpers,
66 66
     Snap.Snaplet.HeistNoClass,
67 67
     Snap.Snaplet.Internal.Initializer,
68 68
     Snap.Snaplet.Internal.LensT,
@@ -163,32 +163,6 @@ Executable snap
163 163
     ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
164 164
                  -fno-warn-orphans
165 165
 
166  
-Executable app
167  
-  hs-source-dirs: src, examples
168  
-  main-is: App.hs
169  
-
170  
-  build-depends:
171  
-    base                >= 4        && < 5,
172  
-    bytestring,
173  
-    mtl                 >= 2,
174  
-    old-locale,
175  
-    old-time,
176  
-    snap-core           >= 0.6      && < 0.7,
177  
-    snap-server         >= 0.6      && < 0.7,
178  
-    template-haskell    >= 2.3      && < 2.7,
179  
-    text                >= 0.11     && <0.12,
180  
-    time,
181  
-    unix-compat
182  
-
183  
-  ghc-prof-options: -prof -auto-all
184  
-
185  
-  if impl(ghc >= 6.12.0)
186  
-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
187  
-                 -fno-warn-orphans -fno-warn-unused-do-bind
188  
-  else
189  
-    ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2
190  
-                 -fno-warn-orphans
191  
-
192 166
 source-repository head
193 167
   type:     git
194 168
   location: https://github.com/snapframework/snap.git
341  src/Snap/Snaplet/Auth.hs
@@ -34,340 +34,39 @@ module Snap.Snaplet.Auth
34 34
   , checkPasswordAndLogin
35 35
 
36 36
   -- * Types
37  
-  , AuthManager
38  
-  , IAuthBackend
  37
+  , AuthManager(..)
  38
+  , IAuthBackend(..)
39 39
   , AuthSettings(..)
40 40
   , defAuthSettings
41 41
   , AuthUser(..)
  42
+  , defAuthUser
42 43
   , UserId(..)
43 44
   , Password(..)
44 45
   , AuthFailure(..)
45 46
   , BackendError(..)
  47
+  , Role(..)
46 48
 
47 49
   -- * Other Utilities
  50
+  , encryptPassword
  51
+  , checkPassword
48 52
   , authenticatePassword
49 53
   , setPassword
50  
-  )
51  
-  where
52  
-
53  
-import           Control.Monad.State
54  
-import           Data.ByteString (ByteString)
55  
-import           Data.Maybe (isJust)
56  
-import           Data.Serialize hiding (get)
57  
-import           Data.Time
58  
-import           Data.Text.Encoding (decodeUtf8)
59  
-import           Data.Text (Text)
60  
-import           Web.ClientSession
61  
-
62  
-import           Snap.Core
63  
-import           Snap.Snaplet
64  
-import qualified Snap.Snaplet.Auth.AuthManager as AM
65  
-import           Snap.Snaplet.Auth.AuthManager (IAuthBackend(..), AuthManager(..))
66  
-import           Snap.Snaplet.Auth.Types
67  
-import           Snap.Snaplet.Session
68  
-import           Snap.Snaplet.Session.Common
69  
-import           Snap.Snaplet.Session.SecureCookie
70  
-
71  
-
72  
-
73  
-------------------------------------------------------------------------------
74  
--- Higher level functions 
75  
---
76  
-------------------------------------------------------------------------------
77  
-
78  
-
79  
-------------------------------------------------------------------------------
80  
--- | Create a new user from just a username and password
81  
---
82  
--- May throw a "DuplicateLogin" if given username is not unique
83  
-createUser
84  
-  :: Text -- Username
85  
-  -> ByteString -- Password
86  
-  -> Handler b (AuthManager b) AuthUser
87  
-createUser unm pwd = do
88  
-  (AuthManager r _ _ _ _ _ _ _) <- get
89  
-  liftIO $ AM.createUser r unm pwd
90  
-
91  
-
92  
-------------------------------------------------------------------------------
93  
--- | Lookup a user by her username, check given password and perform login
94  
-loginByUsername
95  
-  :: ByteString       -- ^ Username/login for user
96  
-  -> Password         -- ^ Should be ClearText
97  
-  -> Bool             -- ^ Set remember token?
98  
-  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
99  
-loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
100  
-loginByUsername unm pwd rm  = do
101  
-  AuthManager r _ _ _ cn rp sk _ <- get
102  
-  au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
103  
-  case au of
104  
-    Nothing  -> return $ Left UserNotFound
105  
-    Just au' -> do
106  
-      res <- checkPasswordAndLogin au' pwd
107  
-      case res of
108  
-        Left e -> return $ Left e
109  
-        Right au'' -> do
110  
-          case rm of
111  
-            True -> do
112  
-              token <- liftIO $ randomToken 64
113  
-              setRememberToken sk cn rp token
114  
-              let au''' = au'' { userRememberToken = Just (decodeUtf8 token) }
115  
-              saveUser au'''
116  
-              return $ Right au'''
117  
-            False -> return $ Right au''
118  
-
119  
-
120  
-------------------------------------------------------------------------------
121  
--- | Remember user from the remember token if possible and perform login
122  
-loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
123  
-loginByRememberToken = do
124  
-  (AuthManager r _ _ _ rc rp sk _) <- get
125  
-  token <- getRememberToken sk rc rp
126  
-  au <- maybe (return Nothing) (liftIO . lookupByRememberToken r . decodeUtf8) token
127  
-  case au of
128  
-    Just au' -> forceLogin au' >> return au
129  
-    Nothing -> return Nothing
130  
-
131  
-
132  
-------------------------------------------------------------------------------
133  
--- | Logout the active user
134  
-logout :: Handler b (AuthManager b) ()
135  
-logout = do 
136  
-  s <- gets session
137  
-  withTop s $ withSession s removeSessionUserId 
138  
-  AuthManager _ _ _ _ rc _ _ _ <- get
139  
-  forgetRememberToken rc
140  
-  modify (\mgr -> mgr { activeUser = Nothing } )
141  
-
142  
-
143  
-------------------------------------------------------------------------------
144  
--- | Return the current user; trying to remember from cookie if possible.
145  
-currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
146  
-currentUser = cacheOrLookup f
147  
-  where 
148  
-    f = do
149  
-      (AuthManager r s _ _ _ _ _ _) <- get
150  
-      uid <- withTop s getSessionUserId 
151  
-      case uid of
152  
-        Nothing -> loginByRememberToken 
153  
-        Just uid' -> liftIO $ lookupByUserId r uid'
154  
-
155  
-
156  
-------------------------------------------------------------------------------
157  
--- | Convenience wrapper around 'rememberUser' that returns a bool result
158  
-isLoggedIn :: Handler b (AuthManager b) Bool
159  
-isLoggedIn = isJust `fmap` currentUser
160  
-
161  
-
162  
-------------------------------------------------------------------------------
163  
--- | Create or update a given user
164  
---
165  
--- May throw a 'BackendError' if something goes wrong.
166  
-saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
167  
-saveUser u = do
168  
-  (AuthManager r _ _ _ _ _ _ _) <- get
169  
-  liftIO $ save r u
170  
-
171  
-
172  
-------------------------------------------------------------------------------
173  
--- | Destroy the given user
174  
---
175  
--- May throw a 'BackendError' if something goes wrong.
176  
-destroyUser :: AuthUser -> Handler b (AuthManager b) ()
177  
-destroyUser u = do
178  
-  (AuthManager r _ _ _ _ _ _ _) <- get
179  
-  liftIO $ destroy r u
180  
-
181  
-
182  
-------------------------------------------------------------------------------
183  
---  Lower level helper functions
184  
---
185  
-------------------------------------------------------------------------------
186  
-
187  
-
188  
-------------------------------------------------------------------------------
189  
--- | Mutate an 'AuthUser', marking failed authentication
190  
---
191  
--- This will save the user to the backend.
192  
-markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
193  
-markAuthFail u = do
194  
-  (AuthManager r _ _ _ _ _ _ lo) <- get
195  
-  incFailCtr u >>= checkLockout lo >>= liftIO . save r
196  
-  where
197  
-    incFailCtr u' = return $ u' 
198  
-                      { userFailedLoginCount = userFailedLoginCount u' + 1}
199  
-    checkLockout lo u' = case lo of
200  
-      Nothing -> return u'
201  
-      Just (mx, wait) -> 
202  
-        case userFailedLoginCount u' >= mx of
203  
-          True -> do
204  
-            now <- liftIO getCurrentTime
205  
-            let reopen = addUTCTime wait now
206  
-            return $ u' { userLockedOutUntil = Just reopen }
207  
-
208  
-
209  
-------------------------------------------------------------------------------
210  
--- | Mutate an 'AuthUser', marking successful authentication
211  
---
212  
--- This will save the user to the backend.
213  
-markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
214  
-markAuthSuccess u = do
215  
-  (AuthManager r _ _ _ _ _ _ _) <- get
216  
-  incLoginCtr u >>= updateIp >>= updateLoginTS 
217  
-    >>= resetFailCtr >>= liftIO . save r
218  
-  where
219  
-    incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }
220  
-    updateIp u' = do
221  
-      ip <- rqRemoteAddr `fmap` getRequest 
222  
-      return $ u' { userLastLoginIp = userCurrentLoginIp u'
223  
-                  , userCurrentLoginIp = Just ip }
224  
-    updateLoginTS u' = do
225  
-      now <- liftIO getCurrentTime
226  
-      return $
227  
-        u' { userCurrentLoginAt = Just now
228  
-           , userLastLoginAt = userCurrentLoginAt u' }
229  
-    resetFailCtr u' = return $ 
230  
-      u' { userFailedLoginCount = 0 
231  
-         , userLockedOutUntil = Nothing }
232  
-
233  
-
234  
-------------------------------------------------------------------------------
235  
--- | Authenticate and log the user into the current session if successful.
236  
---
237  
--- This is a mid-level function exposed to allow roll-your-own ways of looking
238  
--- up a user from the database.
239  
---
240  
--- This function will:
241  
---
242  
--- 1. Check the password
243  
---
244  
--- 2. Login the user into the current session
245  
---
246  
--- 3. Mark success/failure of the authentication trial on the user record
247  
-checkPasswordAndLogin
248  
-  :: AuthUser               -- ^ An existing user, somehow looked up from db
249  
-  -> Password               -- ^ A ClearText password
250  
-  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
251  
-checkPasswordAndLogin u pw = 
252  
-  case userLockedOutUntil u of
253  
-    Just x -> do
254  
-      now <- liftIO getCurrentTime
255  
-      if now > x 
256  
-        then auth u
257  
-        else return . Left $ LockedOut x
258  
-    Nothing -> auth u
259  
-  where
260  
-    auth user = 
261  
-      case authenticatePassword user pw of
262  
-        Just e -> do
263  
-          markAuthFail user
264  
-          return $ Left e
265  
-        Nothing -> do
266  
-          forceLogin user 
267  
-          modify (\mgr -> mgr { activeUser = Just user })
268  
-          user' <- markAuthSuccess user
269  
-          return $ Right user'
270  
-
271  
-
272  
-------------------------------------------------------------------------------
273  
--- | Login and persist the given 'AuthUser' in the active session
274  
---
275  
--- Meant to be used if you have other means of being sure that the person is
276  
--- who she says she is.
277  
-forceLogin 
278  
-  :: AuthUser
279  
-  -- ^ An existing user, somehow looked up from db
280  
-  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
281  
-forceLogin u = do
282  
-  AuthManager _ s _ _ _ _ _ _ <- get
283  
-  withSession s $ do
284  
-    case userId u of
285  
-      Just x -> do
286  
-        withTop s (setSessionUserId x) 
287  
-        return $ Right u
288  
-      Nothing -> return . Left $ 
289  
-        AuthError "forceLogin: Can't force the login of a user without userId"
290  
-
291  
-
292  
-
293  
-------------------------------------------------------------------------------
294  
--- Internal, non-exported helpers
295  
---
296  
-------------------------------------------------------------------------------
297  
-
298  
-
299  
-getRememberToken :: (Serialize t, MonadSnap m)
300  
-                 => Key
301  
-                 -> ByteString
302  
-                 -> Maybe Int
303  
-                 -> m (Maybe t)
304  
-getRememberToken sk rc rp = getSecureCookie rc sk rp
305 54
 
  55
+  -- * Handlers
  56
+  , registerUser
  57
+  , loginUser
  58
+  , logoutUser
  59
+  , requireUser
306 60
 
307  
-setRememberToken :: (Serialize t, MonadSnap m)
308  
-                 => Key
309  
-                 -> ByteString
310  
-                 -> Maybe Int
311  
-                 -> t
312  
-                 -> m ()
313  
-setRememberToken sk rc rp token = setSecureCookie rc sk rp token
314  
-
315  
-
316  
-forgetRememberToken :: MonadSnap m => ByteString -> m ()
317  
-forgetRememberToken rc = expireCookie rc (Just "/")
318  
-
319  
-                                       
320  
-------------------------------------------------------------------------------
321  
--- | Set the current user's 'UserId' in the active session
322  
-setSessionUserId :: UserId -> Handler b SessionManager ()
323  
-setSessionUserId (UserId t) = setInSession "__user_id" t
324  
-
325  
-
326  
-------------------------------------------------------------------------------
327  
--- | Remove 'UserId' from active session, effectively logging the user out.
328  
-removeSessionUserId :: Handler b SessionManager ()
329  
-removeSessionUserId = deleteFromSession "__user_id"
330  
-
331  
-
332  
-------------------------------------------------------------------------------
333  
--- | Get the current user's 'UserId' from the active session
334  
-getSessionUserId :: Handler b SessionManager (Maybe UserId)
335  
-getSessionUserId = do
336  
-  uid <- getFromSession "__user_id" 
337  
-  return $ uid >>= return . UserId
338  
-
339  
-
340  
-------------------------------------------------------------------------------
341  
--- | Check password for a given user. 
342  
---
343  
--- Returns "Nothing" if check is successful and an "IncorrectPassword" error
344  
--- otherwise
345  
-authenticatePassword 
346  
-  :: AuthUser        -- ^ Looked up from the back-end
347  
-  -> Password        -- ^ Check against this password
348  
-  -> Maybe AuthFailure
349  
-authenticatePassword u pw = auth
  61
+  -- * Splice helpers
  62
+  , addAuthSplices
  63
+  , ifLoggedIn
  64
+  , ifLoggedOut
  65
+  )
350 66
   where
351  
-    auth = case userPassword u of
352  
-      Nothing -> Just PasswordMissing
353  
-      Just upw -> check $ checkPassword pw upw 
354  
-    check b = if b then Nothing else Just IncorrectPassword
355  
-
356  
-
357  
-------------------------------------------------------------------------------
358  
--- | Wrap lookups around request-local cache
359  
-cacheOrLookup 
360  
-  :: Handler b (AuthManager b) (Maybe AuthUser)
361  
-  -- ^ Lookup action to perform if request local cache is empty
362  
-  -> Handler b (AuthManager b) (Maybe AuthUser)
363  
-cacheOrLookup f = do
364  
-  au <- gets activeUser
365  
-  if isJust au 
366  
-    then return au
367  
-    else do
368  
-      au' <- f
369  
-      modify (\mgr -> mgr { activeUser = au' })
370  
-      return au'
371  
-
372 67
 
  68
+import           Snap.Snaplet.Auth.AuthManager
  69
+import           Snap.Snaplet.Auth.Handlers
  70
+import           Snap.Snaplet.Auth.SpliceHelpers
  71
+import           Snap.Snaplet.Auth.Types
373 72
 
6  src/Snap/Snaplet/Auth/AuthManager.hs
@@ -14,7 +14,7 @@ module Snap.Snaplet.Auth.AuthManager
14 14
   , IAuthBackend(..)
15 15
 
16 16
   -- * Context-free Operations 
17  
-  , createUser
  17
+  , buildAuthUser
18 18
 
19 19
 ) where
20 20
 
@@ -33,7 +33,7 @@ import           Snap.Snaplet.Auth.Types
33 33
 -- | Create a new user from just a username and password
34 34
 --
35 35
 -- May throw a "DuplicateLogin" if given username is not unique
36  
-createUser
  36
+buildAuthUser
37 37
   :: (IAuthBackend r) 
38 38
   => r
39 39
   -- ^ An auth backend
@@ -42,7 +42,7 @@ createUser
42 42
   -> ByteString 
43 43
   -- ^ Password
44 44
   -> IO AuthUser
45  
-createUser r unm pass = do
  45
+buildAuthUser r unm pass = do
46 46
   now <- getCurrentTime
47 47
   let au = defAuthUser {
48 48
               userLogin = unm
2  src/Snap/Snaplet/Auth/Backends/JsonFile.hs
@@ -28,7 +28,7 @@ import           System.Directory
28 28
 
29 29
 import           Snap.Snaplet
30 30
 import           Snap.Snaplet.Auth.Types
31  
-import           Snap.Snaplet.Auth.AuthManager hiding (createUser)
  31
+import           Snap.Snaplet.Auth.AuthManager
32 32
 import           Snap.Snaplet.Session
33 33
 
34 34
 
321  src/Snap/Snaplet/Auth/Handlers.hs
@@ -10,23 +10,327 @@
10 10
 
11 11
 -}
12 12
 
13  
-module Snap.Snaplet.Auth.Handlers 
14  
-  ( 
15  
-    registerUser
16  
-  , loginUser
17  
-  , logoutUser
18  
-  , requireUser
19  
-  ) where
  13
+module Snap.Snaplet.Auth.Handlers where
20 14
 
21 15
 import           Control.Monad.CatchIO (throw)
22 16
 import           Control.Monad.State
23 17
 import           Data.ByteString (ByteString)
24 18
 import           Data.Lens.Lazy
  19
+import           Data.Maybe (isJust)
  20
+import           Data.Serialize hiding (get)
  21
+import           Data.Time
25 22
 import           Data.Text.Encoding (decodeUtf8)
  23
+import           Data.Text (Text)
  24
+import           Web.ClientSession
26 25
 
27 26
 import           Snap.Core
28  
-import           Snap.Snaplet.Auth
29 27
 import           Snap.Snaplet
  28
+import           Snap.Snaplet.Auth.AuthManager
  29
+import           Snap.Snaplet.Auth.Types
  30
+import           Snap.Snaplet.Session
  31
+import           Snap.Snaplet.Session.Common
  32
+import           Snap.Snaplet.Session.SecureCookie
  33
+
  34
+
  35
+
  36
+------------------------------------------------------------------------------
  37
+-- Higher level functions 
  38
+------------------------------------------------------------------------------
  39
+
  40
+
  41
+------------------------------------------------------------------------------
  42
+-- | Create a new user from just a username and password
  43
+--
  44
+-- May throw a "DuplicateLogin" if given username is not unique
  45
+createUser
  46
+  :: Text -- Username
  47
+  -> ByteString -- Password
  48
+  -> Handler b (AuthManager b) AuthUser
  49
+createUser unm pwd = do
  50
+  (AuthManager r _ _ _ _ _ _ _) <- get
  51
+  liftIO $ buildAuthUser r unm pwd
  52
+
  53
+
  54
+------------------------------------------------------------------------------
  55
+-- | Lookup a user by her username, check given password and perform login
  56
+loginByUsername
  57
+  :: ByteString       -- ^ Username/login for user
  58
+  -> Password         -- ^ Should be ClearText
  59
+  -> Bool             -- ^ Set remember token?
  60
+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
  61
+loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
  62
+loginByUsername unm pwd rm  = do
  63
+  AuthManager r _ _ _ cn rp sk _ <- get
  64
+  au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
  65
+  case au of
  66
+    Nothing  -> return $ Left UserNotFound
  67
+    Just au' -> do
  68
+      res <- checkPasswordAndLogin au' pwd
  69
+      case res of
  70
+        Left e -> return $ Left e
  71
+        Right au'' -> do
  72
+          case rm of
  73
+            True -> do
  74
+              token <- liftIO $ randomToken 64
  75
+              setRememberToken sk cn rp token
  76
+              let au''' = au'' { userRememberToken = Just (decodeUtf8 token) }
  77
+              saveUser au'''
  78
+              return $ Right au'''
  79
+            False -> return $ Right au''
  80
+
  81
+
  82
+------------------------------------------------------------------------------
  83
+-- | Remember user from the remember token if possible and perform login
  84
+loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
  85
+loginByRememberToken = do
  86
+  (AuthManager r _ _ _ rc rp sk _) <- get
  87
+  token <- getRememberToken sk rc rp
  88
+  au <- maybe (return Nothing) (liftIO . lookupByRememberToken r . decodeUtf8) token
  89
+  case au of
  90
+    Just au' -> forceLogin au' >> return au
  91
+    Nothing -> return Nothing
  92
+
  93
+
  94
+------------------------------------------------------------------------------
  95
+-- | Logout the active user
  96
+logout :: Handler b (AuthManager b) ()
  97
+logout = do 
  98
+  s <- gets session
  99
+  withTop s $ withSession s removeSessionUserId 
  100
+  AuthManager _ _ _ _ rc _ _ _ <- get
  101
+  forgetRememberToken rc
  102
+  modify (\mgr -> mgr { activeUser = Nothing } )
  103
+
  104
+
  105
+------------------------------------------------------------------------------
  106
+-- | Return the current user; trying to remember from cookie if possible.
  107
+currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
  108
+currentUser = cacheOrLookup f
  109
+  where 
  110
+    f = do
  111
+      (AuthManager r s _ _ _ _ _ _) <- get
  112
+      uid <- withTop s getSessionUserId 
  113
+      case uid of
  114
+        Nothing -> loginByRememberToken 
  115
+        Just uid' -> liftIO $ lookupByUserId r uid'
  116
+
  117
+
  118
+------------------------------------------------------------------------------
  119
+-- | Convenience wrapper around 'rememberUser' that returns a bool result
  120
+isLoggedIn :: Handler b (AuthManager b) Bool
  121
+isLoggedIn = isJust `fmap` currentUser
  122
+
  123
+
  124
+------------------------------------------------------------------------------
  125
+-- | Create or update a given user
  126
+--
  127
+-- May throw a 'BackendError' if something goes wrong.
  128
+saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
  129
+saveUser u = do
  130
+  (AuthManager r _ _ _ _ _ _ _) <- get
  131
+  liftIO $ save r u
  132
+
  133
+
  134
+------------------------------------------------------------------------------
  135
+-- | Destroy the given user
  136
+--
  137
+-- May throw a 'BackendError' if something goes wrong.
  138
+destroyUser :: AuthUser -> Handler b (AuthManager b) ()
  139
+destroyUser u = do
  140
+  (AuthManager r _ _ _ _ _ _ _) <- get
  141
+  liftIO $ destroy r u
  142
+
  143
+
  144
+------------------------------------------------------------------------------
  145
+--  Lower level helper functions
  146
+--
  147
+------------------------------------------------------------------------------
  148
+
  149
+
  150
+------------------------------------------------------------------------------
  151
+-- | Mutate an 'AuthUser', marking failed authentication
  152
+--
  153
+-- This will save the user to the backend.
  154
+markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
  155
+markAuthFail u = do
  156
+  (AuthManager r _ _ _ _ _ _ lo) <- get
  157
+  incFailCtr u >>= checkLockout lo >>= liftIO . save r
  158
+  where
  159
+    incFailCtr u' = return $ u' 
  160
+                      { userFailedLoginCount = userFailedLoginCount u' + 1}
  161
+    checkLockout lo u' = case lo of
  162
+      Nothing -> return u'
  163
+      Just (mx, wait) -> 
  164
+        case userFailedLoginCount u' >= mx of
  165
+          True -> do
  166
+            now <- liftIO getCurrentTime
  167
+            let reopen = addUTCTime wait now
  168
+            return $ u' { userLockedOutUntil = Just reopen }
  169
+
  170
+
  171
+------------------------------------------------------------------------------
  172
+-- | Mutate an 'AuthUser', marking successful authentication
  173
+--
  174
+-- This will save the user to the backend.
  175
+markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
  176
+markAuthSuccess u = do
  177
+  (AuthManager r _ _ _ _ _ _ _) <- get
  178
+  incLoginCtr u >>= updateIp >>= updateLoginTS 
  179
+    >>= resetFailCtr >>= liftIO . save r
  180
+  where
  181
+    incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }
  182
+    updateIp u' = do
  183
+      ip <- rqRemoteAddr `fmap` getRequest 
  184
+      return $ u' { userLastLoginIp = userCurrentLoginIp u'
  185
+                  , userCurrentLoginIp = Just ip }
  186
+    updateLoginTS u' = do
  187
+      now <- liftIO getCurrentTime
  188
+      return $
  189
+        u' { userCurrentLoginAt = Just now
  190
+           , userLastLoginAt = userCurrentLoginAt u' }
  191
+    resetFailCtr u' = return $ 
  192
+      u' { userFailedLoginCount = 0 
  193
+         , userLockedOutUntil = Nothing }
  194
+
  195
+
  196
+------------------------------------------------------------------------------
  197
+-- | Authenticate and log the user into the current session if successful.
  198
+--
  199
+-- This is a mid-level function exposed to allow roll-your-own ways of looking
  200
+-- up a user from the database.
  201
+--
  202
+-- This function will:
  203
+--
  204
+-- 1. Check the password
  205
+--
  206
+-- 2. Login the user into the current session
  207
+--
  208
+-- 3. Mark success/failure of the authentication trial on the user record
  209
+checkPasswordAndLogin
  210
+  :: AuthUser               -- ^ An existing user, somehow looked up from db
  211
+  -> Password               -- ^ A ClearText password
  212
+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
  213
+checkPasswordAndLogin u pw = 
  214
+  case userLockedOutUntil u of
  215
+    Just x -> do
  216
+      now <- liftIO getCurrentTime
  217
+      if now > x 
  218
+        then auth u
  219
+        else return . Left $ LockedOut x
  220
+    Nothing -> auth u
  221
+  where
  222
+    auth user = 
  223
+      case authenticatePassword user pw of
  224
+        Just e -> do
  225
+          markAuthFail user
  226
+          return $ Left e
  227
+        Nothing -> do
  228
+          forceLogin user 
  229
+          modify (\mgr -> mgr { activeUser = Just user })
  230
+          user' <- markAuthSuccess user
  231
+          return $ Right user'
  232
+
  233
+
  234
+------------------------------------------------------------------------------
  235
+-- | Login and persist the given 'AuthUser' in the active session
  236
+--
  237
+-- Meant to be used if you have other means of being sure that the person is
  238
+-- who she says she is.
  239
+forceLogin 
  240
+  :: AuthUser
  241
+  -- ^ An existing user, somehow looked up from db
  242
+  -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
  243
+forceLogin u = do
  244
+  AuthManager _ s _ _ _ _ _ _ <- get
  245
+  withSession s $ do
  246
+    case userId u of
  247
+      Just x -> do
  248
+        withTop s (setSessionUserId x) 
  249
+        return $ Right u
  250
+      Nothing -> return . Left $ 
  251
+        AuthError "forceLogin: Can't force the login of a user without userId"
  252
+
  253
+
  254
+
  255
+------------------------------------------------------------------------------
  256
+-- Internal, non-exported helpers
  257
+--
  258
+------------------------------------------------------------------------------
  259
+
  260
+
  261
+getRememberToken :: (Serialize t, MonadSnap m)
  262
+                 => Key
  263
+                 -> ByteString
  264
+                 -> Maybe Int
  265
+                 -> m (Maybe t)
  266
+getRememberToken sk rc rp = getSecureCookie rc sk rp
  267
+
  268
+
  269
+setRememberToken :: (Serialize t, MonadSnap m)
  270
+                 => Key
  271
+                 -> ByteString
  272
+                 -> Maybe Int
  273
+                 -> t
  274
+                 -> m ()
  275
+setRememberToken sk rc rp token = setSecureCookie rc sk rp token
  276
+
  277
+
  278
+forgetRememberToken :: MonadSnap m => ByteString -> m ()
  279
+forgetRememberToken rc = expireCookie rc (Just "/")
  280
+
  281
+                                       
  282
+------------------------------------------------------------------------------
  283
+-- | Set the current user's 'UserId' in the active session
  284
+setSessionUserId :: UserId -> Handler b SessionManager ()
  285
+setSessionUserId (UserId t) = setInSession "__user_id" t
  286
+
  287
+
  288
+------------------------------------------------------------------------------
  289
+-- | Remove 'UserId' from active session, effectively logging the user out.
  290
+removeSessionUserId :: Handler b SessionManager ()
  291
+removeSessionUserId = deleteFromSession "__user_id"
  292
+
  293
+
  294
+------------------------------------------------------------------------------
  295
+-- | Get the current user's 'UserId' from the active session
  296
+getSessionUserId :: Handler b SessionManager (Maybe UserId)
  297
+getSessionUserId = do
  298
+  uid <- getFromSession "__user_id" 
  299
+  return $ uid >>= return . UserId
  300
+
  301
+
  302
+------------------------------------------------------------------------------
  303
+-- | Check password for a given user. 
  304
+--
  305
+-- Returns "Nothing" if check is successful and an "IncorrectPassword" error
  306
+-- otherwise
  307
+authenticatePassword 
  308
+  :: AuthUser        -- ^ Looked up from the back-end
  309
+  -> Password        -- ^ Check against this password
  310
+  -> Maybe AuthFailure
  311
+authenticatePassword u pw = auth
  312
+  where
  313
+    auth = case userPassword u of
  314
+      Nothing -> Just PasswordMissing
  315
+      Just upw -> check $ checkPassword pw upw 
  316
+    check b = if b then Nothing else Just IncorrectPassword
  317
+
  318
+
  319
+------------------------------------------------------------------------------
  320
+-- | Wrap lookups around request-local cache
  321
+cacheOrLookup 
  322
+  :: Handler b (AuthManager b) (Maybe AuthUser)
  323
+  -- ^ Lookup action to perform if request local cache is empty
  324
+  -> Handler b (AuthManager b) (Maybe AuthUser)
  325
+cacheOrLookup f = do
  326
+  au <- gets activeUser
  327
+  if isJust au 
  328
+    then return au
  329
+    else do
  330
+      au' <- f
  331
+      modify (\mgr -> mgr { activeUser = au' })
  332
+      return au'
  333
+
30 334
 
31 335
 
32 336
 ------------------------------------------------------------------------------
@@ -99,3 +403,4 @@ requireUser
99 403
 requireUser auth bad good = do
100 404
   loggedIn <- withTop auth isLoggedIn
101 405
   if loggedIn then good else bad
  406
+
3  src/Snap/Snaplet/Auth/SpliceHelpers.hs
@@ -21,8 +21,9 @@ import           Data.Lens.Lazy
21 21
 import qualified Text.XmlHtml as X
22 22
 import           Text.Templating.Heist
23 23
 
24  
-import           Snap.Snaplet.Auth
25 24
 import           Snap.Snaplet
  25
+import           Snap.Snaplet.Auth.AuthManager
  26
+import           Snap.Snaplet.Auth.Handlers
26 27
 import           Snap.Snaplet.Heist
27 28
 
28 29
 
2  src/Snap/Snaplet/Auth/Types.hs
@@ -97,6 +97,8 @@ data AuthUser = AuthUser
97 97
   } deriving (Show,Eq)
98 98
 
99 99
 
  100
+------------------------------------------------------------------------------
  101
+-- | Default AuthUser that has all empty values.
100 102
 defAuthUser :: AuthUser
101 103
 defAuthUser = AuthUser {
102 104
     userId = Nothing
3  src/Snap/Snaplet/Heist.hs
@@ -34,6 +34,7 @@ module Snap.Snaplet.Heist
34 34
   , Unclassed.SnapletSplice
35 35
   , Unclassed.liftHeist
36 36
   , Unclassed.liftHandler
  37
+  , Unclassed.liftAppHandler
37 38
   , Unclassed.liftWith
38 39
   , Unclassed.bindSnapletSplices
39 40
 
@@ -88,7 +89,7 @@ addTemplates pfx = withTop' heistLens (Unclassed.addTemplates pfx)
88 89
 
89 90
 ------------------------------------------------------------------------------
90 91
 -- | Adds templates to the Heist TemplateState, and lets you specify where
91  
--- they are fonud in the filesystem.
  92
+-- they are found in the filesystem.
92 93
 addTemplatesAt :: HasHeist b => ByteString -> FilePath -> Initializer b v ()
93 94
 addTemplatesAt pfx p = withTop' heistLens (Unclassed.addTemplatesAt pfx p)
94 95
 
1  test/runTestsAndCoverage.sh
@@ -31,6 +31,7 @@ EXCLUDES='Main
31 31
 Blackbox.App
32 32
 Blackbox.BarSnaplet
33 33
 Blackbox.Common
  34
+Blackbox.EmbeddedSnaplet
34 35
 Blackbox.FooSnaplet
35 36
 Blackbox.Tests
36 37
 Blackbox.Types
1  test/suite/Snap/TestCommon.hs
@@ -32,6 +32,7 @@ testGeneratedProject projName snapInitArgs cabalInstallArgs httpPort
32 32
         flip onException (setCurrentDirectory cwd >>
33 33
                           removeDirectoryRecursive projectPath) $ do
34 34
             makeWorkDirectory projectPath
  35
+            putStrLn $ "Changing directory to "++projectPath
35 36
             setCurrentDirectory projectPath
36 37
             snapExe <- findSnap
37 38
             systemOrDie $ snapExe ++ " init " ++ snapInitArgs
54  test/suite/TestSuite.hs
@@ -4,10 +4,16 @@ module Main where
4 4
 
5 5
 import           Control.Concurrent
6 6
 import           Control.Exception
  7
+import           Control.Monad
  8
+import qualified Data.ByteString.Lazy.Char8 as L
  9
+import qualified Data.ByteString.Char8 as S
  10
+import qualified Network.HTTP.Enumerator as HTTP
7 11
 import           Snap.Http.Server.Config
8 12
 import           Snap.Snaplet
9 13
 import           System.Directory
10  
-import           Test.Framework (defaultMain)
  14
+import           Test.Framework (defaultMain, Test)
  15
+import           Test.Framework.Providers.HUnit
  16
+import           Test.HUnit hiding (Test, path)
11 17
 
12 18
 import           Snap.Http.Server (simpleHttpServe)
13 19
 import           Blackbox.App
@@ -16,6 +22,7 @@ import qualified Snap.Snaplet.Internal.Lensed.Tests
16 22
 import qualified Snap.Snaplet.Internal.LensT.Tests
17 23
 import qualified Snap.Snaplet.Internal.RST.Tests
18 24
 import qualified Snap.Snaplet.Internal.Tests
  25
+import           Snap.TestCommon
19 26
 
20 27
 
21 28
 ------------------------------------------------------------------------------
@@ -25,6 +32,10 @@ main = do
25 32
     Blackbox.Tests.remove "non-cabal-appdir/templates/good.tpl"
26 33
     Blackbox.Tests.removeDir "non-cabal-appdir/snaplets/foosnaplet"
27 34
 
  35
+    -- Test generated projects before we start the test server.
  36
+    -- TODO Get this working properly.  Might have to put in the test list.
  37
+--    defaultMain [testBarebones, testDefault]
  38
+
28 39
     tid <- startServer
29 40
     defaultMain tests
30 41
     throwTo tid UserInterrupt
@@ -34,6 +45,8 @@ main = do
34 45
                 , Snap.Snaplet.Internal.LensT.Tests.tests
35 46
                 , Snap.Snaplet.Internal.RST.Tests.tests
36 47
                 , Snap.Snaplet.Internal.Tests.tests
  48
+--                , testBarebones
  49
+--                , testDefault
37 50
                 ]
38 51
 
39 52
 startServer :: IO ThreadId
@@ -51,17 +64,32 @@ startServer = do
51 64
         doCleanup
52 65
 
53 66
 
54  
---testBarebones :: Test
55  
---testBarebones = testCase "snap/barebones" go
56  
---  where
57  
---    go = testGeneratedProject "barebonesTest"
58  
---                              "-b"
59  
---                              ""
60  
---                              port
61  
---                              testIt
62  
---    port = 9990
63  
---    testIt = do
64  
---        body <- HTTP.simpleHttp "http://127.0.0.1:9990"
65  
---        assertEqual "server not up" "hello world" body
  67
+testBarebones :: Test
  68
+testBarebones = testCase "snap/barebones" go
  69
+  where
  70
+    go = testGeneratedProject "barebonesTest"
  71
+                              "-b"
  72
+                              ""
  73
+                              port
  74
+                              testIt
  75
+    port = 9990
  76
+    testIt = do
  77
+        body <- HTTP.simpleHttp "http://127.0.0.1:9990"
  78
+        assertEqual "server not up" "hello world" body
  79
+
66 80
 
  81
+testDefault :: Test
  82
+testDefault = testCase "snap/default" go
  83
+  where
  84
+    go = testGeneratedProject "defaultTest"
  85
+                              ""
  86
+                              ""
  87
+                              port
  88
+                              testIt
  89
+    port = 9991
  90
+    testIt = do
  91
+        body <- liftM (S.concat . L.toChunks) $
  92
+                HTTP.simpleHttp "http://127.0.0.1:9991"
  93
+        assertBool "response contains phrase 'it works!'"
  94
+                   $ "It works!" `S.isInfixOf` body
67 95
 

0 notes on commit e88b397

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