From f7b467c8ee442383e4b6467d28e7dbab540471af Mon Sep 17 00:00:00 2001 From: Joe Wang Date: Tue, 23 Nov 2021 22:38:16 +0800 Subject: [PATCH] Remove salt and use Bcrypt for password hash --- .vscode/settings.json | 11 +++++----- package.yaml | 1 + sql/001.initial.sql | 3 +-- src/Conduit/Api/Auth.hs | 3 ++- src/Conduit/App.hs | 9 +++++---- src/Conduit/Core/Password.hs | 36 +++++++++++++++++---------------- src/Conduit/Db/Schema/User.hs | 20 ++++++++---------- src/Conduit/Db/Transaction.hs | 5 +++-- src/Conduit/Environment.hs | 18 +++++++++++++++++ src/Conduit/Repository/User.hs | 2 +- src/Conduit/Util.hs | 11 +++++++--- test/Test/Conduit/TestHelper.hs | 6 ++---- 12 files changed, 74 insertions(+), 51 deletions(-) create mode 100644 src/Conduit/Environment.hs diff --git a/.vscode/settings.json b/.vscode/settings.json index 285365b..4ce8960 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -1,22 +1,23 @@ { "cSpell.words": [ - "Favorited", - "Followship", - "Postgres", - "Qiao", - "Serializable", "aeson", "anyclass", + "bcrypt", "bytestring", "cryptonite", "dhall", + "Favorited", "fmap", + "Followship", "hasql", "hspec", "mconcat", "nodew", + "Postgres", + "Qiao", "realworld", "rtsopts", + "Serializable", "uncurry", "unfollow", "varchar" diff --git a/package.yaml b/package.yaml index f412128..e8a5c60 100644 --- a/package.yaml +++ b/package.yaml @@ -33,6 +33,7 @@ dependencies: - lens - jose - cryptonite +- memory - mtl - transformers - dhall diff --git a/sql/001.initial.sql b/sql/001.initial.sql index b22751c..867d85d 100644 --- a/sql/001.initial.sql +++ b/sql/001.initial.sql @@ -4,8 +4,7 @@ CREATE TABLE IF NOT EXISTS users ( user_id SERIAL PRIMARY KEY , user_email VARCHAR(64) UNIQUE NOT NULL , user_username VARCHAR(64) UNIQUE NOT NULL - , user_password VARCHAR(64) NOT NULL - , user_salt VARCHAR(64) NOT NULL + , user_password VARCHAR(60) NOT NULL , user_bio TEXT , user_image TEXT , user_createdAt TIMESTAMP DEFAULT CURRENT_TIMESTAMP diff --git a/src/Conduit/Api/Auth.hs b/src/Conduit/Api/Auth.hs index ea0065a..4bea46e 100644 --- a/src/Conduit/Api/Auth.hs +++ b/src/Conduit/Api/Auth.hs @@ -15,6 +15,7 @@ import Conduit.Core.Password import Conduit.Core.User import Conduit.JWT import Conduit.Util +import Conduit.Environment data LoginUser = LoginUser { loginEmail :: Text @@ -90,7 +91,7 @@ registerHandler (UserData u) = genUserResponse :: User -> AppM LoginResponse genUserResponse user = do let username = userName user - jwtKey <- getJwtKey + jwtKey <- getJwtKey' claims <- liftIO $ mkClaims username liftIO $ signJwt jwtKey claims >>= either (\_ -> throwIO err422) (return . mapUserToLoginResponse user) diff --git a/src/Conduit/App.hs b/src/Conduit/App.hs index fea26ba..f737053 100644 --- a/src/Conduit/App.hs +++ b/src/Conduit/App.hs @@ -13,6 +13,7 @@ import Hasql.Pool (Pool) import Crypto.JOSE.JWK ( JWK ) import Control.Monad.Trans.Except ( ExceptT(ExceptT) ) import qualified Servant +import Conduit.Environment data AppEnv = AppEnv { envDbPool :: Pool @@ -24,8 +25,8 @@ type AppM = RIO AppEnv runHandler ∷ AppEnv → AppM a → Servant.Handler a runHandler env app = Servant.Handler $ ExceptT $ try $ runRIO env app -getDbPool :: AppM Pool -getDbPool = ask <&> envDbPool +instance HasDbPool AppEnv where + getDbPool = envDbPool -getJwtKey :: AppM JWK -getJwtKey = ask <&> envJwtKey +instance HasJwtKey AppEnv where + getJwtKey = envJwtKey diff --git a/src/Conduit/Core/Password.hs b/src/Conduit/Core/Password.hs index 595b3fc..28f5e05 100644 --- a/src/Conduit/Core/Password.hs +++ b/src/Conduit/Core/Password.hs @@ -7,10 +7,12 @@ import Rel8 ( DBEq, DBType ) import Data.Aeson ( FromJSON, ToJSON ) import Crypto.Random ( MonadRandom(getRandomBytes) ) import Crypto.Hash ( hashWith, SHA256(SHA256) ) +import Crypto.KDF.BCrypt as Bcrypt (bcrypt, validatePassword) import qualified Data.Text as T +import Data.ByteArray (Bytes, convert) +import Conduit.Util (fromTextToBytes, fromBytesToText) -newtype Salt = Salt { getSalt :: Text } - deriving newtype (Eq, Show, Read, DBEq, DBType) +newtype Salt = Salt Bytes newtype HashedPassword = HashedPassword { getHashedPasswd :: Text } deriving newtype (Eq, Show, Read, DBEq, DBType) @@ -18,24 +20,24 @@ newtype HashedPassword = HashedPassword { getHashedPasswd :: Text } newtype Password = Password { getPassword :: Text } deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType) +unsafePassword :: Text -> Password +unsafePassword = Password + +mkPassword :: Text -> Maybe Password +mkPassword rawText = + if T.length rawText <= 6 then Nothing + else Just $ Password rawText + newSalt :: MonadIO m => m Salt -newSalt = do - rnd <- liftIO $ getRandomBytes 32 - return $ Salt $ T.pack $ show $ hashWith SHA256 (rnd :: ByteString) +newSalt = liftIO $ Salt <$> getRandomBytes 16 hashPasswordWithSalt :: Password -> Salt -> HashedPassword hashPasswordWithSalt (Password password) (Salt salt) = - let _salt = hashWith SHA256 (encodeUtf8 salt) - _password = hashWith SHA256 _salt - in HashedPassword $ T.pack $ show _password + let hash = Bcrypt.bcrypt 10 salt (fromTextToBytes password) + in HashedPassword $ fromBytesToText hash -hashPassword :: MonadIO m => Password -> m (HashedPassword, Salt) -hashPassword password = do - salt <- newSalt - let hash = hashPasswordWithSalt password salt - return (hash, salt) +hashPassword :: MonadIO m => Password -> m HashedPassword +hashPassword password = hashPasswordWithSalt password <$> newSalt -verifyPassword :: Password -> Salt -> HashedPassword -> Bool -verifyPassword password salt hash = - let _hash = hashPasswordWithSalt password salt - in hash == _hash +verifyPassword :: Password -> HashedPassword -> Bool +verifyPassword (Password password) (HashedPassword hash) = Bcrypt.validatePassword (fromTextToBytes password) (fromTextToBytes hash) diff --git a/src/Conduit/Db/Schema/User.hs b/src/Conduit/Db/Schema/User.hs index cf73194..7f978e4 100644 --- a/src/Conduit/Db/Schema/User.hs +++ b/src/Conduit/Db/Schema/User.hs @@ -20,7 +20,6 @@ data UserEntity f = UserEntity , entityUserName :: Column f Username , entityUserEmail :: Column f EmailAddress , entityUserPassword :: Column f HashedPassword - , entityUserSalt :: Column f Salt , entityUserBio :: Column f Text , entityUserImage :: Column f Text } @@ -38,7 +37,6 @@ userSchema = TableSchema , entityUserName = "user_username" , entityUserEmail = "user_email" , entityUserPassword = "user_password" - , entityUserSalt = "user_salt" , entityUserBio = "user_bio" , entityUserImage = "user_image" } @@ -61,11 +59,10 @@ updateUserProperties user expr = expr , entityUserImage = lit (userImage user) } -updatePasswordAndSalt :: (HashedPassword, Salt) -> UserEntity Expr -> UserEntity Expr -updatePasswordAndSalt (hash, salt) expr = expr - { entityUserSalt = lit salt - , entityUserPassword = lit hash - } +updatePassword :: HashedPassword -> UserEntity Expr -> UserEntity Expr +updatePassword hash expr = expr + { entityUserPassword = lit hash + } getUserByIdStmt :: Expr UserId -> Query (UserEntity Expr) getUserByIdStmt uid = do @@ -85,8 +82,8 @@ getUserByEmailStmt email = do where_ $ entityUserEmail a ==. lit email return a -insertUserStmt :: User -> (HashedPassword, Salt) -> Insert [UserId] -insertUserStmt user (hash, salt) = Insert +insertUserStmt :: User -> HashedPassword -> Insert [UserId] +insertUserStmt user hash = Insert { into = userSchema , rows = values [ UserEntity { entityUserId = unsafeCastExpr $ nextval "users_user_id_seq" @@ -95,14 +92,13 @@ insertUserStmt user (hash, salt) = Insert , entityUserBio = lit (userBio user) , entityUserImage = lit (userImage user) , entityUserPassword = lit hash - , entityUserSalt = lit salt } ] , onConflict = DoNothing , returning = Projection entityUserId } -updateUserStmt :: User -> Maybe (HashedPassword, Salt) -> Update Int64 +updateUserStmt :: User -> Maybe HashedPassword -> Update Int64 updateUserStmt user mbPassword = Update { target = userSchema @@ -113,5 +109,5 @@ updateUserStmt user mbPassword = } where setter _ = case mbPassword of - Just password -> updatePasswordAndSalt password . updateUserProperties user + Just password -> updatePassword password . updateUserProperties user _ -> updateUserProperties user diff --git a/src/Conduit/Db/Transaction.hs b/src/Conduit/Db/Transaction.hs index d152f89..c044325 100644 --- a/src/Conduit/Db/Transaction.hs +++ b/src/Conduit/Db/Transaction.hs @@ -13,6 +13,7 @@ import Hasql.Statement (Statement) import Conduit.Config import Conduit.App +import Conduit.Environment loadPool :: DbConfig -> IO Pool loadPool cfg = acquire (poolSize, 1, postgresSettings) @@ -36,9 +37,9 @@ runTransactionWithPool pool transaction = do runStmt :: Statement () a -> Transaction a runStmt = statement () -runTransaction :: forall a . Transaction a -> AppM a +runTransaction :: forall a m env . (HasDbPool env, MonadReader env m, MonadIO m) => Transaction a -> m a runTransaction transaction = do - pool <- getDbPool + pool <- getDbPool' runTransactionWithPool pool transaction executeStmt :: Statement () a -> AppM a diff --git a/src/Conduit/Environment.hs b/src/Conduit/Environment.hs new file mode 100644 index 0000000..7c5a562 --- /dev/null +++ b/src/Conduit/Environment.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE RankNTypes #-} +module Conduit.Environment where + +import Hasql.Pool (Pool) +import Crypto.JOSE (JWK) +import RIO (MonadReader, ask, (<&>)) + +class HasDbPool env where + getDbPool :: env -> Pool + +class HasJwtKey env where + getJwtKey :: env -> JWK + +getDbPool' :: (HasDbPool env, MonadReader env m) => m Pool +getDbPool' = ask <&> getDbPool + +getJwtKey' :: (HasJwtKey env, MonadReader env m) => m JWK +getJwtKey' = ask <&> getJwtKey diff --git a/src/Conduit/Repository/User.hs b/src/Conduit/Repository/User.hs index dce8cf2..9129cde 100644 --- a/src/Conduit/Repository/User.hs +++ b/src/Conduit/Repository/User.hs @@ -32,7 +32,7 @@ getUserByEmailAndPassword email password = do return $ verifyPassword' =<< listToMaybe users where verifyPassword' user = - if verifyPassword password (entityUserSalt user) (entityUserPassword user) + if verifyPassword password (entityUserPassword user) then Just $ mapUserEntityToUser user else diff --git a/src/Conduit/Util.hs b/src/Conduit/Util.hs index 429d920..95f7318 100644 --- a/src/Conduit/Util.hs +++ b/src/Conduit/Util.hs @@ -8,6 +8,8 @@ import Data.List ( head, tail ) import Data.Char ( toLower ) import Data.UUID import System.Random +import Data.ByteArray (Bytes, convert) +import Data.Text.Encoding (decodeUtf8) toJsonOptions :: Int -> Options toJsonOptions prefixLength = @@ -22,8 +24,11 @@ hoistMaybe = MaybeT . return newUUID :: IO UUID newUUID = randomIO --- whenJust :: Monad m => Maybe t -> (t -> m (Maybe a)) -> m (Maybe a) --- whenJust mb f = maybe (return Nothing) f mb - flipMaybe :: Maybe a -> b -> (a -> b) -> b flipMaybe mb error f = maybe error f mb + +fromTextToBytes :: Text -> Bytes +fromTextToBytes = convert . encodeUtf8 + +fromBytesToText :: Bytes -> Text +fromBytesToText = decodeUtf8 . convert diff --git a/test/Test/Conduit/TestHelper.hs b/test/Test/Conduit/TestHelper.hs index 41c2edd..ad36d06 100644 --- a/test/Test/Conduit/TestHelper.hs +++ b/test/Test/Conduit/TestHelper.hs @@ -71,18 +71,16 @@ setupTestUser :: Text -> IO () setupTestUser username = do let email = T.append username "@test.com" let password = Password $ T.append username "password" - (hash, salt) <- hashPassword password + hash <- hashPassword password setupSeedData $ sql $ mconcat - [ "INSERT INTO users (user_email, user_username, user_password, user_salt, user_bio, user_image)" + [ "INSERT INTO users (user_email, user_username, user_password, user_bio, user_image)" , "VALUES ('" , T.encodeUtf8 email , "', '" , T.encodeUtf8 username , "', '" , T.encodeUtf8 . getHashedPasswd $ hash - , "', '" - , T.encodeUtf8 . getSalt $ salt , "', ''" , ", '');" ]