Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 350 lines (289 sloc) 11.247 kB
492e045 @ozataman Save progress on auth
ozataman authored
1 {-# LANGUAGE ExistentialQuantification #-}
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
2 {-# LANGUAGE OverloadedStrings #-}
492e045 @ozataman Save progress on auth
ozataman authored
3
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
4 {-|
5
6 This module contains all the central authentication functionality.
7
8 It exports a number of high-level functions to be used directly in your
9 application handlers.
10
11 We also export a number of mid-level functions that
12 should be helpful when you are integrating with another way of confirming the
13 authentication of login requests.
14
15 -}
16
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
17 module Snap.Snaplet.Auth
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
18 (
1e94262 @ozataman Add some docs
ozataman authored
19
bf7e64a @ozataman Separate out AuthManager module, break out some functionality
ozataman authored
20 -- * Higher Level Handler Functions
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
21 createUser
4204039 @ozataman Add save/destroy Handlers, more docs
ozataman authored
22 , saveUser
23 , destroyUser
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
24 , loginByUsername
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
25 , loginByRememberToken
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
26 , forceLogin
27 , logout
28 , isLoggedIn
1e94262 @ozataman Add some docs
ozataman authored
29
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
30 -- * Lower Level Functions
1e94262 @ozataman Add some docs
ozataman authored
31 , markAuthSuccess
32 , markAuthFail
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
33 , checkPasswordAndLogin
1e94262 @ozataman Add some docs
ozataman authored
34
35 -- * Types
36 , AuthManager
37 , IAuthBackend
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
38 , AuthSettings(..)
39 , defAuthSettings
1e94262 @ozataman Add some docs
ozataman authored
40 , AuthUser(..)
41 , UserId(..)
42 , Password(..)
43 , AuthFailure(..)
44 , BackendError(..)
45
46 -- * Other Utilities
47 , authenticatePassword
bf7e64a @ozataman Separate out AuthManager module, break out some functionality
ozataman authored
48 , setPassword
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
49 )
50 where
492e045 @ozataman Save progress on auth
ozataman authored
51
52 import Control.Monad.State
53 import Crypto.PasswordStore
54 import qualified Data.ByteString.Char8 as B
55 import Data.ByteString (ByteString)
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
56 import Data.Maybe (isJust)
492e045 @ozataman Save progress on auth
ozataman authored
57 import Data.Time
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
58 import Data.Text.Encoding (decodeUtf8)
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
59 import Data.Text (Text)
b0fadff @mightybyte Alpha release of new snaplet infrastructure.
mightybyte authored
60
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
61 import Snap.Core
492e045 @ozataman Save progress on auth
ozataman authored
62 import Snap.Snaplet
bf7e64a @ozataman Separate out AuthManager module, break out some functionality
ozataman authored
63 import qualified Snap.Snaplet.Auth.AuthManager as AM
64 import Snap.Snaplet.Auth.AuthManager (IAuthBackend(..), AuthManager(..))
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
65 import Snap.Snaplet.Auth.Types
492e045 @ozataman Save progress on auth
ozataman authored
66 import Snap.Snaplet.Session
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
67 import Snap.Snaplet.Session.Common
68 import Snap.Snaplet.Session.SecureCookie
492e045 @ozataman Save progress on auth
ozataman authored
69
70
71
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
72 ------------------------------------------------------------------------------
73 -- Higher level functions
74 --
75 ------------------------------------------------------------------------------
492e045 @ozataman Save progress on auth
ozataman authored
76
77
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
78 ------------------------------------------------------------------------------
79 -- | Create a new user from just a username and password
80 --
81 -- May throw a "DuplicateLogin' if given username is not unique
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
82 createUser
83 :: Text -- Username
84 -> ByteString -- Password
85 -> Handler b (AuthManager b) AuthUser
86 createUser unm pass = do
bf7e64a @ozataman Separate out AuthManager module, break out some functionality
ozataman authored
87 (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
88 liftIO $ AM.createUser r unm pass
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
89
90
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
91 ------------------------------------------------------------------------------
92 -- | Lookup a user by her username, check given password and perform login
93 loginByUsername
94 :: ByteString -- ^ Username/login for user
95 -> Password -- ^ Should be ClearText
96 -> Bool -- ^ Set remember token?
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
97 -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
98 loginByUsername _ (Encrypted _) _ = error "Cannot login with encrypted password"
99 loginByUsername unm pwd rm = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
100 (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
101 au <- liftIO $ lookupByLogin r (decodeUtf8 unm)
102 case au of
f8e9737 @ozataman Get JsonFile backend working, flesh out some more - still got undefineds
ozataman authored
103 Nothing -> return $ Left UserNotFound
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
104 Just au' -> checkPasswordAndLogin au' pwd rm
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
105
492e045 @ozataman Save progress on auth
ozataman authored
106
107 ------------------------------------------------------------------------------
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
108 -- | Remember user from the remember token if possible.
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
109 loginByRememberToken :: Handler b (AuthManager b) (Maybe AuthUser)
110 loginByRememberToken = cacheOrLookup f
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
111 where
112 f = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
113 mgr@(AuthManager r _ _ _ rc rp sk _) <- getSnapletState
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
114 token <- getRememberToken sk rc rp
115 maybe (return Nothing) (liftIO . lookupByRememberToken r . decodeUtf8) token
492e045 @ozataman Save progress on auth
ozataman authored
116
117
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
118 ------------------------------------------------------------------------------
1e94262 @ozataman Add some docs
ozataman authored
119 -- | Logout the active user
492e045 @ozataman Save progress on auth
ozataman authored
120 logout :: Handler b (AuthManager b) ()
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
121 logout = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
122 s <- getsSnapletState session
a7387ee @ozataman Get session changes to persist
ozataman authored
123 withTop s $ withSession s removeSessionUserId
6ac2670 @ozataman Get latest enhancements working
ozataman authored
124 modifySnapletState (\mgr -> mgr { activeUser = Nothing } )
492e045 @ozataman Save progress on auth
ozataman authored
125
126
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
127 ------------------------------------------------------------------------------
128 -- | Return the current user
492e045 @ozataman Save progress on auth
ozataman authored
129 currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
130 currentUser = cacheOrLookup f
131 where
132 f = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
133 mgr@(AuthManager r s _ _ _ _ _ _) <- getSnapletState
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
134 uid <- withTop s getSessionUserId
135 case uid of
136 Nothing -> return Nothing
137 Just uid' -> liftIO $ lookupByUserId r uid'
492e045 @ozataman Save progress on auth
ozataman authored
138
139
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
140 ------------------------------------------------------------------------------
141 -- | Convenience wrapper around 'rememberUser' that returns a bool result
492e045 @ozataman Save progress on auth
ozataman authored
142 isLoggedIn :: Handler b (AuthManager b) Bool
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
143 isLoggedIn = do
144 au <- currentUser
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
145 return $ isJust au
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
146
492e045 @ozataman Save progress on auth
ozataman authored
147
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
148 ------------------------------------------------------------------------------
4204039 @ozataman Add save/destroy Handlers, more docs
ozataman authored
149 -- | Create or update a given user
150 --
151 -- May throw a 'BackendError' if something goes wrong.
6ac2670 @ozataman Get latest enhancements working
ozataman authored
152 saveUser :: AuthUser -> Handler b (AuthManager b) AuthUser
4204039 @ozataman Add save/destroy Handlers, more docs
ozataman authored
153 saveUser u = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
154 (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
4204039 @ozataman Add save/destroy Handlers, more docs
ozataman authored
155 liftIO $ save r u
156
157
158 ------------------------------------------------------------------------------
159 -- | Destroy the given user
160 --
161 -- May throw a 'BackendError' if something goes wrong.
162 destroyUser :: AuthUser -> Handler b (AuthManager b) ()
163 destroyUser u = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
164 (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
4204039 @ozataman Add save/destroy Handlers, more docs
ozataman authored
165 liftIO $ destroy r u
166
167
168 ------------------------------------------------------------------------------
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
169 -- Lower level helper functions
170 --
171 ------------------------------------------------------------------------------
172
492e045 @ozataman Save progress on auth
ozataman authored
173
174 ------------------------------------------------------------------------------
1e94262 @ozataman Add some docs
ozataman authored
175 -- | Mutate an 'AuthUser', marking failed authentication
176 --
177 -- This will save the user to the backend.
492e045 @ozataman Save progress on auth
ozataman authored
178 markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
179 markAuthFail u = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
180 (AuthManager r _ _ _ _ _ _ lo) <- getSnapletState
181 incFailCtr u >>= checkLockout lo >>= liftIO . save r
492e045 @ozataman Save progress on auth
ozataman authored
182 where
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
183 incFailCtr u' = return $ u'
184 { userFailedLoginCount = userFailedLoginCount u' + 1}
6ac2670 @ozataman Get latest enhancements working
ozataman authored
185 checkLockout lo u' = case lo of
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
186 Nothing -> return u'
187 Just (mx, wait) ->
188 case userFailedLoginCount u' >= mx of
189 True -> do
190 now <- liftIO getCurrentTime
191 let reopen = addUTCTime wait now
6ac2670 @ozataman Get latest enhancements working
ozataman authored
192 return $ u' { userLockedOutUntil = Just reopen }
492e045 @ozataman Save progress on auth
ozataman authored
193
194
195 ------------------------------------------------------------------------------
1e94262 @ozataman Add some docs
ozataman authored
196 -- | Mutate an 'AuthUser', marking successful authentication
197 --
198 -- This will save the user to the backend.
492e045 @ozataman Save progress on auth
ozataman authored
199 markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
200 markAuthSuccess u = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
201 (AuthManager r _ _ _ _ _ _ _) <- getSnapletState
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
202 now <- liftIO getCurrentTime
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
203 incLoginCtr u >>= updateIp >>= updateLoginTS
204 >>= resetFailCtr >>= liftIO . save r
492e045 @ozataman Save progress on auth
ozataman authored
205 where
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
206 incLoginCtr u' = return $ u' { userLoginCount = userLoginCount u' + 1 }
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
207 updateIp u' = fail "updateIP not defined in markAuthSuccess"
208 updateLoginTS u' = do
209 now <- liftIO getCurrentTime
210 return $
211 u' { userCurrentLoginAt = Just now
212 , userLastLoginAt = userCurrentLoginAt u' }
213 resetFailCtr u' = return $
214 u' { userFailedLoginCount = 0
215 , userLockedOutUntil = Nothing }
492e045 @ozataman Save progress on auth
ozataman authored
216
217
218 ------------------------------------------------------------------------------
219 -- | Authenticate and log the user into the current session if successful.
220 --
221 -- This is a mid-level function exposed to allow roll-your-own ways of looking
222 -- up a user from the database.
223 --
224 -- This function will:
225 --
226 -- 1. Check the password
227 --
228 -- 2. Login the user into the current session
229 --
230 -- 3. Mark success/failure of the authentication trial on the user record
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
231 checkPasswordAndLogin
1e94262 @ozataman Add some docs
ozataman authored
232 :: AuthUser -- ^ An existing user, somehow looked up from db
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
233 -> Password -- ^ A ClearText password
234 -> Bool -- ^ Set remember cookie?
492e045 @ozataman Save progress on auth
ozataman authored
235 -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
236 checkPasswordAndLogin u pw remember =
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
237 case userLockedOutUntil u of
238 Just x -> do
239 now <- liftIO getCurrentTime
240 if now > x then
b02bb12 @ozataman Fix bug in checkPasswordAndLogin
ozataman authored
241 auth u
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
242 else
b02bb12 @ozataman Fix bug in checkPasswordAndLogin
ozataman authored
243 return . Left $ LockedOut x
244 Nothing -> auth u
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
245 where
246 auth u =
247 case authenticatePassword u pw of
248 Just e -> do
249 markAuthFail u
250 return $ Left e
251 Nothing -> do
252 forceLogin u remember
6ac2670 @ozataman Get latest enhancements working
ozataman authored
253 modifySnapletState (\mgr -> mgr { activeUser = Just u })
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
254 u' <- markAuthSuccess u
255 return $ Right u'
492e045 @ozataman Save progress on auth
ozataman authored
256
257
258 ------------------------------------------------------------------------------
259 -- | Login and persist the given 'AuthUser' in the active session
260 --
261 -- Meant to be used if you have other means of being sure that the person is
262 -- who she says she is.
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
263 --
264 -- TODO: Implement remember cookie
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
265 forceLogin
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
266 :: AuthUser
267 -- ^ An existing user, somehow looked up from db
268 -> Bool
269 -- ^ Set remember cookie?
270 -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
271 forceLogin u rc = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
272 AuthManager _ s _ _ cn rp sk _ <- getSnapletState
a7387ee @ozataman Get session changes to persist
ozataman authored
273 withSession s $ do
274 case userId u of
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
275 Just x -> do
276 withTop s (setSessionUserId x)
277 token <- liftIO $ randomToken 64
278 setRememberToken sk cn rp token
279 return $ Right u
280 Nothing -> return . Left $
281 AuthError "forceLogin: Can't force the login of a user without userId"
282
283
284
285 ------------------------------------------------------------------------------
286 -- Internal, non-exported helpers
287 --
288 ------------------------------------------------------------------------------
289
290
291 getRememberToken sk rc rp = getSecureCookie rc sk rp
492e045 @ozataman Save progress on auth
ozataman authored
292
463de2c @ozataman Get rid of all undefined, tweak some of the API
ozataman authored
293 setRememberToken sk rc rp token = setSecureCookie rc sk rp token
492e045 @ozataman Save progress on auth
ozataman authored
294
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
295
492e045 @ozataman Save progress on auth
ozataman authored
296 ------------------------------------------------------------------------------
297 -- | Set the current user's 'UserId' in the active session
298 setSessionUserId :: UserId -> Handler b SessionManager ()
299 setSessionUserId (UserId t) = setInSession "__user_id" t
300
301
302 ------------------------------------------------------------------------------
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
303 -- | Remove 'UserId' from active session, effectively logging the user out.
304 removeSessionUserId :: Handler b SessionManager ()
305 removeSessionUserId = deleteFromSession "__user_id"
306
307
308 ------------------------------------------------------------------------------
492e045 @ozataman Save progress on auth
ozataman authored
309 -- | Get the current user's 'UserId' from the active session
310 getSessionUserId :: Handler b SessionManager (Maybe UserId)
311 getSessionUserId = do
312 uid <- getFromSession "__user_id"
313 return $ uid >>= return . UserId
314
b0fadff @mightybyte Alpha release of new snaplet infrastructure.
mightybyte authored
315
316 ------------------------------------------------------------------------------
1e94262 @ozataman Add some docs
ozataman authored
317 -- | Check password for a given user.
318 --
319 -- Returns 'Nothing" if check is successful and an 'IncorrectPassword' error
320 -- otherwise
492e045 @ozataman Save progress on auth
ozataman authored
321 authenticatePassword
322 :: AuthUser -- ^ Looked up from the back-end
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
323 -> Password -- ^ Check against this password
492e045 @ozataman Save progress on auth
ozataman authored
324 -> Maybe AuthFailure
325 authenticatePassword u pw = auth
326 where
327 auth = case userPassword u of
328 Nothing -> Just PasswordMissing
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
329 Just upw -> check $ checkPassword pw upw
492e045 @ozataman Save progress on auth
ozataman authored
330 check b = if b then Nothing else Just IncorrectPassword
b0fadff @mightybyte Alpha release of new snaplet infrastructure.
mightybyte authored
331
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
332
333 ------------------------------------------------------------------------------
334 -- | Wrap lookups around request-local cache
335 cacheOrLookup
336 :: Handler b (AuthManager b) (Maybe AuthUser)
337 -- ^ Lookup action to perform if request local cache is empty
338 -> Handler b (AuthManager b) (Maybe AuthUser)
339 cacheOrLookup f = do
6ac2670 @ozataman Get latest enhancements working
ozataman authored
340 au <- getsSnapletState activeUser
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
341 if isJust au
342 then return au
343 else do
344 au' <- f
6ac2670 @ozataman Get latest enhancements working
ozataman authored
345 modifySnapletState (\mgr -> mgr { activeUser = au' })
a7a4510 @ozataman Get working with data-lens, fill out some undefineds
ozataman authored
346 return au'
dbda05f @ozataman Flesh out a first auth implementation
ozataman authored
347
348
349
Something went wrong with that request. Please try again.