{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE Rank2Types #-}{-|
Pre-packaged Handlers that deal with form submissions and standard use-cases
involving authentication.
-}moduleSnap.Snaplet.Auth.HandlerswhereimportControl.ApplicativeimportControl.Monad.CatchIO(throw)importControl.Monad.StateimportData.ByteString(ByteString)importData.Lens.LazyimportData.Maybe(isJust)importData.Serializehiding(get)importData.TimeimportData.Text.Encoding(decodeUtf8)importData.Text(Text)importWeb.ClientSessionimportSnap.CoreimportSnap.SnapletimportSnap.Snaplet.Auth.AuthManagerimportSnap.Snaplet.Auth.TypesimportSnap.Snaplet.SessionimportSnap.Snaplet.Session.CommonimportSnap.Snaplet.Session.SecureCookie-------------------------------------------------------------------------------- Higher level functions-------------------------------------------------------------------------------------------------------------------------------------------------------------- | Create a new user from just a username and password---- May throw a "DuplicateLogin" if given username is not uniquecreateUser::Text-- Username->ByteString-- Password->Handlerb(AuthManagerb)AuthUsercreateUserunmpwd=withBackend(\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 loginloginByUsername::ByteString-- ^ Username/login for user->Password-- ^ Should be ClearText->Bool-- ^ Set remember token?->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)loginByUsername_(Encrypted_)_=error"Cannot login with encrypted password"loginByUsernameunmpwdrm=dosk<-getssiteKeycn<-getsrememberCookieNamerp<-getsrememberPeriodwithBackend$loginByUsername'skcnrpwhereloginByUsername'::(IAuthBackendt)=>Key->ByteString->MaybeInt->t->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)loginByUsername'skcnrpr=doau<-liftIO$lookupByLoginr(decodeUtf8unm)caseauofNothing->return$LeftUserNotFoundJustau'->dores<-checkPasswordAndLoginau'pwdcaseresofLefte->return$LefteRightau''->docasermofTrue->dotoken<-liftIO$randomToken64setRememberTokenskcnrptokenletau'''=au''{userRememberToken=Just(decodeUtf8token)}saveUserau'''return$Rightau'''False->return$Rightau''-------------------------------------------------------------------------------- | Remember user from the remember token if possible and perform loginloginByRememberToken::Handlerb(AuthManagerb)(MaybeAuthUser)loginByRememberToken=withBackend$\r->dosk<-getssiteKeyrc<-getsrememberCookieNamerp<-getsrememberPeriodtoken<-getRememberTokenskrcrpau<-maybe(returnNothing)(liftIO.lookupByRememberTokenr.decodeUtf8)tokencaseauofJustau'->forceLoginau'>>returnauNothing->returnNothing-------------------------------------------------------------------------------- | Logout the active userlogout::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 resultisLoggedIn::Handlerb(AuthManagerb)BoolisLoggedIn=isJust`fmap`currentUser-------------------------------------------------------------------------------- | Create or update a given user---- May throw a 'BackendError' if something goes wrong.saveUser::AuthUser->Handlerb(AuthManagerb)AuthUsersaveUseru=withBackend$liftIO.flipsaveu-------------------------------------------------------------------------------- | Destroy the given user---- May throw a 'BackendError' if something goes wrong.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)AuthUsermarkAuthFailu=withBackend$\r->dolo<-getslockoutincFailCtru>>=checkLockoutlo>>=liftIO.saverwhereincFailCtru'=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)AuthUsermarkAuthSuccessu=withBackend$\r->doincLoginCtru>>=updateIp>>=updateLoginTS>>=resetFailCtr>>=liftIO.saverwhereincLoginCtru'=return$u'{userLoginCount=userLoginCountu'+1}updateIpu'=doip<-rqRemoteAddr`fmap`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 recordcheckPasswordAndLogin::AuthUser-- ^ An existing user, somehow looked up from db->Password-- ^ A ClearText password->Handlerb(AuthManagerb)(EitherAuthFailureAuthUser)checkPasswordAndLoginupw=caseuserLockedOutUntiluofJustx->donow<-liftIOgetCurrentTimeifnow>xthenauthuelsereturn.Left$LockedOutxNothing->authuwhereauthuser=caseauthenticatePassworduserpwofJuste->domarkAuthFailuserreturn$LefteNothing->doforceLoginusermodify(\mgr->mgr{activeUser=Justuser})user'<-markAuthSuccessuserreturn$Rightuser'-------------------------------------------------------------------------------- | 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$docaseuserIduofJustx->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=getSecureCookiercskrpsetRememberToken::(Serializet,MonadSnapm)=>Key->ByteString->MaybeInt->t->m()setRememberTokenskrcrptoken=setSecureCookiercskrptokenforgetRememberToken::MonadSnapm=>ByteString->m()forgetRememberTokenrc=expireCookierc(Just"/")-------------------------------------------------------------------------------- | Set the current user's 'UserId' in the active sessionsetSessionUserId::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 sessiongetSessionUserId::HandlerbSessionManager(MaybeUserId)getSessionUserId=douid<-getFromSession"__user_id"return$uid>>=return.UserId-------------------------------------------------------------------------------- | Check password for a given user.---- Returns "Nothing" if check is successful and an "IncorrectPassword" error-- otherwiseauthenticatePassword::AuthUser-- ^ Looked up from the back-end->Password-- ^ Check against this password->MaybeAuthFailureauthenticatePasswordupw=authwhereauth=caseuserPassworduofNothing->JustPasswordMissingJustupw->check$checkPasswordpwupwcheckb=ifbthenNothingelseJustIncorrectPassword-------------------------------------------------------------------------------- | Wrap lookups around request-local cachecacheOrLookup::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' fieldsregisterUser::ByteString-- Login field->ByteString-- Password field->Handlerb(AuthManagerb)AuthUserregisterUserlfpf=dol<-fmapdecodeUtf8`fmap`getParamlfp<-getParampfcaseliftM2(,)lpofNothing->throwPasswordMissingJust(lgn,pwd)->docreateUserlgnpwd-------------------------------------------------------------------------------- | A 'MonadSnap' handler that processes a login form.---- The request paremeters are passed to 'performLogin'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=dousername<-getParamunfpassword<-getParampwdfremember<-maybeFalse(=="1")`fmap`maybe(returnNothing)getParamremfmMatch<-casepasswordofNothing->return$LeftPasswordMissingJustpassword'->docaseusernameofNothing->return.Left$AuthError"Username is missing"Justusername'->dologinByUsernameusername'(ClearTextpassword')remembereitherloginFail(constloginSucc)mMatch-------------------------------------------------------------------------------- | 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::Lensb(Snaplet(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(AuthManagerbckend_______)<-getreturn$fbckend