From 600d3073105197189661e25a1722289196a64b06 Mon Sep 17 00:00:00 2001
From: Cole Brown <bigswim@gmail.com>
Date: Thu, 21 Sep 2017 16:02:18 -0400
Subject: [PATCH] Extend `YesodAuthEmail` to support extensible password
 hashing.

This change introduces `hashAndSaltPassword` and `verifyPassword` to the
`YesodAuthEmail` type class, allowing users to implement their own hashing
schemes (i.e. to provide compatibility with an existing database). It also
updates the default handlers to use these new functions when appropriate. The
functions have default implementation such that behavior for legacy applications
should not change.
---
 yesod-auth/ChangeLog.md        |  5 ++++
 yesod-auth/Yesod/Auth/Email.hs | 52 +++++++++++++++++++++++-----------
 yesod-auth/yesod-auth.cabal    |  2 +-
 3 files changed, 42 insertions(+), 17 deletions(-)

diff --git a/yesod-auth/ChangeLog.md b/yesod-auth/ChangeLog.md
index e661abc7..f978cf10 100644
--- a/yesod-auth/ChangeLog.md
+++ b/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)
diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs
index 44990a8e..51cbea7c 100644
--- a/yesod-auth/Yesod/Auth/Email.hs
+++ b/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
-                       case mrealpass of
-                         Nothing -> return Nothing
-                         Just realpass -> return $ if isValidPass pass realpass
-                                                   then Just email'
-                                                   else Nothing
+                      mrealpass <- lift $ getPassword aid
+                      case mrealpass of
+                        Nothing -> return Nothing
+                        Just realpass -> do
+                            passValid <- lift $ verifyPassword pass realpass 
+                            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
-                    Nothing ->
+                case (mrealpass, current) of
+                    (Nothing, _) ->
                         lift $ loginErrorMessage (tm setpassR) "You do not currently have a password set on your account"
-                    Just realpass
-                        | isNothing current -> loginErrorMessageI LoginR Msg.BadSetPass
-                        | isValidPass (fromJust current) realpass -> confirmPassword aid tm jcreds
-                        | otherwise ->
-                            lift $ loginErrorMessage (tm setpassR) "Invalid current password, please try again"
+                    (_, Nothing) ->
+                        loginErrorMessageI LoginR Msg.BadSetPass
+                    (Just realpass, Just current') -> do
+                        passValid <- lift $ verifyPassword current' realpass
+                        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
diff --git a/yesod-auth/yesod-auth.cabal b/yesod-auth/yesod-auth.cabal
index 4d406329..196c2df9 100644
--- a/yesod-auth/yesod-auth.cabal
+++ b/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