{-# LANGUAGE TemplateHaskell, TypeFamilies, TypeSynonymInstances, DeriveDataTypeable,
FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts,
UndecidableInstances, TypeOperators, RecordWildCards
#-}moduleHappstack.Auth.Core.Auth(UserPass(..),UserPassId(..),UserName(..),UserPassError(..),userPassErrorString,SetUserName(..),AuthState(..),initialAuthState,AuthToken(..),AuthId(..),FacebookId(..),AuthMethod(..),AuthMethod_v1(..),AuthMap(..),HashedPass(..),mkHashedPass,genAuthToken,AskUserPass(..),CheckUserPass(..),CreateUserPass(..),SetPassword(..),AddAuthToken(..),AskAuthToken(..),UpdateAuthToken(..),DeleteAuthToken(..),AuthTokenAuthId(..),GenAuthId(..),AddAuthMethod(..),NewAuthMethod(..),RemoveAuthIdentifier(..),IdentifierAuthIds(..),FacebookAuthIds(..),AddAuthUserPassId(..),RemoveAuthUserPassId(..),UserPassIdAuthIds(..),AskAuthState(..),addAuthCookie,deleteAuthCookie,getAuthId,getAuthToken)whereimportControl.Applicative(Alternative,(<$>),optional)importControl.Monad(replicateM)importControl.Monad.Reader(ask)importControl.Monad.State(get,put)importControl.Monad.Trans(MonadIO(..))importCrypto.PasswordStoreimportData.AcidimportData.Acid.Advanced(query',update')importData.ByteString(ByteString)importqualifiedData.ByteString.Char8asBimportData.Data(Data,Typeable)importqualifiedData.IxSetasIxSetimportData.IxSet(IxSet,(@=),inferIxSet,noCalcs,getOne,updateIx)importData.Map(Map)importqualifiedData.MapasMapimportData.SafeCopy-- (base, deriveSafeCopy)importData.Set(Set)importqualifiedData.SetasSetimportData.Time.Clock(UTCTime,addUTCTime,getCurrentTime,)importqualifiedData.TextasTextimportqualifiedData.Text.EncodingasTextimportData.Text(Text)importNetwork.HTTP.Types(Ascii)importWeb.Authenticate.OpenId(Identifier)importWeb.Routes(PathInfo(..))importHappstack.Server(CookieLife(..),Happstack,addCookie,expireCookie,lookCookieValue,mkCookie)newtypeAuthId=AuthId{unAuthId::Integer}deriving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy1'base''AuthId)instancePathInfoAuthIdwheretoPathSegments(AuthIdi)=toPathSegmentsifromPathSegments=AuthId<$>fromPathSegmentssuccAuthId::AuthId->AuthIdsuccAuthId(AuthIdi)=AuthId(succi)-- * UserPassnewtypeHashedPass=HashedPassByteStringderiving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy1'base''HashedPass)-- | NOTE: The Eq and Ord instances are 'case-insensitive'. They apply 'toCaseFold' before comparing.newtypeUserName=UserName{unUserName::Text}deriving(Read,Show,Data,Typeable)$(deriveSafeCopy1'base''UserName)instanceEqUserNamewhere(UserNamex)==(UserNamey)=(Text.toCaseFoldx)==(Text.toCaseFoldy)(UserNamex)/=(UserNamey)=(Text.toCaseFoldx)/=(Text.toCaseFoldy)instanceOrdUserNamewherecompare(UserNamex)(UserNamey)=compare(Text.toCaseFoldx)(Text.toCaseFoldy)(UserNamex)<(UserNamey)=(Text.toCaseFoldx)<(Text.toCaseFoldy)(UserNamex)>=(UserNamey)=(Text.toCaseFoldx)>=(Text.toCaseFoldy)(UserNamex)>(UserNamey)=(Text.toCaseFoldx)>(Text.toCaseFoldy)(UserNamex)<=(UserNamey)=(Text.toCaseFoldx)<=(Text.toCaseFoldy)max(UserNamex)(UserNamey)=UserName$max(Text.toCaseFoldx)(Text.toCaseFoldy)min(UserNamex)(UserNamey)=UserName$min(Text.toCaseFoldx)(Text.toCaseFoldy)newtypeUserPassId=UserPassId{unUserPassId::Integer}deriving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy1'base''UserPassId)succUserPassId::UserPassId->UserPassIdsuccUserPassId(UserPassIdi)=UserPassId(succi)dataUserPass=UserPass{upName::UserName,upPassword::HashedPass,upId::UserPassId}deriving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy1'base''UserPass)$(inferIxSet"UserPasses"''UserPass'noCalcs[''UserName,''HashedPass,''AuthId,''UserPassId])-- * Identifier$(deriveSafeCopy1'base''Identifier)-- * AuthMapnewtypeFacebookId_001=FacebookId_001{unFacebookId_001::Text}deriving(Eq,Ord,Read,Show,Data,Typeable,SafeCopy)newtypeFacebookId=FacebookId{unFacebookId::Ascii}deriving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy2'extension''FacebookId)instanceMigrateFacebookIdwheretypeMigrateFromFacebookId=FacebookId_001migrate(FacebookId_001fid)=FacebookId(Text.encodeUtf8fid)dataAuthMethod_v1=AuthIdentifier_v1{amIdentifier_v1::Identifier}|AuthUserPassId_v1{amUserPassId_v1::UserPassId}deriving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy1'base''AuthMethod_v1)dataAuthMethod=AuthIdentifier{amIdentifier::Identifier}|AuthUserPassId{amUserPassId::UserPassId}|AuthFacebook{amFacebookId::FacebookId}deriving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy2'extension''AuthMethod)instanceMigrateAuthMethodwheretypeMigrateFromAuthMethod=AuthMethod_v1migrate(AuthIdentifier_v1ident)=AuthIdentifieridentmigrate(AuthUserPassId_v1up)=AuthUserPassIdupdataAuthMap=AuthMap{amMethod::AuthMethod,amAuthId::AuthId}deriving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy1'base''AuthMap)$(inferIxSet"AuthMaps"''AuthMap'noCalcs[''AuthId,''AuthMethod,''Identifier,''UserPassId,''FacebookId])-- * AuthTokendataAuthToken=AuthToken{tokenString::String,tokenExpires::UTCTime,tokenAuthId::MaybeAuthId,tokenAuthMethod::AuthMethod}deriving(Eq,Ord,Data,Show,Typeable)$(deriveSafeCopy1'base''AuthToken)$(inferIxSet"AuthTokens"''AuthToken'noCalcs[''String,''AuthId])-- * AuthState-- how to we remove expired AuthTokens?---- Since the user might be logged in a several machines they might have several auth tokens. So we can not just expire the old ones everytime they log in.---- Basically we can expired them on: logout and time---- time is tricky because we do not really want to do a db update everytime they access the sitedataAuthState=AuthState{userPasses::UserPasses,nextUserPassId::UserPassId,authMaps::AuthMaps,nextAuthId::AuthId,authTokens::AuthTokens}deriving(Data,Eq,Show,Typeable)$(deriveSafeCopy1'base''AuthState)-- | a reasonable initial 'AuthState'initialAuthState::AuthStateinitialAuthState=AuthState{userPasses=IxSet.empty,nextUserPassId=UserPassId1,authMaps=IxSet.empty,authTokens=IxSet.empty,nextAuthId=AuthId1}-- ** UserPassmodifyUserPass::UserPassId->(UserPass->UserPass)->UpdateAuthState(MaybeUserPassError)modifyUserPassupidfn=doas@(AuthState{..})<-getcasegetOne$userPasses@=upidofNothing->return(Just$InvalidUserPassIdupid)(JustuserPass)->doletuserPass'=fnuserPassputas{userPasses=IxSet.updateIxupiduserPass'userPasses}returnNothing-- | errors that can occur when working with 'UserPass'dataUserPassError=UsernameInUseUserName|InvalidUserPassIdUserPassId|InvalidUserNameUserName|InvalidPasswordderiving(Eq,Ord,Read,Show,Data,Typeable)$(deriveSafeCopy1'base''UserPassError)-- | return a user-friendly error message string for an 'AddAuthError'userPassErrorString::UserPassError->StringuserPassErrorString(UsernameInUse(UserNametxt))="Username already in use: "++Text.unpacktxtuserPassErrorString(InvalidUserPassId(UserPassIdi))="Invalid UserPassId "++showiuserPassErrorString(InvalidUserName(UserNamename))="Invalid username "++Text.unpacknameuserPassErrorStringInvalidPassword="Invalid password"-- | creates a new 'UserPass'createUserPass::UserName-- ^ desired username->HashedPass-- ^ hashed password->UpdateAuthState(EitherUserPassErrorUserPass)createUserPassnamehashedPass=doas@(AuthState{..})<-getifnot(IxSet.null$userPasses@=name)thenreturn(Left(UsernameInUsename))elsedoletuserPass=UserPass{upName=name,upPassword=hashedPass,upId=nextUserPassId}put$as{userPasses=IxSet.insertuserPassuserPasses,nextUserPassId=succUserPassIdnextUserPassId}return(RightuserPass)-- | change the 'UserName' associated with a 'UserPassId'-- this will break password salting...setUserName::UserPassId->Text->UpdateAuthState(MaybeUserPassError)setUserNameupidname=doas<-getifnameAvailable(userPassesas)thencasegetOne$(userPassesas)@=upidof(JustuserPass)->doput$as{userPasses=IxSet.updateIxupid(userPass{upName=UserNamename})(userPassesas)}returnNothingNothing->return(Just$InvalidUserPassIdupid)elsereturn(Just$UsernameInUse(UserNamename))wherenameAvailableuserPasses=caseIxSet.toList(userPasses@=(UserNamename))of[]->True[a]|(upIda==upid)->True_->False-- | hash a password stringmkHashedPass::Text-- ^ password in plain text->IOHashedPass-- ^ salted and hashedmkHashedPasspass=HashedPass<$>makePassword(Text.encodeUtf8pass)12-- | verify a passwordverifyHashedPass::Text-- ^ password in plain text->HashedPass-- ^ hashed version of password->BoolverifyHashedPasspasswd(HashedPasshashedPass)=verifyPassword(Text.encodeUtf8passwd)hashedPass-- | change the password for the give 'UserPassId'setPassword::UserPassId->HashedPass->UpdateAuthState(MaybeUserPassError)setPasswordupidhashedPass=modifyUserPassupid$\userPass->userPass{upPassword=hashedPass}checkUserPass::Text->Text->QueryAuthState(EitherUserPassErrorUserPassId)checkUserPassusernamepassword=doas@(AuthState{..})<-askcaseIxSet.getOne$userPasses@=(UserNameusername)ofNothing->return(Left$InvalidUserName(UserNameusername))(JustuserPass)|verifyHashedPasspassword(upPassworduserPass)->doreturn(Right(upIduserPass))|otherwise->return(LeftInvalidPassword)askUserPass::UserPassId->QueryAuthState(MaybeUserPass)askUserPassuid=doas@(AuthState{..})<-askreturn$getOne$userPasses@=uid-- ** AuthMapaddAuthMethod::AuthMethod->AuthId->UpdateAuthState()addAuthMethodauthMethodauthid=doas@(AuthState{..})<-getput$as{authMaps=IxSet.insert(AuthMapauthMethodauthid)authMaps}newAuthMethod::AuthMethod->UpdateAuthStateAuthIdnewAuthMethodauthMethod=doas@(AuthState{..})<-getput$as{authMaps=IxSet.insert(AuthMapauthMethodnextAuthId)authMaps,nextAuthId=succAuthIdnextAuthId}returnnextAuthIdremoveAuthIdentifier::Identifier->AuthId->UpdateAuthState()removeAuthIdentifieridentifierauthid=doas@(AuthState{..})<-getput$as{authMaps=IxSet.delete(AuthMap(AuthIdentifieridentifier)authid)authMaps}identifierAuthIds::Identifier->QueryAuthState(SetAuthId)identifierAuthIdsidentifier=doas@(AuthState{..})<-askreturn$Set.mapamAuthId$IxSet.toSet$authMaps@=identifierfacebookAuthIds::FacebookId->QueryAuthState(SetAuthId)facebookAuthIdsfacebookId=doas@(AuthState{..})<-askreturn$Set.mapamAuthId$IxSet.toSet$authMaps@=facebookIdaddAuthUserPassId::UserPassId->AuthId->UpdateAuthState()addAuthUserPassIdupidauthid=doas@(AuthState{..})<-getput$as{authMaps=IxSet.insert(AuthMap(AuthUserPassIdupid)authid)authMaps}removeAuthUserPassId::UserPassId->AuthId->UpdateAuthState()removeAuthUserPassIdupidauthid=doas@(AuthState{..})<-getput$as{authMaps=IxSet.delete(AuthMap(AuthUserPassIdupid)authid)authMaps}userPassIdAuthIds::UserPassId->QueryAuthState(SetAuthId)userPassIdAuthIdsupid=doas@(AuthState{..})<-askreturn$Set.mapamAuthId$IxSet.toSet$authMaps@=upid-- * AuthTokenaddAuthToken::AuthToken->UpdateAuthState()addAuthTokenauthToken=doas@AuthState{..}<-getput(as{authTokens=IxSet.insertauthTokenauthTokens})-- | look up the 'AuthToken' associated with the 'String'askAuthToken::String-- ^ token string (used in the cookie)->QueryAuthState(MaybeAuthToken)askAuthTokentokenStr=doas@AuthState{..}<-askreturn$getOne$authTokens@=tokenStrupdateAuthToken::AuthToken->UpdateAuthState()updateAuthTokenauthToken=doas@AuthState{..}<-getput(as{authTokens=IxSet.updateIx(tokenStringauthToken)authTokenauthTokens})deleteAuthToken::String->UpdateAuthState()deleteAuthTokentokenStr=doas@AuthState{..}<-getput(as{authTokens=IxSet.deleteIxtokenStrauthTokens})authTokenAuthId::String->QueryAuthState(MaybeAuthId)authTokenAuthIdtokenString=doas@(AuthState{..})<-askcasegetOne$authTokens@=tokenStringofNothing->returnNothing(JustauthToken)->return$(tokenAuthIdauthToken)-- TODO:-- - expireAuthTokens-- - tickleAuthToken-- | generate an new authentication tokengenAuthToken::(MonadIOm)=>MaybeAuthId->AuthMethod->Int->mAuthTokengenAuthTokenaidauthMethodlifetime=dorandom<-liftIO$B.unpack.exportSalt<$>genSaltIO-- the docs promise that the salt will be base64, so 'B.unpack' should be safenow<-liftIO$getCurrentTimeletexpires=addUTCTime(fromIntegrallifetime)nowprefix=caseaidofNothing->"0"(Justa)->show(unAuthIda)return$AuthToken{tokenString=prefix++random,tokenExpires=expires,tokenAuthId=aid,tokenAuthMethod=authMethod}-- | generate a new, unused 'AuthId'genAuthId::UpdateAuthStateAuthIdgenAuthId=doas@(AuthState{..})<-getput(as{nextAuthId=succAuthIdnextAuthId})returnnextAuthIdaskAuthState::QueryAuthStateAuthStateaskAuthState=ask$(makeAcidic''AuthState['askUserPass,'checkUserPass,'createUserPass,'setUserName,'setPassword,'addAuthToken,'askAuthToken,'updateAuthToken,'deleteAuthToken,'authTokenAuthId,'genAuthId,'addAuthMethod,'newAuthMethod,'removeAuthIdentifier,'identifierAuthIds,'facebookAuthIds,'addAuthUserPassId,'removeAuthUserPassId,'userPassIdAuthIds,'askAuthState])-- * happstack-server level stuffaddAuthCookie::(Happstackm)=>AcidStateAuthState->MaybeAuthId->AuthMethod->m()addAuthCookieacidHaidauthMethod=doauthToken<-genAuthTokenaidauthMethod(60*60)update'acidH(AddAuthTokenauthToken)addCookieSession(mkCookie"authToken"(tokenStringauthToken))return()deleteAuthCookie::(Happstackm,Alternativem)=>AcidStateAuthState->m()deleteAuthCookieacidH=domTokenStr<-optional$lookCookieValue"authToken"casemTokenStrofNothing->return()(JusttokenStr)->doexpireCookie"authToken"update'acidH(DeleteAuthTokentokenStr)getAuthToken::(Alternativem,Happstackm)=>AcidStateAuthState->m(MaybeAuthToken)getAuthTokenacidH=domTokenStr<-optional$lookCookieValue"authToken"casemTokenStrofNothing->returnNothing(JusttokenStr)->query'acidH(AskAuthTokentokenStr)getAuthId::(Alternativem,Happstackm)=>AcidStateAuthState->m(MaybeAuthId)getAuthIdacidH=domTokenStr<-optional$lookCookieValue"authToken"casemTokenStrofNothing->returnNothing(JusttokenStr)->query'acidH(AuthTokenAuthIdtokenStr)