Remove salt and use Bcrypt for password hash

.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"

package.yaml

@@ -33,6 +33,7 @@ dependencies:
 - lens
 - jose
 - cryptonite
+- memory
 - mtl
 - transformers
 - dhall

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

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)

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

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)

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

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

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

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

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

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
             , "', ''"
             , ", '');"
             ]