Skip to content
This repository
Newer
Older
100644 205 lines (165 sloc) 6.629 kb
492e0455 »
2011-07-31 Save progress on auth
1 {-# LANGUAGE ExistentialQuantification #-}
2
3 module Snap.Snaplet.Auth where
4
5 import Control.Monad.State
6 import Crypto.PasswordStore
7 import qualified Data.ByteString.Char8 as B
8 import Data.ByteString (ByteString)
dbda05fa »
2011-07-31 Flesh out a first auth implementation
9 import Data.Maybe (isJust)
492e0455 »
2011-07-31 Save progress on auth
10 import Data.Time
b0fadff5 »
2011-07-25 Alpha release of new snaplet infrastructure.
11
12 import Snap.Snaplet.Auth.Types
492e0455 »
2011-07-31 Save progress on auth
13 import Snap.Snaplet
14 import Snap.Snaplet.Session
15
16
17
18 -- $higherlevel
19 -- These are the key functions you will use in your handlers.
20
21
dbda05fa »
2011-07-31 Flesh out a first auth implementation
22 ------------------------------------------------------------------------------
23 -- | Lookup a user by her username, check given password and perform login
24 loginByUsername
25 :: ByteString -- ^ Username/login for user
26 -> Password -- ^ Should be ClearText
27 -> Bool -- ^ Set remember token?
28 -> Handler b (AuthManager b) (Maybe AuthUser)
29 loginByUsername = undefined
30
492e0455 »
2011-07-31 Save progress on auth
31
32 ------------------------------------------------------------------------------
dbda05fa »
2011-07-31 Flesh out a first auth implementation
33 -- | Remember user from the remember token if possible.
34 rememberUser :: Handler b (AuthManager b) (Maybe AuthUser)
35 rememberUser = cacheOrLookup f
36 where
37 f = do
38 mgr@(AuthManager r _ _ _ rc to _) <- get
39 uid <- undefined
40 case uid of
41 Nothing -> return Nothing
42 Just uid' -> liftIO $ lookupByUserId r uid'
492e0455 »
2011-07-31 Save progress on auth
43
44
dbda05fa »
2011-07-31 Flesh out a first auth implementation
45 ------------------------------------------------------------------------------
46 -- Logout the active user
492e0455 »
2011-07-31 Save progress on auth
47 logout :: Handler b (AuthManager b) ()
dbda05fa »
2011-07-31 Flesh out a first auth implementation
48 logout = do
49 s <- gets session
50 withTop s removeSessionUserId
51 modify (\mgr -> mgr { activeUser = Nothing } )
492e0455 »
2011-07-31 Save progress on auth
52
53
dbda05fa »
2011-07-31 Flesh out a first auth implementation
54 ------------------------------------------------------------------------------
55 -- | Return the current user
492e0455 »
2011-07-31 Save progress on auth
56 currentUser :: Handler b (AuthManager b) (Maybe AuthUser)
dbda05fa »
2011-07-31 Flesh out a first auth implementation
57 currentUser = cacheOrLookup f
58 where
59 f = do
60 mgr@(AuthManager r s _ _ _ _ _) <- get
61 uid <- withTop s getSessionUserId
62 case uid of
63 Nothing -> return Nothing
64 Just uid' -> liftIO $ lookupByUserId r uid'
492e0455 »
2011-07-31 Save progress on auth
65
66
dbda05fa »
2011-07-31 Flesh out a first auth implementation
67 ------------------------------------------------------------------------------
68 -- | Convenience wrapper around 'rememberUser' that returns a bool result
492e0455 »
2011-07-31 Save progress on auth
69 isLoggedIn :: Handler b (AuthManager b) Bool
dbda05fa »
2011-07-31 Flesh out a first auth implementation
70 isLoggedIn = do
71 au <- currentUser
72 return $ if isJust au then True else False
73
492e0455 »
2011-07-31 Save progress on auth
74
dbda05fa »
2011-07-31 Flesh out a first auth implementation
75 -- $midlevel
76 -- You might need these if you are rolling your own handlers/authenticators
492e0455 »
2011-07-31 Save progress on auth
77
78 ------------------------------------------------------------------------------
79 -- | Mutate an 'AuthUser', marking failed authentication now.
80 markAuthFail :: AuthUser -> Handler b (AuthManager b) AuthUser
81 markAuthFail u = do
dbda05fa »
2011-07-31 Flesh out a first auth implementation
82 (AuthManager r _ _ _ _ _ _) <- get
492e0455 »
2011-07-31 Save progress on auth
83 proc u >>= liftIO . save r
84 where
85 proc = incFailCtr >=> checkLockout
86 incFailCtr = undefined
87 checkLockout = undefined
88
89
90 ------------------------------------------------------------------------------
91 -- | Mutate an 'AuthUser', marking successful authentication now.
92 markAuthSuccess :: AuthUser -> Handler b (AuthManager b) AuthUser
93 markAuthSuccess u = do
dbda05fa »
2011-07-31 Flesh out a first auth implementation
94 (AuthManager r _ _ _ _ _ _) <- get
492e0455 »
2011-07-31 Save progress on auth
95 proc u >>= liftIO . save r
96 where
97 proc = incLoginCtr >=> updateIp >=> updateLoginTS >=>
98 setRememberToken >=> resetFailCtr
99 incLoginCtr = undefined
100 updateIp = undefined
101 updateLoginTS = undefined
102 setRememberToken = undefined
103 resetFailCtr = undefined
104
105
106 ------------------------------------------------------------------------------
107 -- | Authenticate and log the user into the current session if successful.
108 --
109 -- This is a mid-level function exposed to allow roll-your-own ways of looking
110 -- up a user from the database.
111 --
112 -- This function will:
113 --
114 -- 1. Check the password
115 --
116 -- 2. Login the user into the current session
117 --
118 -- 3. Mark success/failure of the authentication trial on the user record
dbda05fa »
2011-07-31 Flesh out a first auth implementation
119 checkPasswordAndLogin
492e0455 »
2011-07-31 Save progress on auth
120 :: AuthUser
dbda05fa »
2011-07-31 Flesh out a first auth implementation
121 -> Password -- ^ A ClearText password
122 -> Bool -- ^ Set remember cookie?
492e0455 »
2011-07-31 Save progress on auth
123 -> Handler b (AuthManager b) (Either AuthFailure AuthUser)
dbda05fa »
2011-07-31 Flesh out a first auth implementation
124 checkPasswordAndLogin u pw remember =
492e0455 »
2011-07-31 Save progress on auth
125 case authenticatePassword u pw of
126 Just e -> do
127 markAuthFail u
128 return $ Left e
129 Nothing -> do
dbda05fa »
2011-07-31 Flesh out a first auth implementation
130 forceLoginUser u remember
131 modify (\mgr -> mgr { activeUser = Just u })
492e0455 »
2011-07-31 Save progress on auth
132 u' <- markAuthSuccess u
133 return $ Right u'
134
135
136 ------------------------------------------------------------------------------
137 -- | Login and persist the given 'AuthUser' in the active session
138 --
139 -- Meant to be used if you have other means of being sure that the person is
140 -- who she says she is.
dbda05fa »
2011-07-31 Flesh out a first auth implementation
141 forceLoginUser
142 :: AuthUser
143 -> Bool -- ^ Set remember cookie?
144 -> Handler b (AuthManager b) Bool
145 forceLoginUser u rc = do
146 AuthManager _ s _ _ _ _ _ <- get
492e0455 »
2011-07-31 Save progress on auth
147 case userId u of
148 Just x -> withTop s (setSessionUserId x) >> return True
149 Nothing -> return False
150
151
dbda05fa »
2011-07-31 Flesh out a first auth implementation
152 -- $lowlevel
153 -- You shouldn't need to use these explicitly
154
492e0455 »
2011-07-31 Save progress on auth
155 ------------------------------------------------------------------------------
156 -- | Set the current user's 'UserId' in the active session
157 setSessionUserId :: UserId -> Handler b SessionManager ()
158 setSessionUserId (UserId t) = setInSession "__user_id" t
159
160
161 ------------------------------------------------------------------------------
dbda05fa »
2011-07-31 Flesh out a first auth implementation
162 -- | Remove 'UserId' from active session, effectively logging the user out.
163 removeSessionUserId :: Handler b SessionManager ()
164 removeSessionUserId = deleteFromSession "__user_id"
165
166
167 ------------------------------------------------------------------------------
492e0455 »
2011-07-31 Save progress on auth
168 -- | Get the current user's 'UserId' from the active session
169 getSessionUserId :: Handler b SessionManager (Maybe UserId)
170 getSessionUserId = do
171 uid <- getFromSession "__user_id"
172 return $ uid >>= return . UserId
173
b0fadff5 »
2011-07-25 Alpha release of new snaplet infrastructure.
174
175 ------------------------------------------------------------------------------
492e0455 »
2011-07-31 Save progress on auth
176 -- | Check password for a given user.
177 authenticatePassword
178 :: AuthUser -- ^ Looked up from the back-end
dbda05fa »
2011-07-31 Flesh out a first auth implementation
179 -> Password -- ^ Check against this password
492e0455 »
2011-07-31 Save progress on auth
180 -> Maybe AuthFailure
181 authenticatePassword u pw = auth
182 where
183 auth = case userPassword u of
184 Nothing -> Just PasswordMissing
dbda05fa »
2011-07-31 Flesh out a first auth implementation
185 Just upw -> check $ checkPassword pw upw
492e0455 »
2011-07-31 Save progress on auth
186 check b = if b then Nothing else Just IncorrectPassword
b0fadff5 »
2011-07-25 Alpha release of new snaplet infrastructure.
187
dbda05fa »
2011-07-31 Flesh out a first auth implementation
188
189 ------------------------------------------------------------------------------
190 -- | Wrap lookups around request-local cache
191 cacheOrLookup
192 :: Handler b (AuthManager b) (Maybe AuthUser)
193 -- ^ Lookup action to perform if request local cache is empty
194 -> Handler b (AuthManager b) (Maybe AuthUser)
195 cacheOrLookup f = do
196 au <- gets activeUser
197 if isJust au then return au
198 else do
199 au' <- f
200 modify (\mgr -> mgr { activeUser = au' })
201 return au'
202
203
204
Something went wrong with that request. Please try again.