diff --git a/src/Snap/Snaplet/Auth.hs b/src/Snap/Snaplet/Auth.hs index 69a37851..19833449 100644 --- a/src/Snap/Snaplet/Auth.hs +++ b/src/Snap/Snaplet/Auth.hs @@ -60,6 +60,8 @@ module Snap.Snaplet.Auth , loginUser , logoutUser , requireUser + , setPasswordResetToken + , clearPasswordResetToken -- * Splice helpers , addAuthSplices diff --git a/src/Snap/Snaplet/Auth/Handlers.hs b/src/Snap/Snaplet/Auth/Handlers.hs index 236ace27..2d1ab5de 100644 --- a/src/Snap/Snaplet/Auth/Handlers.hs +++ b/src/Snap/Snaplet/Auth/Handlers.hs @@ -496,3 +496,45 @@ withBackend :: withBackend f = join $ do (AuthManager backend_ _ _ _ _ _ _ _ _) <- get return $ f backend_ + + +------------------------------------------------------------------------------ +-- | 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 -> Handler b (AuthManager b) Bool +setPasswordResetToken login = do + token <- liftIO . randomToken 40 =<< gets randomNumberGenerator + now <- liftIO getCurrentTime + modPasswordResetToken login (Just $ decodeUtf8 token) (Just now) + + +------------------------------------------------------------------------------ +-- | 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 -> Handler b (AuthManager b) Bool +clearPasswordResetToken login = modPasswordResetToken login Nothing Nothing + + +------------------------------------------------------------------------------ +-- | Helper function used for setting and clearing the password reset token +-- and associated timestamp. +modPasswordResetToken :: Text + -> Maybe Text + -> Maybe UTCTime + -> Handler v (AuthManager v) Bool +modPasswordResetToken login token timestamp = do + res <- runMaybeT $ do + u <- MaybeT $ withBackend $ \b -> liftIO $ lookupByLogin b login + lift $ saveUser $ u + { userResetToken = token + , userResetRequestedAt = timestamp + } + return () + return $ maybe False (\_ -> True) res + + + diff --git a/src/Snap/Snaplet/Auth/Types.hs b/src/Snap/Snaplet/Auth/Types.hs index c81c1fb3..c4c0630a 100644 --- a/src/Snap/Snaplet/Auth/Types.hs +++ b/src/Snap/Snaplet/Auth/Types.hs @@ -9,6 +9,7 @@ module Snap.Snaplet.Auth.Types where import Control.Applicative import Control.Arrow import Control.Monad.Trans +import Control.Monad.Trans.Maybe import Crypto.PasswordStore import Data.Aeson import Data.ByteString (ByteString) @@ -20,6 +21,7 @@ import Data.Time import Data.Text (Text) import Data.Typeable import Snap.Snaplet +import Snap.Snaplet.Session.Common ------------------------------------------------------------------------------ @@ -120,6 +122,10 @@ data Role = Role ByteString data AuthUser = AuthUser { userId :: Maybe UserId , userLogin :: Text + + -- We have to have an email field for password reset functionality, but we + -- don't want to force users to log in with their email address. + , userEmail :: Maybe Text , userPassword :: Maybe Password , userActivatedAt :: Maybe UTCTime , userSuspendedAt :: Maybe UTCTime @@ -133,6 +139,8 @@ data AuthUser = AuthUser , userLastLoginIp :: Maybe ByteString , userCreatedAt :: Maybe UTCTime , userUpdatedAt :: Maybe UTCTime + , userResetToken :: Maybe Text + , userResetRequestedAt :: Maybe UTCTime , userRoles :: [Role] , userMeta :: HashMap Text Value } @@ -145,6 +153,7 @@ defAuthUser :: AuthUser defAuthUser = AuthUser { userId = Nothing , userLogin = "" + , userEmail = Nothing , userPassword = Nothing , userActivatedAt = Nothing , userSuspendedAt = Nothing @@ -158,6 +167,8 @@ defAuthUser = AuthUser , userLastLoginIp = Nothing , userCreatedAt = Nothing , userUpdatedAt = Nothing + , userResetToken = Nothing + , userResetRequestedAt = Nothing , userRoles = [] , userMeta = HM.empty } @@ -249,6 +260,7 @@ instance ToJSON AuthUser where toJSON u = object [ "uid" .= userId u , "login" .= userLogin u + , "email" .= userEmail u , "pw" .= userPassword u , "activated_at" .= userActivatedAt u , "suspended_at" .= userSuspendedAt u @@ -262,6 +274,8 @@ instance ToJSON AuthUser where , "last_ip" .= userLastLoginIp u , "created_at" .= userCreatedAt u , "updated_at" .= userUpdatedAt u + , "reset_token" .= userResetToken u + , "reset_requested_at" .= userResetRequestedAt u , "roles" .= userRoles u , "meta" .= userMeta u ] @@ -272,6 +286,7 @@ instance FromJSON AuthUser where parseJSON (Object v) = AuthUser <$> v .: "uid" <*> v .: "login" + <*> v .: "email" <*> v .: "pw" <*> v .: "activated_at" <*> v .: "suspended_at" @@ -285,6 +300,8 @@ instance FromJSON AuthUser where <*> v .: "last_ip" <*> v .: "created_at" <*> v .: "updated_at" + <*> v .: "reset_token" + <*> v .: "reset_requested_at" <*> v .:? "roles" .!= [] <*> v .: "meta" parseJSON _ = error "Unexpected JSON input"