Merge pull request #1446 from bigs/extensible-password-hashing

Extend `YesodAuthEmail` to support extensible password hashing

yesod-auth/ChangeLog.md

@@ -1,3 +1,8 @@
+## 1.4.20
+
+* Extend `YesodAuthEmail` to support extensible password hashing via
+  `hashAndSaltPassword` and `verifyPassword` functions
+
 ## 1.4.19
 
 * Adjust English localization to distinguish between "log in" (verb) and "login" (noun)

yesod-auth/Yesod/Auth/Email.hs

@@ -4,7 +4,7 @@
 {-# LANGUAGE PatternGuards           #-}
 {-# LANGUAGE QuasiQuotes             #-}
 {-# LANGUAGE Rank2Types              #-}
-{-# LANGUAGE ScopedTypeVariables#-}
+{-# LANGUAGE ScopedTypeVariables     #-}
 {-# LANGUAGE TypeFamilies            #-}
 -- | A Yesod plugin for Authentication via e-mail
 --
@@ -132,7 +132,7 @@ import           Safe                     (readMay)
 import           System.IO.Unsafe         (unsafePerformIO)
 import qualified Text.Email.Validate
 import           Data.Aeson.Types (Parser, Result(..), parseMaybe, withObject, (.:?))
-import           Data.Maybe (isJust, isNothing, fromJust)
+import           Data.Maybe (isJust)
 import Data.ByteArray (convert)
 
 loginR, registerR, forgotPasswordR, setpassR :: AuthRoute
@@ -203,6 +203,22 @@ class ( YesodAuth site
     -- @since 1.1.0
     setVerifyKey :: AuthEmailId site -> VerKey -> HandlerT site IO ()
 
+    -- | Hash and salt a password
+    --
+    -- Default: 'saltPass'.
+    --
+    -- @since 1.4.20
+    hashAndSaltPassword :: Text -> HandlerT site IO SaltedPass
+    hashAndSaltPassword = liftIO . saltPass
+
+    -- | Verify a password matches the stored password for the given account.
+    --
+    -- Default: Fetch a password with 'getPassword' and match using 'Yesod.Auth.Util.PasswordStore.verifyPassword'.
+    --
+    -- @since 1.4.20
+    verifyPassword :: Text -> SaltedPass -> HandlerT site IO Bool
+    verifyPassword plain salted = return $ isValidPass plain salted
+
     -- | Verify the email address on the given account.
     --
     -- __/Warning!/__ If you have persisted the @'AuthEmailId' site@
@@ -620,12 +636,14 @@ postLoginR = do
                    , emailCredsStatus <$> mecreds
                    ) of
                 (Just aid, Just email', Just True) -> do
-                       mrealpass <- lift $ getPassword aid
+                      mrealpass <- lift $ getPassword aid
-                       case mrealpass of
+                      case mrealpass of
-                         Nothing -> return Nothing
+                        Nothing -> return Nothing
-                         Just realpass -> return $ if isValidPass pass realpass
+                        Just realpass -> do
-                                                   then Just email'
+                            passValid <- lift $ verifyPassword pass realpass 
-                                                   else Nothing
+                            return $ if passValid
+                                    then Just email'
+                                    else Nothing
                 _ -> return Nothing
           let isEmail = Text.Email.Validate.isValid $ encodeUtf8 identifier
           case maid of
@@ -753,14 +771,16 @@ postPasswordR = do
                               then getThird jcreds
                               else fcurrent
                 mrealpass <- lift $ getPassword aid
-                case mrealpass of
+                case (mrealpass, current) of
-                    Nothing ->
+                    (Nothing, _) ->
                         lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
-                    Just realpass
+                    (_, Nothing) ->
-                        | isNothing current -> loginErrorMessageI LoginR Msg.BadSetPass
+                        loginErrorMessageI LoginR Msg.BadSetPass
-                        | isValidPass (fromJust current) realpass -> confirmPassword aid tm jcreds
+                    (Just realpass, Just current') -> do
-                        | otherwise ->
+                        passValid <- lift $ verifyPassword current' realpass
-                            lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
+                        if passValid
+                          then confirmPassword aid tm jcreds
+                          else lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
 
   where
     msgOk = Msg.PassUpdated
@@ -787,7 +807,7 @@ postPasswordR = do
                 case isSecure of
                   Left e -> lift $ loginErrorMessage (tm setpassR) e
                   Right () -> do
-                     salted <- liftIO $ saltPass new
+                     salted <- lift $ hashAndSaltPassword new
                      y <- lift $ do
                                 setPassword aid salted
                                 deleteSession loginLinkKey

yesod-auth/yesod-auth.cabal

@@ -1,5 +1,5 @@
 name:            yesod-auth
-version:         1.4.19
+version:         1.4.20
 license:         MIT
 license-file:    LICENSE
 author:          Michael Snoyman, Patrick Brisbin