{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE Rank2Types #-}-------------------------------------------------------------------------------- | Pre-packaged Handlers that deal with form submissions and standard-- use-cases involving authentication.moduleSnap.Snaplet.Auth.Handlerswhere------------------------------------------------------------------------------importControl.ApplicativeimportControl.ErrorimportControl.Monad.StateimportData.ByteString(ByteString)importData.Serializehiding(get)importData.TimeimportData.Text.Encoding(decodeUtf8)importData.Text(Text,null,strip)importPreludehiding(null)importWeb.ClientSession------------------------------------------------------------------------------importSnap.CoreimportSnap.SnapletimportSnap.Snaplet.Auth.AuthManagerimportSnap.Snaplet.Auth.TypesimportSnap.Snaplet.Session------------------------------------------------------------------------------------------------------------ Higher level functions -------------------------------------------------------------------------------------------------------------- | Create a new user from just a username and password--createUser::Text-- ^ Username->ByteString-- ^ Password->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)createUserunmpwd|null$stripunm=return$LeftUsernameMissing|otherwise=douExists<-usernameExistsunmifuExiststhenreturn$LeftDuplicateLoginelsewithBackend$\r->liftIO$buildAuthUserrunmpwd-------------------------------------------------------------------------------- | Check whether a user with the given username exists.--usernameExists::Text-- ^ The username to be checked->Handlerb(AuthManagerb)BoolusernameExistsusername=withBackend$\r->liftIO$isJust<$>lookupByLoginrusername-------------------------------------------------------------------------------- | Lookup a user by her username, check given password and perform login--loginByUsername::ByteString-- ^ Username/login for user->Password-- ^ Should be ClearText->Bool-- ^ Set remember token?->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)loginByUsername_(Encrypted_)_=return$LeftEncryptedPasswordloginByUsernameunmpwdshouldRemember=dosk<-getssiteKeycn<-getsrememberCookieNamerp<-getsrememberPeriodwithBackend$loginByUsername'skcnrpwhere--------------------------------------------------------------------------loginByUsername'::(IAuthBackendt)=>Key->ByteString->MaybeInt->t->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)loginByUsername'skcnrpr=liftIO(lookupByLoginr$decodeUtf8unm)>>=maybe(return$!LeftUserNotFound)foundwhere----------------------------------------------------------------------founduser=checkPasswordAndLoginuserpwd>>=either(return.Left)matched----------------------------------------------------------------------matcheduser|shouldRemember=dotoken<-getsrandomNumberGenerator>>=liftIO.randomToken64setRememberTokenskcnrptokenletuser'=user{userRememberToken=Just(decodeUtf8token)}saveUseruser'return$!Rightuser'|otherwise=return$Rightuser-------------------------------------------------------------------------------- | Remember user from the remember token if possible and perform login--loginByRememberToken::Handlerb(AuthManagerb)(MaybeAuthUser)loginByRememberToken=withBackend$\impl->dokey<-getssiteKeycookieName_<-getsrememberCookieNameperiod<-getsrememberPeriodrunMaybeT$dotoken<-MaybeT$getRememberTokenkeycookieName_perioduser<-MaybeT$liftIO$lookupByRememberTokenimpl$decodeUtf8tokenlift$forceLoginuserreturnuser-------------------------------------------------------------------------------- | Logout the active user--logout::Handlerb(AuthManagerb)()logout=dos<-getssessionwithTops$withSessionsremoveSessionUserIdrc<-getsrememberCookieNameforgetRememberTokenrcmodify$\mgr->mgr{activeUser=Nothing}-------------------------------------------------------------------------------- | Return the current user; trying to remember from cookie if possible.--currentUser::Handlerb(AuthManagerb)(MaybeAuthUser)currentUser=cacheOrLookup$withBackend$\r->dos<-getssessionuid<-withTopsgetSessionUserIdcaseuidofNothing->loginByRememberTokenJustuid'->liftIO$lookupByUserIdruid'-------------------------------------------------------------------------------- | Convenience wrapper around 'rememberUser' that returns a bool result--isLoggedIn::Handlerb(AuthManagerb)BoolisLoggedIn=isJust<$>currentUser-------------------------------------------------------------------------------- | Create or update a given user--saveUser::AuthUser->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)saveUseru|null$userLoginu=return$LeftUsernameMissing|otherwise=withBackend$\r->liftIO$saveru-------------------------------------------------------------------------------- | Destroy the given user--destroyUser::AuthUser->Handlerb(AuthManagerb)()destroyUseru=withBackend$liftIO.flipdestroyu------------------------------------- Lower level helper functions --------------------------------------------------------------------------------------------------------------------- | Mutate an 'AuthUser', marking failed authentication---- This will save the user to the backend.--markAuthFail::AuthUser->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)markAuthFailu=withBackend$\r->dolo<-getslockoutincFailCtru>>=checkLockoutlo>>=liftIO.saverwhere--------------------------------------------------------------------------incFailCtru'=return$u'{userFailedLoginCount=userFailedLoginCountu'+1}--------------------------------------------------------------------------checkLockoutlou'=caseloofNothing->returnu'Just(mx,wait)->ifuserFailedLoginCountu'>=mxthendonow<-liftIOgetCurrentTimeletreopen=addUTCTimewaitnowreturn$!u'{userLockedOutUntil=Justreopen}elsereturnu'-------------------------------------------------------------------------------- | Mutate an 'AuthUser', marking successful authentication---- This will save the user to the backend.--markAuthSuccess::AuthUser->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)markAuthSuccessu=withBackend$\r->incLoginCtru>>=updateIp>>=updateLoginTS>>=resetFailCtr>>=liftIO.saverwhere--------------------------------------------------------------------------incLoginCtru'=return$u'{userLoginCount=userLoginCountu'+1}--------------------------------------------------------------------------updateIpu'=doip<-rqRemoteAddr<$>getRequestreturn$u'{userLastLoginIp=userCurrentLoginIpu',userCurrentLoginIp=Justip}--------------------------------------------------------------------------updateLoginTSu'=donow<-liftIOgetCurrentTimereturn$u'{userCurrentLoginAt=Justnow,userLastLoginAt=userCurrentLoginAtu'}--------------------------------------------------------------------------resetFailCtru'=return$u'{userFailedLoginCount=0,userLockedOutUntil=Nothing}-------------------------------------------------------------------------------- | Authenticate and log the user into the current session if successful.---- This is a mid-level function exposed to allow roll-your-own ways of looking-- up a user from the database.---- This function will:---- 1. Check the password---- 2. Login the user into the current session---- 3. Mark success/failure of the authentication trial on the user record--checkPasswordAndLogin::AuthUser-- ^ An existing user, somehow looked up from db->Password-- ^ A ClearText password->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)checkPasswordAndLoginupw=caseuserLockedOutUntiluofJustx->donow<-liftIOgetCurrentTimeifnow>xthenauthuelsereturn.Left$LockedOutxNothing->authuwhereauth::AuthUser->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)authuser=caseauthenticatePassworduserpwofJuste->domarkAuthFailuserreturn$LefteNothing->doforceLoginusermodify(\mgr->mgr{activeUser=Justuser})markAuthSuccessuser-------------------------------------------------------------------------------- | Login and persist the given 'AuthUser' in the active session---- Meant to be used if you have other means of being sure that the person is-- who she says she is.--forceLogin::AuthUser-- ^ An existing user, somehow looked up from db->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)forceLoginu=dos<-getssessionwithSessions$caseuserIduofJustx->dowithTops(setSessionUserIdx)return$RightuNothing->return.Left$AuthError$"forceLogin: Can't force the login of a user "++"without userId"-------------------------------------- Internal, non-exported helpers --------------------------------------------------------------------------------------------------------------------getRememberToken::(Serializet,MonadSnapm)=>Key->ByteString->MaybeInt->m(Maybet)getRememberTokenskrcrp=getSecureCookiercskrp------------------------------------------------------------------------------setRememberToken::(Serializet,MonadSnapm)=>Key->ByteString->MaybeInt->t->m()setRememberTokenskrcrptoken=setSecureCookiercskrptoken------------------------------------------------------------------------------forgetRememberToken::MonadSnapm=>ByteString->m()forgetRememberTokenrc=expireCookierc(Just"/")-------------------------------------------------------------------------------- | Set the current user's 'UserId' in the active session--setSessionUserId::UserId->HandlerbSessionManager()setSessionUserId(UserIdt)=setInSession"__user_id"t-------------------------------------------------------------------------------- | Remove 'UserId' from active session, effectively logging the user out.removeSessionUserId::HandlerbSessionManager()removeSessionUserId=deleteFromSession"__user_id"-------------------------------------------------------------------------------- | Get the current user's 'UserId' from the active session--getSessionUserId::HandlerbSessionManager(MaybeUserId)getSessionUserId=douid<-getFromSession"__user_id"return$liftMUserIduid-------------------------------------------------------------------------------- | Check password for a given user.---- Returns "Nothing" if check is successful and an "IncorrectPassword" error-- otherwise--authenticatePassword::AuthUser-- ^ Looked up from the back-end->Password-- ^ Check against this password->MaybeAuthFailureauthenticatePasswordupw=authwhereauth=caseuserPassworduofNothing->JustPasswordMissingJustupw->check$checkPasswordpwupwcheckb=ifbthenNothingelseJustIncorrectPassword-------------------------------------------------------------------------------- | Wrap lookups around request-local cache--cacheOrLookup::Handlerb(AuthManagerb)(MaybeAuthUser)-- ^ Lookup action to perform if request local cache is empty->Handlerb(AuthManagerb)(MaybeAuthUser)cacheOrLookupf=doau<-getsactiveUserifisJustauthenreturnauelsedoau'<-fmodify(\mgr->mgr{activeUser=au'})returnau'-------------------------------------------------------------------------------- | Register a new user by specifying login and password 'Param' fields--registerUser::ByteString-- ^ Login field->ByteString-- ^ Password field->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)registerUserlfpf=dol<-fmapdecodeUtf8<$>getParamlfp<-getParampfletl'=noteUsernameMissinglletp'=notePasswordMissingp-- In case of multiple AuthFailure, the first available one-- will be propagated.caseliftM2(,)l'p'ofLefte->return$LefteRight(lgn,pwd)->createUserlgnpwd-------------------------------------------------------------------------------- | A 'MonadSnap' handler that processes a login form.---- The request paremeters are passed to 'performLogin'---- To make your users stay logged in for longer than the session replay-- prevention timeout, you must pass a field name as the third parameter and-- that field must be set to a value of \"1\" by the submitting form. This-- lets you use a user selectable check box. Or if you want user remembering-- always turned on, you can use a hidden form field.loginUser::ByteString-- ^ Username field->ByteString-- ^ Password field->MaybeByteString-- ^ Remember field; Nothing if you want no remember function.->(AuthFailure->Handlerb(AuthManagerb)())-- ^ Upon failure->Handlerb(AuthManagerb)()-- ^ Upon success->Handlerb(AuthManagerb)()loginUserunfpwdfremfloginFailloginSucc=runEitherT(loginUser'unfpwdfremf)>>=eitherloginFail(constloginSucc)------------------------------------------------------------------------------loginUser'::ByteString->ByteString->MaybeByteString->EitherTAuthFailure(Handlerb(AuthManagerb))AuthUserloginUser'unfpwdfremf=dombUsername<-lift$getParamunfmbPassword<-lift$getParampwdfremember<-lift$liftM(fromMaybeFalse)(runMaybeT$dofield<-MaybeT$returnremfvalue<-MaybeT$getParamfieldreturn$value=="1")password<-noteTPasswordMissing$hoistMaybembPasswordusername<-noteTUsernameMissing$hoistMaybembUsernameEitherT$loginByUsernameusername(ClearTextpassword)remember-------------------------------------------------------------------------------- | Simple handler to log the user out. Deletes user from session.--logoutUser::Handlerb(AuthManagerb)()-- ^ What to do after logging out->Handlerb(AuthManagerb)()logoutUsertarget=logout>>target-------------------------------------------------------------------------------- | Require that an authenticated 'AuthUser' is present in the current-- session.---- This function has no DB cost - only checks to see if a user_id is present-- in the current session.--requireUser::SnapletLensb(AuthManagerb)-- ^ Lens reference to an "AuthManager"->Handlerbva-- ^ Do this if no authenticated user is present.->Handlerbva-- ^ Do this if an authenticated user is present.->HandlerbvarequireUserauthbadgood=dologgedIn<-withTopauthisLoggedInifloggedInthengoodelsebad-------------------------------------------------------------------------------- | Run a function on the backend, and return the result.---- This uses an existential type so that the backend type doesn't-- 'escape' AuthManager. The reason that the type is Handler b-- (AuthManager v) a and not a is because anything that uses the-- backend will return an IO something, which you can liftIO, or a-- Handler b (AuthManager v) a if it uses other handler things.--withBackend::(forallr.(IAuthBackendr)=>r->Handlerb(AuthManagerv)a)-- ^ The function to run with the handler.->Handlerb(AuthManagerv)awithBackendf=join$do(AuthManagerbackend_________)<-getreturn$fbackend_-------------------------------------------------------------------------------- | This function generates a random password reset token and stores it in-- the database for the user. Call this function when a user forgets their-- password. Then use the token to autogenerate a link that the user can-- visit to reset their password. This function also sets a timestamp so the-- reset token can be expired.setPasswordResetToken::Text->Handlerb(AuthManagerb)(MaybeText)setPasswordResetTokenlogin=dotokBS<-liftIO.randomToken40=<<getsrandomNumberGeneratorlettoken=decodeUtf8tokBSnow<-liftIOgetCurrentTimesuccess<-modPasswordResetTokenlogin(Justtoken)(Justnow)return$ifsuccessthenJusttokenelseNothing-------------------------------------------------------------------------------- | Clears a user's password reset token. Call this when the user-- successfully changes their password to ensure that the password reset link-- cannot be used again.clearPasswordResetToken::Text->Handlerb(AuthManagerb)BoolclearPasswordResetTokenlogin=modPasswordResetTokenloginNothingNothing-------------------------------------------------------------------------------- | Helper function used for setting and clearing the password reset token-- and associated timestamp.modPasswordResetToken::Text->MaybeText->MaybeUTCTime->Handlerv(AuthManagerv)BoolmodPasswordResetTokenlogintokentimestamp=dores<-runMaybeT$dou<-MaybeT$withBackend$\b->liftIO$lookupByLoginbloginlift$saveUser$u{userResetToken=token,userResetRequestedAt=timestamp}return()return$maybeFalse(\_->True)res