{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE GeneralizedNewtypeDeriving #-}{-# LANGUAGE OverloadedStrings #-}moduleSnap.Snaplet.Auth.Typeswhere------------------------------------------------------------------------------importControl.ApplicativeimportControl.ArrowimportControl.Monad.CatchIOimportControl.Monad.TransimportControl.Monad.Trans.ErrorimportCrypto.PasswordStoreimportData.AesonimportData.ByteString(ByteString)importqualifiedData.ConfiguratorasCimportData.HashMap.Strict(HashMap)importqualifiedData.HashMap.StrictasHMimportData.Hashable(Hashable)importData.TimeimportData.Text(Text)importData.TypeableimportSnap.Snaplet-------------------------------------------------------------------------------- | Password is clear when supplied by the user and encrypted later when-- returned from the db.dataPassword=ClearTextByteString|EncryptedByteStringderiving(Read,Show,Ord,Eq)-------------------------------------------------------------------------------- | Default strength level to pass into makePassword.defaultStrength::IntdefaultStrength=12--------------------------------------------------------------------------------- | The underlying encryption function, in case you need it for-- external processing.encrypt::ByteString->IOByteStringencrypt=flipmakePassworddefaultStrength--------------------------------------------------------------------------------- | The underlying verify function, in case you need it for external-- processing.verify::ByteString-- ^ Cleartext->ByteString-- ^ Encrypted reference->Boolverify=verifyPassword-------------------------------------------------------------------------------- | Turn a 'ClearText' password into an 'Encrypted' password, ready to-- be stuffed into a database.encryptPassword::Password->IOPasswordencryptPasswordp@(Encrypted{})=returnpencryptPassword(ClearTextp)=Encrypted`fmap`encryptp------------------------------------------------------------------------------checkPassword::Password->Password->BoolcheckPassword(ClearTextpw)(Encryptedpw')=verifypwpw'checkPassword(ClearTextpw)(ClearTextpw')=pw==pw'checkPassword(Encryptedpw)(Encryptedpw')=pw==pw'checkPassword__=error"checkPassword failed. Make sure you pass ClearText passwords"-------------------------------------------------------------------------------- | Authentication failures indicate what went wrong during authentication.-- They may provide useful information to the developer, although it is-- generally not advisable to show the user the exact details about why login-- failed.dataAuthFailure=UserNotFound|IncorrectPassword|PasswordMissing|LockedOutUTCTime-- ^ Locked out until given time|AuthErrorStringderiving(Read,Show,Ord,Eq,Typeable)instanceExceptionAuthFailureinstanceErrorAuthFailurewherestrMsg=AuthError-------------------------------------------------------------------------------- | Internal representation of a 'User'. By convention, we demand that the-- application is able to directly fetch a 'User' using this identifier.---- Think of this type as a secure, authenticated user. You should normally-- never see this type unless a user has been authenticated.newtypeUserId=UserId{unUid::Text}deriving(Read,Show,Ord,Eq,FromJSON,ToJSON,Hashable)-------------------------------------------------------------------------------- | This will be replaced by a role-based permission system.dataRole=RoleByteStringderiving(Read,Show,Ord,Eq)-------------------------------------------------------------------------------- | Type representing the concept of a User in your application.dataAuthUser=AuthUser{userId::MaybeUserId,userLogin::Text,userPassword::MaybePassword,userActivatedAt::MaybeUTCTime,userSuspendedAt::MaybeUTCTime,userRememberToken::MaybeText,userLoginCount::Int,userFailedLoginCount::Int,userLockedOutUntil::MaybeUTCTime,userCurrentLoginAt::MaybeUTCTime,userLastLoginAt::MaybeUTCTime,userCurrentLoginIp::MaybeByteString,userLastLoginIp::MaybeByteString,userCreatedAt::MaybeUTCTime,userUpdatedAt::MaybeUTCTime,userRoles::[Role],userMeta::HashMapTextValue}deriving(Show,Eq)-------------------------------------------------------------------------------- | Default AuthUser that has all empty values.defAuthUser::AuthUserdefAuthUser=AuthUser{userId=Nothing,userLogin="",userPassword=Nothing,userActivatedAt=Nothing,userSuspendedAt=Nothing,userRememberToken=Nothing,userLoginCount=0,userFailedLoginCount=0,userLockedOutUntil=Nothing,userCurrentLoginAt=Nothing,userLastLoginAt=Nothing,userCurrentLoginIp=Nothing,userLastLoginIp=Nothing,userCreatedAt=Nothing,userUpdatedAt=Nothing,userRoles=[],userMeta=HM.empty}-------------------------------------------------------------------------------- | Set a new password for the given user. Given password should be-- clear-text; it will be encrypted into a 'Encrypted'.setPassword::AuthUser->ByteString->IOAuthUsersetPasswordaupass=dopw<-Encrypted<$>makePasswordpassdefaultStrengthreturn$!au{userPassword=Justpw}-------------------------------------------------------------------------------- | Authetication settings defined at initialization timedataAuthSettings=AuthSettings{asMinPasswdLen::Int-- ^ Currently not used/checked,asRememberCookieName::ByteString-- ^ Name of the desired remember cookie,asRememberPeriod::MaybeInt-- ^ How long to remember when the option is used in rest of the API.-- 'Nothing' means remember until end of session.,asLockout::Maybe(Int,NominalDiffTime)-- ^ Lockout strategy: ([MaxAttempts], [LockoutDuration]),asSiteKey::FilePath-- ^ Location of app's encryption key}-------------------------------------------------------------------------------- | Default settings for Auth.---- > asMinPasswdLen = 8-- > asRememberCookieName = "_remember"-- > asRememberPeriod = Just (2*7*24*60*60) = 2 weeks-- > asLockout = Nothing-- > asSiteKey = "site_key.txt"defAuthSettings::AuthSettingsdefAuthSettings=AuthSettings{asMinPasswdLen=8,asRememberCookieName="_remember",asRememberPeriod=Just(2*7*24*60*60),asLockout=Nothing,asSiteKey="site_key.txt"}-------------------------------------------------------------------------------- | Function to get auth settings from a config file. This function can be-- used by the authors of auth snaplet backends in the initializer to let the-- user configure the auth snaplet from a config file. All options are-- optional and default to what's in defAuthSettings if not supplied.-- Here's what the default options would look like in the config file:---- > minPasswordLen = 8-- > rememberCookie = "_remember"-- > rememberPeriod = 1209600 # 2 weeks-- > lockout = [5, 86400] # 5 attempts locks you out for 86400 seconds-- > siteKey = "site_key.txt"authSettingsFromConfig::InitializerbvAuthSettingsauthSettingsFromConfig=doconfig<-getSnapletUserConfigminPasswordLen<-liftIO$C.lookupconfig"minPasswordLen"letpw=maybeid(\xs->s{asMinPasswdLen=x})minPasswordLenrememberCookie<-liftIO$C.lookupconfig"rememberCookie"letrc=maybeid(\xs->s{asRememberCookieName=x})rememberCookierememberPeriod<-liftIO$C.lookupconfig"rememberPeriod"letrp=maybeid(\xs->s{asRememberPeriod=Justx})rememberPeriodlockout<-liftIO$C.lookupconfig"lockout"letlo=maybeid(\xs->s{asLockout=Just(secondfromIntegerx)})lockoutsiteKey<-liftIO$C.lookupconfig"siteKey"letsk=maybeid(\xs->s{asSiteKey=x})siteKeyreturn$(pw.rc.rp.lo.sk)defAuthSettings------------------------------------------------------------------------------dataBackendError=DuplicateLogin|BackendErrorStringderiving(Eq,Show,Read,Typeable)instanceExceptionBackendError---------------------- JSON Instances ----------------------------------------------------------------------------------------------------instanceToJSONAuthUserwheretoJSONu=object["uid".=userIdu,"login".=userLoginu,"pw".=userPasswordu,"activated_at".=userActivatedAtu,"suspended_at".=userSuspendedAtu,"remember_token".=userRememberTokenu,"login_count".=userLoginCountu,"failed_login_count".=userFailedLoginCountu,"locked_until".=userLockedOutUntilu,"current_login_at".=userCurrentLoginAtu,"last_login_at".=userLastLoginAtu,"current_ip".=userCurrentLoginIpu,"last_ip".=userLastLoginIpu,"created_at".=userCreatedAtu,"updated_at".=userUpdatedAtu,"roles".=userRolesu,"meta".=userMetau]------------------------------------------------------------------------------instanceFromJSONAuthUserwhereparseJSON(Objectv)=AuthUser<$>v.:"uid"<*>v.:"login"<*>v.:"pw"<*>v.:"activated_at"<*>v.:"suspended_at"<*>v.:"remember_token"<*>v.:"login_count"<*>v.:"failed_login_count"<*>v.:"locked_until"<*>v.:"current_login_at"<*>v.:"last_login_at"<*>v.:"current_ip"<*>v.:"last_ip"<*>v.:"created_at"<*>v.:"updated_at"<*>v.:?"roles".!=[]<*>v.:"meta"parseJSON_=error"Unexpected JSON input"------------------------------------------------------------------------------instanceToJSONPasswordwheretoJSON(Encryptedx)=toJSONxtoJSON(ClearText_)=error"ClearText passwords can't be serialized into JSON"------------------------------------------------------------------------------instanceFromJSONPasswordwhereparseJSON=fmapEncrypted.parseJSON------------------------------------------------------------------------------instanceToJSONRolewheretoJSON(Rolex)=toJSONx------------------------------------------------------------------------------instanceFromJSONRolewhereparseJSON=fmapRole.parseJSON