diff --git a/Yesod/Auth/HashDB.hs b/Yesod/Auth/HashDB.hs --- a/Yesod/Auth/HashDB.hs +++ b/Yesod/Auth/HashDB.hs @@ -19,8 +19,8 @@ -- Stability : Stable -- Portability : Portable -- --- A yesod-auth AuthPlugin designed to look users up in Persist where --- their user id's and a hash of their password is stored. +-- A yesod-auth AuthPlugin designed to look users up in a Persistent +-- database where their user id and a hash of their password is stored. -- -- This module was removed from @yesod-auth-1.3.0.0@ and is now -- maintained separately. @@ -71,7 +71,7 @@ -- -- > instance HashDBUser User where -- > userPasswordHash = userPassword --- > setPasswordHash h p = p { userPassword = Just h } +-- > setPasswordHash h u = u { userPassword = Just h } -- -- In the YesodAuth instance declaration for your app, include 'authHashDB' -- like so: @@ -95,7 +95,8 @@ -- > > import Crypto.PasswordStore -- > > makePassword "MyPassword" 14 -- --- where \"14\" is the default strength parameter used in this module. +-- where \"14\" is the default strength parameter ('defaultStrength') used +-- in this module. -- -- == Custom Login Form -- @@ -129,8 +130,9 @@ , defaultStrength , setPasswordStrength , setPassword + , validatePass , upgradePasswordHash - -- * Authentication + -- * Interface to database and Yesod.Auth , validateUser , authHashDB , authHashDBWithForm @@ -207,7 +209,9 @@ setSaltAndPasswordHash = setUserHashAndSalt {-# MINIMAL userPasswordHash, (setPasswordHash | (userPasswordSalt, setSaltAndPasswordHash)) #-} +{-# DEPRECATED userPasswordSalt "Compatibility with old data containing a separate salt field will be removed eventually" #-} {-# DEPRECATED setUserHashAndSalt "Please use setSaltAndPasswordHash instead" #-} +{-# DEPRECATED setSaltAndPasswordHash "Compatibility with old data containing a separate salt field will be removed eventually" #-} -- | Calculate salted hash using SHA1. Retained for compatibility with @@ -241,6 +245,42 @@ setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user setPassword = setPasswordStrength defaultStrength +-- | Validate a plaintext password against the hash in the user data structure. +-- This function retains compatibility with user data produced by old +-- versions of this module (prior to 1.3), although the hashes are less +-- secure and should be upgraded as soon as possible. They can be +-- upgraded using 'upgradePasswordHash', or by insisting that users set +-- new passwords. +-- +-- The result distinguishes two types of validation failure, which may +-- be useful in an application which supports multiple authentication +-- methods: +-- +-- * Just False - the user has a password set up, but the given one does +-- not match it +-- +-- * Nothing - the user does not have a password (the hash is Nothing) +-- +-- Since 1.4.1 +-- +validatePass :: HashDBUser u => u -> Text -> Maybe Bool +validatePass user passwd = do + hash <- userPasswordHash user + salt <- userPasswordSalt user + -- NB plaintext password characters are truncated to 8 bits here, and also + -- in saltedHash and passwordHash above (the hash and old salt are already + -- 8 bit). This is for historical compatibility, but in practice it is + -- unlikely to reduce the entropy of most users' alphabets by much. + let hash' = BS.pack $ unpack hash + passwd' = BS.pack $ unpack $ if salt == "" then passwd + else + -- Extra layer for an upgraded old hash + saltedHash salt passwd + if passwordStrength hash' > 0 + -- Will give >0 for new-style hash, else fall back + then return $ verifyPassword passwd' hash' + else return $ hash == saltedHash salt passwd + -- | Upgrade existing user credentials to a stronger hash. The existing -- hash may have been produced either by previous versions of this module, -- which used a weak algorithm, or from a weaker setting in the current @@ -280,10 +320,10 @@ ---------------------------------------------------------------- --- Authentication +-- Interface to database and Yesod.Auth ---------------------------------------------------------------- --- | Constraint for types of functions in this module +-- | Constraint for types of interface functions in this module -- type HashDBPersist master user = ( YesodAuthPersist master @@ -296,32 +336,17 @@ ) -- | Given a user ID and password in plaintext, validate them against --- the database values. This function retains compatibility with --- databases containing hashes produced by previous versions of this --- module, although they are less secure and should be upgraded as --- soon as possible. They can be upgraded using 'upgradePasswordHash', --- or by insisting that users set new passwords. +-- the database values. This function simply looks up the user id in the +-- database and calls 'validatePass' to do the work. +-- validateUser :: HashDBPersist site user => Unique user -- ^ User unique identifier -> Text -- ^ Password in plaintext -> HandlerT site IO Bool validateUser userID passwd = do - -- Checks that hash and password match - let validate u = do hash <- userPasswordHash u - salt <- userPasswordSalt u - let hash' = BS.pack $ unpack hash - passwd' = BS.pack $ unpack - $ if salt == "" then passwd - else - -- Extra layer for an upgraded old hash - saltedHash salt passwd - if passwordStrength hash' > 0 - -- Will give >0 for new-style hash, else fall back - then return $ verifyPassword passwd' hash' - else return $ hash == saltedHash salt passwd -- Get user data user <- runDB $ getBy userID - return $ fromMaybe False $ validate . entityVal =<< user + return $ fromMaybe False $ flip validatePass passwd . entityVal =<< user login :: AuthRoute diff --git a/test/ExampleData.hs b/test/ExampleData.hs new file mode 100644 --- /dev/null +++ b/test/ExampleData.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +module ExampleData ( + OldStyleUser (..), + NewStyleUser (..), + mypassword, + changedpw, + equivpassword, + equivchangedpw, + oldStyleValidUser, + oldStyleBadUser1, + oldStyleBadUser2, + newStyleValidUser, + newStyleBadUser, + stronger +) where + +import Yesod.Auth.HashDB (HashDBUser(..), defaultStrength) +import Data.Text (Text) + +data OldStyleUser = OldStyleUser { + oldStyleName :: Text, + oldStylePass :: Maybe Text, + oldStyleSalt :: Maybe Text + } deriving (Eq, Show) + +instance HashDBUser OldStyleUser where + userPasswordHash = oldStylePass + userPasswordSalt = oldStyleSalt + setSaltAndPasswordHash s h u = u { oldStyleSalt = Just s, + oldStylePass = Just h + } + +data NewStyleUser = NewStyleUser { + newStyleName :: Text, + newStylePass :: Maybe Text + } deriving (Eq, Show) + +instance HashDBUser NewStyleUser where + userPasswordHash = newStylePass + setPasswordHash h u = u { newStylePass = Just h } + +mypassword :: Text +mypassword = "mypassword" +changedpw :: Text +changedpw = "changedpw" + +-- These are equivalent to the above if each character is truncated to 8 bits +equivpassword :: Text +equivpassword = "\x46d\x479\x470\x461\x473\x473\x477\x46f\x472\x464" +equivchangedpw :: Text +equivchangedpw = "\xbc63\xbc68\xbc61\xbc6e\xbc67\xbc65\xbc64\xbc70\xbc77" + +oldStyleValidUser :: OldStyleUser +oldStyleValidUser = + OldStyleUser "foo" + (Just "8e3e33029e71b4e25ba95a00a88c4bfeb93d766a") + (Just "somesalt") + +oldStyleBadUser1 :: OldStyleUser +oldStyleBadUser1 = + OldStyleUser "bar" + Nothing + (Just "pepper") + +oldStyleBadUser2 :: OldStyleUser +oldStyleBadUser2 = + OldStyleUser "baz" + (Just "8e3e33029e71b4e25ba95a00a88c4bfeb93d766a") + Nothing + +newStyleValidUser :: NewStyleUser +newStyleValidUser = + NewStyleUser "fox" + (Just "sha256|14|2hL7cNopkA/dGy/5CQTuSg==|CUTPW6ICMISSjohFep851f9PdqIn7Y4B75/I77BvEYM=") + +newStyleBadUser :: NewStyleUser +newStyleBadUser = + NewStyleUser "bad" + Nothing + +stronger :: Int +stronger = defaultStrength + 2 diff --git a/test/NonDBTests.hs b/test/NonDBTests.hs new file mode 100644 --- /dev/null +++ b/test/NonDBTests.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE OverloadedStrings #-} +module NonDBTests ( + nonDBTests +) where + +import Test.Hspec +import Yesod.Auth.HashDB +import Data.Text (pack, isInfixOf) + +import ExampleData + + +nonDBTests :: Spec +nonDBTests = do + + describe "validatePass" $ do + + context "Old-style valid user" $ do + it "verifies OK with correct password" $ + validatePass oldStyleValidUser mypassword `shouldBe` Just True + it "fails validation with a wrong password giving Just False" $ + validatePass oldStyleValidUser changedpw `shouldBe` Just False + + context "Old-style user with no password hash" $ do + it "fails validation giving Nothing" $ + validatePass oldStyleBadUser1 mypassword `shouldBe` Nothing + + context "Old-style user with no salt" $ do + it "fails validation giving Nothing" $ + validatePass oldStyleBadUser2 mypassword `shouldBe` Nothing + + context "New style valid user" $ do + it "verifies OK with correct password" $ + validatePass newStyleValidUser mypassword `shouldBe` Just True + it "fails validation with a wrong password giving Just False" $ + validatePass newStyleValidUser changedpw `shouldBe` Just False + + context "New-style user with no password hash" $ do + it "fails validation giving Nothing" $ + validatePass newStyleBadUser mypassword `shouldBe` Nothing + + + describe "upgradePasswordHash" $ do + + context "Upgrade of old-style password hash" $ do + it "has the same salt value" $ do + newuser <- upgradePasswordHash defaultStrength oldStyleValidUser + let newsalt = newuser >>= userPasswordSalt + newsalt `shouldBe` Just "somesalt" + it "still verifies with the same password" $ do + newuser <- upgradePasswordHash defaultStrength oldStyleValidUser + let valid = newuser >>= flip validatePass mypassword + valid `shouldBe` Just True + it "still works after a second upgrade to a stronger setting" $ do + newuser <- upgradePasswordHash defaultStrength oldStyleValidUser + neweruser <- case newuser of + Just u -> upgradePasswordHash stronger u + Nothing -> return $ Just oldStyleBadUser1 -- failure + let valid = neweruser >>= flip validatePass mypassword + valid `shouldBe` Just True + it "is Nothing if there is no password hash" $ do + newuser <- upgradePasswordHash defaultStrength oldStyleBadUser1 + newuser `shouldBe` Nothing + it "is Nothing if there is no salt" $ do + newuser <- upgradePasswordHash defaultStrength oldStyleBadUser2 + newuser `shouldBe` Nothing + + context "Upgrade of new-style password hash to stronger setting" $ do + it "really does have a hash containing the new strength" $ do + newuser <- upgradePasswordHash stronger newStyleValidUser + let s = pack $ "|" ++ show stronger ++ "|" + found = fmap (s `isInfixOf`) $ newuser >>= newStylePass + found `shouldBe` Just True + it "still verifies with the same password" $ do + newuser <- upgradePasswordHash stronger newStyleValidUser + let valid = newuser >>= flip validatePass mypassword + valid `shouldBe` Just True + it "is Nothing if there is no password hash" $ do + newuser <- upgradePasswordHash stronger newStyleBadUser + newuser `shouldBe` Nothing + + + describe "setPassword" $ do + it "produces hash which verifies OK starting from old-style user" $ do + newuser <- setPassword changedpw oldStyleValidUser + validatePass newuser changedpw `shouldBe` Just True + it "produces empty salt (in the case of old-style user)" $ do + newuser <- setPassword changedpw oldStyleValidUser + userPasswordSalt newuser `shouldBe` Just "" + it "produces hash which verifies OK starting from new-style user" $ do + newuser <- setPassword changedpw newStyleValidUser + validatePass newuser changedpw `shouldBe` Just True + + + describe "Only the bottom 8 bits of password characters are used" $ do + it "when verifying old-style password hash" $ + validatePass oldStyleValidUser equivpassword `shouldBe` Just True + it "when verifying new-style password hash" $ + validatePass newStyleValidUser equivpassword `shouldBe` Just True + it "when setting a new password" $ do + newuser <- setPassword equivchangedpw oldStyleValidUser + validatePass newuser changedpw `shouldBe` Just True diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +import Test.Hspec + +import NonDBTests + +main :: IO () +main = hspec nonDBTests diff --git a/yesod-auth-hashdb.cabal b/yesod-auth-hashdb.cabal --- a/yesod-auth-hashdb.cabal +++ b/yesod-auth-hashdb.cabal @@ -1,5 +1,5 @@ name: yesod-auth-hashdb -version: 1.4.0 +version: 1.4.1 license: MIT license-file: LICENSE author: Patrick Brisbin, later changes Paul Rouse @@ -7,9 +7,10 @@ synopsis: Authentication plugin for Yesod. category: Web, Yesod stability: Stable -cabal-version: >= 1.6.0 +cabal-version: >= 1.8.0 build-type: Simple -homepage: http://www.yesodweb.com/ +homepage: https://github.com/paul-rouse/yesod-auth-hashdb +bug-reports: https://github.com/paul-rouse/yesod-auth-hashdb/issues description: This package is the Yesod.Auth.HashDB plugin, originally included in yesod-auth, but now modified to be more secure and placed in a separate package. library @@ -26,6 +27,18 @@ exposed-modules: Yesod.Auth.HashDB ghc-options: -Wall + +test-suite test + type: exitcode-stdio-1.0 + main-is: main.hs + hs-source-dirs: test + ghc-options: -Wall + other-modules: ExampleData + NonDBTests + build-depends: base >= 4 && < 5 + , yesod-auth-hashdb + , hspec + , text source-repository head type: git