{-
Copyright (C) 2009 John MacFarlane <jgm@berkeley.edu>,
Henry Laxen <nadine.and.henry@pobox.com>
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-}{- Handlers for registering and authenticating users.
-}moduleNetwork.Gitit.Authentication(formAuthHandlers,httpAuthHandlers,loginUserForm)whereimportNetwork.Gitit.StateimportNetwork.Gitit.TypesimportNetwork.Gitit.FrameworkimportNetwork.Gitit.LayoutimportNetwork.Gitit.ServerimportNetwork.Gitit.UtilimportNetwork.Captcha.ReCaptcha(captchaFields,validateCaptcha)importText.XHtmlhiding((</>),dir,method,password,rev)importqualifiedText.XHtmlasX(password)importSystem.Process(readProcessWithExitCode)importControl.Monad(unless,liftM)importControl.Monad.Trans(MonadIO(),liftIO)importSystem.ExitimportSystem.Log.Logger(logM,Priority(..))importData.Char(isAlphaNum,isAlpha,isAscii)importText.Pandoc.Shared(substitute)importData.Maybe(isJust,fromJust)importNetwork.URL(encString,exportURL,add_param,importURL)importNetwork.BSD(getHostName)importqualifiedText.StringTemplateasTimportNetwork.HTTP(urlEncodeVars)importCodec.Binary.UTF8.String(encodeString)dataValidationType=Register|ResetPasswordderiving(Show,Read)registerUser::Params->HandlerregisterUserparams=doresult'<-sharedValidationRegisterparamscaseresult'ofLefterrors->registerForm>>=formattedPagedefaultPageLayout{pgMessages=errors,pgShowPageTools=False,pgTabs=[],pgTitle="Register for an account"}Right(uname,email,pword)->douser<-liftIO$mkUserunameemailpwordaddUserunameuserloginUserparams{pUsername=uname,pPassword=pword,pEmail=email}resetPasswordRequestForm::Params->HandlerresetPasswordRequestForm_=doletpasswordForm=gui""![identifier"resetPassword"]<<fieldset<<[label<<"Username: ",textfield"username"![size"20",intAttr"tabindex"1],stringToHtml" ",submit"resetPassword""Reset Password"![intAttr"tabindex"2]]cfg<-getConfigletcontents=ifnull(mailCommandcfg)thenp<<"Sorry, password reset not available."elsepasswordFormformattedPagedefaultPageLayout{pgShowPageTools=False,pgTabs=[],pgTitle="Reset your password"}contentsresetPasswordRequest::Params->HandlerresetPasswordRequestparams=doletuname=pUsernameparamsmbUser<-getUserunameleterrors=casembUserofNothing->["Unknown user. Please re-register "++"or press the Back button to try again."]Justu->["Since you did not register with "++"an email address, we can't reset your password."|null(uEmailu)]ifnullerrorsthendoletresponse=p<<[stringToHtml"An email has been sent to ",bold$stringToHtml.uEmail$fromJustmbUser,br,stringToHtml"Please click on the enclosed link to reset your password."]sendReregisterEmail(fromJustmbUser)formattedPagedefaultPageLayout{pgShowPageTools=False,pgTabs=[],pgTitle="Resetting your password"}responseelseregisterForm>>=formattedPagedefaultPageLayout{pgMessages=errors,pgShowPageTools=False,pgTabs=[],pgTitle="Register for an account"}resetLink::String->User->StringresetLinkbase'user=exportURL$foldladd_param(fromJust.importURL$base'++"/_doResetPassword")[("username",uUsernameuser),("reset_code",take20(pHashed(uPassworduser)))]sendReregisterEmail::User->GititServerPart()sendReregisterEmailuser=docfg<-getConfighostname<-liftIOgetHostNamebase'<-getWikiBaseletmessageTemplate=T.newSTMP$resetPasswordMessagecfgletfilledTemplate=T.render.T.setAttribute"username"(uUsernameuser).T.setAttribute"useremail"(uEmailuser).T.setAttribute"hostname"hostname.T.setAttribute"port"(show$portNumbercfg).T.setAttribute"resetlink"(resetLinkbase'user)$messageTemplatelet(mailcommand:args)=words$substitute"%s"(uEmailuser)(mailCommandcfg)(exitCode,_pOut,pErr)<-liftIO$readProcessWithExitCodemailcommandargsfilledTemplateliftIO$logM"gitit"WARNING$"Sent reset password email to "++uUsernameuser++" at "++uEmailuserunless(exitCode==ExitSuccess)$liftIO$logM"gitit"WARNING$mailcommand++" failed. "++pErrvalidateReset::Params->(User->Handler)->HandlervalidateResetparamspostValidate=doletuname=pUsernameparamsuser<-getUserunameletknownUser=isJustuserletresetCodeMatches=take20(pHashed(uPassword(fromJustuser)))==pResetCodeparamsleterrors=case(knownUser,resetCodeMatches)of(True,True)->[](True,False)->["Your reset code is invalid"](False,_)->["User "++uname++" is not known"]ifnullerrorsthenpostValidate(fromJustuser)elseregisterForm>>=formattedPagedefaultPageLayout{pgMessages=errors,pgShowPageTools=False,pgTabs=[],pgTitle="Register for an account"}resetPassword::Params->HandlerresetPasswordparams=validateResetparams$\user->resetPasswordForm(Justuser)>>=formattedPagedefaultPageLayout{pgShowPageTools=False,pgTabs=[],pgTitle="Reset your registration info"}doResetPassword::Params->HandlerdoResetPasswordparams=validateResetparams$\user->doresult'<-sharedValidationResetPasswordparamscaseresult'ofLefterrors->resetPasswordForm(Justuser)>>=formattedPagedefaultPageLayout{pgMessages=errors,pgShowPageTools=False,pgTabs=[],pgTitle="Reset your registration info"}Right(uname,email,pword)->douser'<-liftIO$mkUserunameemailpwordadjustUserunameuser'liftIO$logM"gitit"WARNING$"Successfully reset password and email for "++uUsernameuser'loginUserparams{pUsername=uname,pPassword=pword,pEmail=email}registerForm::GititServerPartHtmlregisterForm=sharedFormNothingresetPasswordForm::MaybeUser->GititServerPartHtmlresetPasswordForm=sharedForm-- synonym for nowsharedForm::MaybeUser->GititServerPartHtmlsharedFormmbUser=withData$\params->docfg<-getConfigdest<-casepDestinationparamsof""->getRefererx->returnxletaccessQ=caseaccessQuestioncfgofNothing->noHtmlJust(prompt,_)->label<<prompt+++br+++X.password"accessCode"![size"15",intAttr"tabindex"1]+++brletcaptcha=ifuseRecaptchacfgthencaptchaFields(recaptchaPublicKeycfg)NothingelsenoHtmlletinitFieldfield=casembUserofNothing->""Justuser->fielduserletuserNameField=casembUserofNothing->label<<"Username (at least 3 letters or digits):"+++br+++textfield"username"![size"20",intAttr"tabindex"2]+++brJustuser->label<<("Username (cannot be changed): "++uUsernameuser)+++brletsubmitField=casembUserofNothing->submit"register""Register"Just_->submit"resetPassword""Reset Password"return$gui""![identifier"loginForm"]<<fieldset<<[accessQ,userNameField,label<<"Email (optional, will not be displayed on the Wiki):",br,textfield"email"![size"20",intAttr"tabindex"3,value(initFielduEmail)],br,textfield"full_name_1"![size"20",theclass"req"],label<<("Password (at least 6 characters,"++" including at least one non-letter):"),br,X.password"password"![size"20",intAttr"tabindex"4],stringToHtml" ",br,label<<"Confirm Password:",br,X.password"password2"![size"20",intAttr"tabindex"5],stringToHtml" ",br,captcha,textfield"destination"![thestyle"display: none;",valuedest],submitField![intAttr"tabindex"6]]sharedValidation::ValidationType->Params->GititServerPart(Either[String](String,String,String))sharedValidationvalidationTypeparams=doletisValidUsernameu=lengthu>=3&&allisAlphaNumuletisValidPasswordpw=lengthpw>=6&&not(allisAlphapw)letaccessCode=pAccessCodeparamsletuname=pUsernameparamsletpword=pPasswordparamsletpword2=pPassword2paramsletemail=pEmailparamsletfakeField=pFullNameparamsletrecaptcha=pRecaptchaparamstaken<-isUserunamecfg<-getConfigletoptionalTestsRegister=[(taken,"Sorry, that username is already taken.")]optionalTestsResetPassword=[]letisValidAccessCode=caseaccessQuestioncfgofNothing->TrueJust(_,answers)->accessCode`elem`answersletisValidEmaile=length(filter(=='@')e)==1peer<-liftM(fst.rqPeer)askRqcaptchaResult<-ifuseRecaptchacfgthenifnull(recaptchaChallengeFieldrecaptcha)||null(recaptchaResponseFieldrecaptcha)-- no need to bother captcha.net in this casethenreturn$Left"missing-challenge-or-response"elseliftIO$dombIPaddr<-lookupIPAddrpeerletipaddr=casembIPaddrofJustip->ipNothing->error$"Could not find ip address for "++peeripaddr`seq`validateCaptcha(recaptchaPrivateKeycfg)ipaddr(recaptchaChallengeFieldrecaptcha)(recaptchaResponseFieldrecaptcha)elsereturn$Right()let(validCaptcha,captchaError)=casecaptchaResultofRight()->(True,Nothing)Lefterr->(False,Justerr)leterrors=validate$optionalTestsvalidationType++[(notisValidAccessCode,"Incorrect response to access prompt."),(not(isValidUsernameuname),"Username must be at least 3 charcaters, all letters or digits."),(not(isValidPasswordpword),"Password must be at least 6 characters, "++"and must contain at least one non-letter."),(not(nullemail)&&not(isValidEmailemail),"Email address appears invalid."),(pword/=pword2,"Password does not match confirmation."),(notvalidCaptcha,"Failed CAPTCHA ("++fromJustcaptchaError++"). Are you really human?"),(not(nullfakeField),-- fakeField is hidden in CSS (honeypot)"You do not seem human enough. If you're sure you are human, "++"try turning off form auto-completion in your browser.")]return$ifnullerrorsthenRight(uname,email,pword)elseLefterrors-- user authenticationloginForm::String->GititServerPartHtmlloginFormdest=docfg<-getConfigbase'<-getWikiBasereturn$gui(base'++"/_login")![identifier"loginForm"]<<fieldset<<[label<<"Username ",textfield"username"![size"15",intAttr"tabindex"1],stringToHtml" ",label<<"Password ",X.password"password"![size"15",intAttr"tabindex"2],stringToHtml" ",textfield"destination"![thestyle"display: none;",valuedest],submit"login""Login"![intAttr"tabindex"3]]+++p<<[stringToHtml"If you do not have an account, ",anchor![href$base'++"/_register?"++urlEncodeVars[("destination",encodeStringdest)]]<<"click here to get one."]+++ifnull(mailCommandcfg)thennoHtmlelsep<<[stringToHtml"If you forgot your password, ",anchor![href$base'++"/_resetPassword"]<<"click here to get a new one."]loginUserForm::HandlerloginUserForm=withData$\params->dodest<-casepDestinationparamsof""->getRefererx->returnxloginFormdest>>=formattedPagedefaultPageLayout{pgShowPageTools=False,pgTabs=[],pgTitle="Login",pgMessages=pMessagesparams}loginUser::Params->HandlerloginUserparams=doletuname=pUsernameparamsletpword=pPasswordparamsletdestination=pDestinationparamsallowed<-authUserunamepwordcfg<-getConfigifallowedthendokey<-newSession(SessionDatauname)addCookie(sessionTimeoutcfg)(mkCookie"sid"(showkey))seeOther(encUrldestination)$toResponse$p<<("Welcome, "++uname)elsewithMessages["Invalid username or password."]loginUserFormencUrl::String->StringencUrl=encStringTrueisAsciilogoutUser::Params->HandlerlogoutUserparams=doletkey=pSessionKeyparamsdest<-casepDestinationparamsof""->getRefererx->returnxcasekeyofJustk->dodelSessionk-- make cookie expire immediately, effectively deleting itaddCookie0(mkCookie"sid""-1")Nothing->return()seeOther(encUrldest)$toResponse"You have been logged out."registerUserForm::HandlerregisterUserForm=registerForm>>=formattedPagedefaultPageLayout{pgShowPageTools=False,pgTabs=[],pgTitle="Register for an account"}formAuthHandlers::[Handler]formAuthHandlers=[dir"_register"$methodSPGETregisterUserForm,dir"_register"$methodSPPOST$withDataregisterUser,dir"_login"$methodSPGETloginUserForm,dir"_login"$methodSPPOST$withDataloginUser,dir"_logout"$methodSPGET$withDatalogoutUser,dir"_resetPassword"$methodSPGET$withDataresetPasswordRequestForm,dir"_resetPassword"$methodSPPOST$withDataresetPasswordRequest,dir"_doResetPassword"$methodSPGET$withDataresetPassword,dir"_doResetPassword"$methodSPPOST$withDatadoResetPassword]loginUserHTTP::Params->HandlerloginUserHTTPparams=dobase'<-getWikiBaseletdestination=pDestinationparams`orIfNull`(base'++"/")seeOther(encUrldestination)$toResponse()logoutUserHTTP::HandlerlogoutUserHTTP=unauthorized$toResponse()-- will this work?httpAuthHandlers::[Handler]httpAuthHandlers=[dir"_logout"$logoutUserHTTP,dir"_login"$withDataloginUserHTTP]