Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 501 lines (462 sloc) 20.708 kb
5b13900 John MacFarlane Integrated Pasqualino Titto Assini's patch for RPXNow support.
authored
1 {-# LANGUAGE ScopedTypeVariables, StandaloneDeriving #-}
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
2 {-
3 Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,
4 Henry Laxen <nadine.and.henry@pobox.com>
5
6 This program is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 2 of the License, or
9 (at your option) any later version.
10
11 This program is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 You should have received a copy of the GNU General Public License
17 along with this program; if not, write to the Free Software
18 Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
19 -}
20
21 {- Handlers for registering and authenticating users.
22 -}
23
726e0b3 John MacFarlane Added authentication-required field.
authored
24 module Network.Gitit.Authentication ( loginUserForm
25 , formAuthHandlers
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
26 , httpAuthHandlers
27 , rpxAuthHandlers) where
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
28
2e4d87e John MacFarlane Moved Gitit under Network namespace.
authored
29 import Network.Gitit.State
30 import Network.Gitit.Types
31 import Network.Gitit.Framework
32 import Network.Gitit.Layout
33 import Network.Gitit.Server
a750597 John MacFarlane Proper _login and _logout for HTTP authentication.
authored
34 import Network.Gitit.Util
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
35 import Network.Captcha.ReCaptcha (captchaFields, validateCaptcha)
36 import Text.XHtml hiding ( (</>), dir, method, password, rev )
37 import qualified Text.XHtml as X ( password )
38 import System.Process (readProcessWithExitCode)
c0f4586 John MacFarlane Migrated to happstack-6.
authored
39 import Control.Monad (unless, liftM, mplus)
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
40 import Control.Monad.Trans (MonadIO(), liftIO)
41 import System.Exit
42 import System.Log.Logger (logM, Priority(..))
068e780 John MacFarlane Major architectural revision of authentication system.
authored
43 import Data.Char (isAlphaNum, isAlpha, isAscii)
6d182e6 John MacFarlane RPX authentication: don't store credentials in user file.
authored
44 import qualified Data.Map as M
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
45 import Text.Pandoc.Shared (substitute)
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
46 import Data.Maybe (isJust, fromJust, isNothing, fromMaybe)
068e780 John MacFarlane Major architectural revision of authentication system.
authored
47 import Network.URL (encString, exportURL, add_param, importURL)
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
48 import Network.BSD (getHostName)
49 import qualified Text.StringTemplate as T
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
50 import Network.HTTP (urlEncodeVars, urlDecode, urlEncode)
5b13900 John MacFarlane Integrated Pasqualino Titto Assini's patch for RPXNow support.
authored
51 import Codec.Binary.UTF8.String (encodeString)
726e0b3 John MacFarlane Added authentication-required field.
authored
52 import Data.ByteString.UTF8 (toString)
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
53 import Network.Gitit.Rpxnow as R
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
54
55 data ValidationType = Register
56 | ResetPassword
57 deriving (Show,Read)
58
589fb6e John MacFarlane Large architecture change.
authored
59 registerUser :: Params -> Handler
60 registerUser params = do
e08c0dc John MacFarlane Changed showActivity to a Handler type.
authored
61 result' <- sharedValidation Register params
62 case result' of
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
63 Left errors -> registerForm >>=
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
64 formattedPage defaultPageLayout{
442fa70 John MacFarlane Simplified formattedPage.
authored
65 pgMessages = errors,
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
66 pgShowPageTools = False,
67 pgTabs = [],
68 pgTitle = "Register for an account"
69 }
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
70 Right (uname, email, pword) -> do
71 user <- liftIO $ mkUser uname email pword
72 addUser uname user
589fb6e John MacFarlane Large architecture change.
authored
73 loginUser params{ pUsername = uname,
74 pPassword = pword,
75 pEmail = email }
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
76
589fb6e John MacFarlane Large architecture change.
authored
77 resetPasswordRequestForm :: Params -> Handler
442fa70 John MacFarlane Simplified formattedPage.
authored
78 resetPasswordRequestForm _ = do
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
79 let passwordForm = gui "" ! [identifier "resetPassword"] << fieldset <<
80 [ label << "Username: "
94586dd John MacFarlane Added tabindex to authentication forms for easier navigation.
authored
81 , textfield "username" ! [size "20", intAttr "tabindex" 1], stringToHtml " "
188a965 Doug Beardsley Added tabindex attributes to submit buttons. Without them, tab was
mightybyte authored
82 , submit "resetPassword" "Reset Password" ! [intAttr "tabindex" 2]]
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
83 cfg <- getConfig
84 let contents = if null (mailCommand cfg)
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
85 then p << "Sorry, password reset not available."
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
86 else passwordForm
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
87 formattedPage defaultPageLayout{
88 pgShowPageTools = False,
89 pgTabs = [],
90 pgTitle = "Reset your password" }
442fa70 John MacFarlane Simplified formattedPage.
authored
91 contents
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
92
589fb6e John MacFarlane Large architecture change.
authored
93 resetPasswordRequest :: Params -> Handler
94 resetPasswordRequest params = do
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
95 let uname = pUsername params
96 mbUser <- getUser uname
97 let errors = case mbUser of
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
98 Nothing -> ["Unknown user. Please re-register " ++
99 "or press the Back button to try again."]
100 Just u -> ["Since you did not register with " ++
101 "an email address, we can't reset your password." |
102 null (uEmail u) ]
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
103 if null errors
104 then do
105 let response =
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
106 p << [ stringToHtml "An email has been sent to "
107 , bold $ stringToHtml . uEmail $ fromJust mbUser
108 , br
109 , stringToHtml
110 "Please click on the enclosed link to reset your password."
111 ]
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
112 sendReregisterEmail (fromJust mbUser)
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
113 formattedPage defaultPageLayout{
114 pgShowPageTools = False,
115 pgTabs = [],
116 pgTitle = "Resetting your password"
117 }
442fa70 John MacFarlane Simplified formattedPage.
authored
118 response
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
119 else registerForm >>=
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
120 formattedPage defaultPageLayout{
2465bcb gwern Strip trailing whitespace; misc -Wall and hlint
gwern authored
121 pgMessages = errors,
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
122 pgShowPageTools = False,
123 pgTabs = [],
124 pgTitle = "Register for an account"
125 }
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
126
9fceaab John MacFarlane Use getWikiBase to construct URLs in templates, handlers.
authored
127 resetLink :: String -> User -> String
128 resetLink base' user =
129 exportURL $ foldl add_param
6d9e1b9 John MacFarlane Fixed getWikiBase.
authored
130 (fromJust . importURL $ base' ++ "/_doResetPassword")
9fceaab John MacFarlane Use getWikiBase to construct URLs in templates, handlers.
authored
131 [("username", uUsername user), ("reset_code", take 20 (pHashed (uPassword user)))]
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
132
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
133 sendReregisterEmail :: User -> GititServerPart ()
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
134 sendReregisterEmail user = do
135 cfg <- getConfig
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
136 hostname <- liftIO getHostName
9fceaab John MacFarlane Use getWikiBase to construct URLs in templates, handlers.
authored
137 base' <- getWikiBase
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
138 let messageTemplate = T.newSTMP $ resetPasswordMessage cfg
139 let filledTemplate = T.render .
140 T.setAttribute "username" (uUsername user) .
141 T.setAttribute "useremail" (uEmail user) .
142 T.setAttribute "hostname" hostname .
143 T.setAttribute "port" (show $ portNumber cfg) .
9fceaab John MacFarlane Use getWikiBase to construct URLs in templates, handlers.
authored
144 T.setAttribute "resetlink" (resetLink base' user) $
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
145 messageTemplate
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
146 let (mailcommand:args) = words $ substitute "%s" (uEmail user)
147 (mailCommand cfg)
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
148 (exitCode, _pOut, pErr) <- liftIO $ readProcessWithExitCode mailcommand args
149 filledTemplate
150 liftIO $ logM "gitit" WARNING $ "Sent reset password email to " ++ uUsername user ++
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
151 " at " ++ uEmail user
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
152 unless (exitCode == ExitSuccess) $
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
153 liftIO $ logM "gitit" WARNING $ mailcommand ++ " failed. " ++ pErr
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
154
c5859b3 John MacFarlane Fixed security issue with change password.
authored
155 validateReset :: Params -> (User -> Handler) -> Handler
156 validateReset params postValidate = do
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
157 let uname = pUsername params
1d8d704 John MacFarlane Renamed AppState -> GititState.
authored
158 user <- getUser uname
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
159 let knownUser = isJust user
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
160 let resetCodeMatches = take 20 (pHashed (uPassword (fromJust user))) ==
161 pResetCode params
442fa70 John MacFarlane Simplified formattedPage.
authored
162 let errors = case (knownUser, resetCodeMatches) of
163 (True, True) -> []
164 (True, False) -> ["Your reset code is invalid"]
2465bcb gwern Strip trailing whitespace; misc -Wall and hlint
gwern authored
165 (False, _) -> ["User " ++ uname ++ " is not known"]
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
166 if null errors
c5859b3 John MacFarlane Fixed security issue with change password.
authored
167 then postValidate (fromJust user)
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
168 else registerForm >>=
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
169 formattedPage defaultPageLayout{
442fa70 John MacFarlane Simplified formattedPage.
authored
170 pgMessages = errors,
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
171 pgShowPageTools = False,
172 pgTabs = [],
173 pgTitle = "Register for an account"
174 }
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
175
c5859b3 John MacFarlane Fixed security issue with change password.
authored
176 resetPassword :: Params -> Handler
177 resetPassword params = validateReset params $ \user ->
178 resetPasswordForm (Just user) >>=
179 formattedPage defaultPageLayout{
180 pgShowPageTools = False,
181 pgTabs = [],
182 pgTitle = "Reset your registration info"
183 }
184
589fb6e John MacFarlane Large architecture change.
authored
185 doResetPassword :: Params -> Handler
c5859b3 John MacFarlane Fixed security issue with change password.
authored
186 doResetPassword params = validateReset params $ \user -> do
e08c0dc John MacFarlane Changed showActivity to a Handler type.
authored
187 result' <- sharedValidation ResetPassword params
188 case result' of
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
189 Left errors ->
c5859b3 John MacFarlane Fixed security issue with change password.
authored
190 resetPasswordForm (Just user) >>=
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
191 formattedPage defaultPageLayout{
442fa70 John MacFarlane Simplified formattedPage.
authored
192 pgMessages = errors,
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
193 pgShowPageTools = False,
194 pgTabs = [],
195 pgTitle = "Reset your registration info"
196 }
c5859b3 John MacFarlane Fixed security issue with change password.
authored
197 Right (uname, email, pword) -> do
198 user' <- liftIO $ mkUser uname email pword
199 adjustUser uname user'
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
200 liftIO $ logM "gitit" WARNING $
c5859b3 John MacFarlane Fixed security issue with change password.
authored
201 "Successfully reset password and email for " ++ uUsername user'
202 loginUser params{ pUsername = uname,
589fb6e John MacFarlane Large architecture change.
authored
203 pPassword = pword,
204 pEmail = email }
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
205
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
206 registerForm :: GititServerPart Html
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
207 registerForm = sharedForm Nothing
208
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
209 resetPasswordForm :: Maybe User -> GititServerPart Html
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
210 resetPasswordForm = sharedForm -- synonym for now
211
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
212 sharedForm :: Maybe User -> GititServerPart Html
068e780 John MacFarlane Major architectural revision of authentication system.
authored
213 sharedForm mbUser = withData $ \params -> do
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
214 cfg <- getConfig
068e780 John MacFarlane Major architectural revision of authentication system.
authored
215 dest <- case pDestination params of
216 "" -> getReferer
217 x -> return x
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
218 let accessQ = case accessQuestion cfg of
219 Nothing -> noHtml
220 Just (prompt, _) -> label << prompt +++ br +++
b4216c6 John MacFarlane Set tabindex on access question input.
authored
221 X.password "accessCode" ! [size "15", intAttr "tabindex" 1]
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
222 +++ br
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
223 let captcha = if useRecaptcha cfg
224 then captchaFields (recaptchaPublicKey cfg) Nothing
225 else noHtml
226 let initField field = case mbUser of
227 Nothing -> ""
228 Just user -> field user
229 let userNameField = case mbUser of
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
230 Nothing -> label <<
231 "Username (at least 3 letters or digits):"
232 +++ br +++
b4216c6 John MacFarlane Set tabindex on access question input.
authored
233 textfield "username" ! [size "20", intAttr "tabindex" 2] +++ br
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
234 Just user -> label << ("Username (cannot be changed): "
235 ++ uUsername user) +++ br
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
236 let submitField = case mbUser of
237 Nothing -> submit "register" "Register"
238 Just _ -> submit "resetPassword" "Reset Password"
239
240 return $ gui "" ! [identifier "loginForm"] << fieldset <<
241 [ accessQ
242 , userNameField
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
243 , label << "Email (optional, will not be displayed on the Wiki):"
244 , br
b4216c6 John MacFarlane Set tabindex on access question input.
authored
245 , textfield "email" ! [size "20", intAttr "tabindex" 3, value (initField uEmail)], br
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
246 , textfield "full_name_1" ! [size "20", theclass "req"]
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
247 , label << ("Password (at least 6 characters," ++
248 " including at least one non-letter):")
249 , br
b4216c6 John MacFarlane Set tabindex on access question input.
authored
250 , X.password "password" ! [size "20", intAttr "tabindex" 4]
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
251 , stringToHtml " "
252 , br
253 , label << "Confirm Password:"
254 , br
b4216c6 John MacFarlane Set tabindex on access question input.
authored
255 , X.password "password2" ! [size "20", intAttr "tabindex" 5]
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
256 , stringToHtml " "
257 , br
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
258 , captcha
068e780 John MacFarlane Major architectural revision of authentication system.
authored
259 , textfield "destination" ! [thestyle "display: none;", value dest]
b4216c6 John MacFarlane Set tabindex on access question input.
authored
260 , submitField ! [intAttr "tabindex" 6]]
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
261
262
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
263 sharedValidation :: ValidationType
589fb6e John MacFarlane Large architecture change.
authored
264 -> Params
ebf01df John MacFarlane Use GititServerPart instead of ServerPart.
authored
265 -> GititServerPart (Either [String] (String,String,String))
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
266 sharedValidation validationType params = do
2a1369c John MacFarlane Allow spaces in usernames (thanks to Juraj Hercek).
authored
267 let isValidUsernameChar c = isAlphaNum c || c == ' '
268 let isValidUsername u = length u >= 3 && all isValidUsernameChar u
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
269 let isValidPassword pw = length pw >= 6 && not (all isAlpha pw)
270 let accessCode = pAccessCode params
271 let uname = pUsername params
272 let pword = pPassword params
273 let pword2 = pPassword2 params
274 let email = pEmail params
275 let fakeField = pFullName params
276 let recaptcha = pRecaptcha params
277 taken <- isUser uname
278 cfg <- getConfig
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
279 let optionalTests Register =
280 [(taken, "Sorry, that username is already taken.")]
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
281 optionalTests ResetPassword = []
282 let isValidAccessCode = case accessQuestion cfg of
283 Nothing -> True
284 Just (_, answers) -> accessCode `elem` answers
285 let isValidEmail e = length (filter (=='@') e) == 1
589fb6e John MacFarlane Large architecture change.
authored
286 peer <- liftM (fst . rqPeer) askRq
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
287 captchaResult <-
288 if useRecaptcha cfg
289 then if null (recaptchaChallengeField recaptcha) ||
290 null (recaptchaResponseField recaptcha)
291 -- no need to bother captcha.net in this case
292 then return $ Left "missing-challenge-or-response"
293 else liftIO $ do
589fb6e John MacFarlane Large architecture change.
authored
294 mbIPaddr <- lookupIPAddr peer
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
295 let ipaddr = case mbIPaddr of
296 Just ip -> ip
297 Nothing -> error $
298 "Could not find ip address for " ++
589fb6e John MacFarlane Large architecture change.
authored
299 peer
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
300 ipaddr `seq` validateCaptcha (recaptchaPrivateKey cfg)
301 ipaddr (recaptchaChallengeField recaptcha)
302 (recaptchaResponseField recaptcha)
303 else return $ Right ()
304 let (validCaptcha, captchaError) =
305 case captchaResult of
306 Right () -> (True, Nothing)
307 Left err -> (False, Just err)
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
308 let errors = validate $ optionalTests validationType ++
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
309 [ (not isValidAccessCode, "Incorrect response to access prompt.")
310 , (not (isValidUsername uname),
311 "Username must be at least 3 charcaters, all letters or digits.")
312 , (not (isValidPassword pword),
313 "Password must be at least 6 characters, " ++
314 "and must contain at least one non-letter.")
315 , (not (null email) && not (isValidEmail email),
316 "Email address appears invalid.")
317 , (pword /= pword2,
318 "Password does not match confirmation.")
319 , (not validCaptcha,
320 "Failed CAPTCHA (" ++ fromJust captchaError ++
321 "). Are you really human?")
322 , (not (null fakeField), -- fakeField is hidden in CSS (honeypot)
323 "You do not seem human enough. If you're sure you are human, " ++
324 "try turning off form auto-completion in your browser.")
325 ]
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
326 return $ if null errors then Right (uname, email, pword) else Left errors
327
328 -- user authentication
068e780 John MacFarlane Major architectural revision of authentication system.
authored
329 loginForm :: String -> GititServerPart Html
330 loginForm dest = do
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
331 cfg <- getConfig
9fceaab John MacFarlane Use getWikiBase to construct URLs in templates, handlers.
authored
332 base' <- getWikiBase
6d9e1b9 John MacFarlane Fixed getWikiBase.
authored
333 return $ gui (base' ++ "/_login") ! [identifier "loginForm"] <<
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
334 fieldset <<
335 [ label << "Username "
94586dd John MacFarlane Added tabindex to authentication forms for easier navigation.
authored
336 , textfield "username" ! [size "15", intAttr "tabindex" 1]
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
337 , stringToHtml " "
338 , label << "Password "
94586dd John MacFarlane Added tabindex to authentication forms for easier navigation.
authored
339 , X.password "password" ! [size "15", intAttr "tabindex" 2]
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
340 , stringToHtml " "
068e780 John MacFarlane Major architectural revision of authentication system.
authored
341 , textfield "destination" ! [thestyle "display: none;", value dest]
188a965 Doug Beardsley Added tabindex attributes to submit buttons. Without them, tab was
mightybyte authored
342 , submit "login" "Login" ! [intAttr "tabindex" 3]
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
343 ] +++
344 p << [ stringToHtml "If you do not have an account, "
068e780 John MacFarlane Major architectural revision of authentication system.
authored
345 , anchor ! [href $ base' ++ "/_register?" ++
346 urlEncodeVars [("destination", encodeString dest)]] << "click here to get one."
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
347 ] +++
348 if null (mailCommand cfg)
349 then noHtml
350 else p << [ stringToHtml "If you forgot your password, "
6d9e1b9 John MacFarlane Fixed getWikiBase.
authored
351 , anchor ! [href $ base' ++ "/_resetPassword"] <<
2677256 John MacFarlane Reformatting/hlint in Authentication module.
authored
352 "click here to get a new one."
353 ]
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
354
6ad56de John MacFarlane Removed Params as explicit parameter of Handlers.
authored
355 loginUserForm :: Handler
356 loginUserForm = withData $ \params -> do
068e780 John MacFarlane Major architectural revision of authentication system.
authored
357 dest <- case pDestination params of
358 "" -> getReferer
359 x -> return x
360 loginForm dest >>=
361 formattedPage defaultPageLayout{ pgShowPageTools = False,
362 pgTabs = [],
363 pgTitle = "Login",
364 pgMessages = pMessages params
365 }
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
366
589fb6e John MacFarlane Large architecture change.
authored
367 loginUser :: Params -> Handler
368 loginUser params = do
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
369 let uname = pUsername params
370 let pword = pPassword params
371 let destination = pDestination params
372 allowed <- authUser uname pword
7212791 John MacFarlane Added session-timeout config setting.
authored
373 cfg <- getConfig
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
374 if allowed
375 then do
376 key <- newSession (SessionData uname)
c0f4586 John MacFarlane Migrated to happstack-6.
authored
377 addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))
068e780 John MacFarlane Major architectural revision of authentication system.
authored
378 seeOther (encUrl destination) $ toResponse $ p << ("Welcome, " ++ uname)
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
379 else
9feb181 Display informative message on authentication failure.
John MacFarlane authored
380 withMessages ["Invalid username or password."] loginUserForm
068e780 John MacFarlane Major architectural revision of authentication system.
authored
381
382 encUrl :: String -> String
383 encUrl = encString True isAscii
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
384
589fb6e John MacFarlane Large architecture change.
authored
385 logoutUser :: Params -> Handler
386 logoutUser params = do
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
387 let key = pSessionKey params
068e780 John MacFarlane Major architectural revision of authentication system.
authored
388 dest <- case pDestination params of
389 "" -> getReferer
390 x -> return x
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
391 case key of
392 Just k -> do
393 delSession k
c0f4586 John MacFarlane Migrated to happstack-6.
authored
394 expireCookie "sid"
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
395 Nothing -> return ()
068e780 John MacFarlane Major architectural revision of authentication system.
authored
396 seeOther (encUrl dest) $ toResponse "You have been logged out."
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
397
068e780 John MacFarlane Major architectural revision of authentication system.
authored
398 registerUserForm :: Handler
399 registerUserForm = registerForm >>=
40f5f19 John MacFarlane Set redirect properly after account creation.
authored
400 formattedPage defaultPageLayout{
401 pgShowPageTools = False,
402 pgTabs = [],
403 pgTitle = "Register for an account"
404 }
fe14fa8 Added functions for a password reset email.
John MacFarlane authored
405
b3ea1d6 John MacFarlane Moved authentication handlers into Authentication module.
authored
406 formAuthHandlers :: [Handler]
407 formAuthHandlers =
a3b36ce John MacFarlane Modifications to get gitit to compile w latest pandoc, happstack.
authored
408 [ dir "_register" $ method GET >> registerUserForm
409 , dir "_register" $ method POST >> withData registerUser
410 , dir "_login" $ method GET >> loginUserForm
411 , dir "_login" $ method POST >> withData loginUser
412 , dir "_logout" $ method GET >> withData logoutUser
413 , dir "_resetPassword" $ method GET >> withData resetPasswordRequestForm
414 , dir "_resetPassword" $ method POST >> withData resetPasswordRequest
415 , dir "_doResetPassword" $ method GET >> withData resetPassword
416 , dir "_doResetPassword" $ method POST >> withData doResetPassword
726e0b3 John MacFarlane Added authentication-required field.
authored
417 , dir "_user" currentUser
b3ea1d6 John MacFarlane Moved authentication handlers into Authentication module.
authored
418 ]
419
a750597 John MacFarlane Proper _login and _logout for HTTP authentication.
authored
420 loginUserHTTP :: Params -> Handler
421 loginUserHTTP params = do
422 base' <- getWikiBase
423 let destination = pDestination params `orIfNull` (base' ++ "/")
424 seeOther (encUrl destination) $ toResponse ()
425
426 logoutUserHTTP :: Handler
427 logoutUserHTTP = unauthorized $ toResponse () -- will this work?
428
b3ea1d6 John MacFarlane Moved authentication handlers into Authentication module.
authored
429 httpAuthHandlers :: [Handler]
430 httpAuthHandlers =
431 [ dir "_logout" $ logoutUserHTTP
726e0b3 John MacFarlane Added authentication-required field.
authored
432 , dir "_login" $ withData loginUserHTTP
433 , dir "_user" currentUser ]
5b13900 John MacFarlane Integrated Pasqualino Titto Assini's patch for RPXNow support.
authored
434
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
435 -- Login using RPX (see RPX development docs at https://rpxnow.com/docs)
436 loginRPXUser :: RPars -- ^ The parameters passed by the RPX callback call (after authentication has taken place
437 -> Handler
438 loginRPXUser params = do
439 cfg <- getConfig
1bc9242 John MacFarlane Use base-url to set rpx token_url.
authored
440 ref <- getReferer
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
441 let mtoken = rToken params
442 if isNothing mtoken
77464e3 John MacFarlane Fixed redirect loop with rpx and require-authentication=read.
authored
443 then do
1bc9242 John MacFarlane Use base-url to set rpx token_url.
authored
444 let url = baseUrl cfg ++ "/_login?destination=" ++
445 (fromMaybe ref $ rDestination params)
77464e3 John MacFarlane Fixed redirect loop with rpx and require-authentication=read.
authored
446 if null (rpxDomain cfg)
447 then error "rpx-domain is not set."
448 else do
449 let rpx = "https://" ++ rpxDomain cfg ++
450 ".rpxnow.com/openid/v2/signin?token_url=" ++
1bc9242 John MacFarlane Use base-url to set rpx token_url.
authored
451 urlEncode url
77464e3 John MacFarlane Fixed redirect loop with rpx and require-authentication=read.
authored
452 see rpx
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
453 else do -- We got an answer from RPX, this might also return an exception.
454 uid' :: Either String R.Identifier <- liftIO $
455 R.authenticate (rpxKey cfg) $ fromJust mtoken
456 uid <- case uid' of
457 Right u -> return u
458 Left err -> error err
459 liftIO $ logM "gitit.loginRPXUser" DEBUG $ "uid:" ++ show uid
460 -- We need to get an unique identifier for the user
461 -- The 'identifier' is always present but can be rather cryptic
462 -- The 'verifiedEmail' is also unique and is a more readable choice
463 -- so we use it if present.
464 let userId = R.userIdentifier uid
465 let email = prop "verifiedEmail" uid
6d182e6 John MacFarlane RPX authentication: don't store credentials in user file.
authored
466 user <- liftIO $ mkUser (fromMaybe userId email) (fromMaybe "" email) "none"
467 updateGititState $ \s -> s { users = M.insert userId user (users s) }
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
468 key <- newSession (SessionData userId)
c0f4586 John MacFarlane Migrated to happstack-6.
authored
469 addCookie (MaxAge $ sessionTimeout cfg) (mkCookie "sid" (show key))
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
470 see $ fromJust $ rDestination params
471 where
472 prop pname info = lookup pname $ R.userData info
473 see url = seeOther (encUrl url) $ toResponse noHtml
474
475 -- The parameters passed by the RPX callback call.
c0f4586 John MacFarlane Migrated to happstack-6.
authored
476 data RPars = RPars { rToken :: Maybe String
477 , rDestination :: Maybe String }
478 deriving Show
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
479
480 instance FromData RPars where
481 fromData = do
c0f4586 John MacFarlane Migrated to happstack-6.
authored
482 vtoken <- liftM Just (look "token") `mplus` return Nothing
483 vDestination <- liftM (Just . urlDecode) (look "destination") `mplus`
484 return Nothing
485 return RPars { rToken = vtoken
486 , rDestination = vDestination }
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
487
488 rpxAuthHandlers :: [Handler]
489 rpxAuthHandlers =
a3b36ce John MacFarlane Modifications to get gitit to compile w latest pandoc, happstack.
authored
490 [ dir "_logout" $ method GET >> withData logoutUser
3cf6676 John MacFarlane Added RPX support again, using stripped-down module.
authored
491 , dir "_login" $ withData loginRPXUser
492 , dir "_user" currentUser ]
493
726e0b3 John MacFarlane Added authentication-required field.
authored
494 -- | Returns username of logged in user or null string if nobody logged in.
495 currentUser :: Handler
496 currentUser = do
497 req <- askRq
498 ok $ toResponse $ maybe "" toString (getHeader "REMOTE_USER" req)
499
02a14d2 John MacFarlane Added 'rpx' as authentication-method, 'rpx-domain' & 'rpx-key' config.
authored
500
Something went wrong with that request. Please try again.