mirror of
https://github.com/nodew/haskell-realworld-example.git
synced 2024-08-16 20:20:23 +03:00
Remove salt and use Bcrypt for password hash
This commit is contained in:
parent
42c46c8a70
commit
f7b467c8ee
11
.vscode/settings.json
vendored
11
.vscode/settings.json
vendored
@ -1,22 +1,23 @@
|
|||||||
{
|
{
|
||||||
"cSpell.words": [
|
"cSpell.words": [
|
||||||
"Favorited",
|
|
||||||
"Followship",
|
|
||||||
"Postgres",
|
|
||||||
"Qiao",
|
|
||||||
"Serializable",
|
|
||||||
"aeson",
|
"aeson",
|
||||||
"anyclass",
|
"anyclass",
|
||||||
|
"bcrypt",
|
||||||
"bytestring",
|
"bytestring",
|
||||||
"cryptonite",
|
"cryptonite",
|
||||||
"dhall",
|
"dhall",
|
||||||
|
"Favorited",
|
||||||
"fmap",
|
"fmap",
|
||||||
|
"Followship",
|
||||||
"hasql",
|
"hasql",
|
||||||
"hspec",
|
"hspec",
|
||||||
"mconcat",
|
"mconcat",
|
||||||
"nodew",
|
"nodew",
|
||||||
|
"Postgres",
|
||||||
|
"Qiao",
|
||||||
"realworld",
|
"realworld",
|
||||||
"rtsopts",
|
"rtsopts",
|
||||||
|
"Serializable",
|
||||||
"uncurry",
|
"uncurry",
|
||||||
"unfollow",
|
"unfollow",
|
||||||
"varchar"
|
"varchar"
|
||||||
|
@ -33,6 +33,7 @@ dependencies:
|
|||||||
- lens
|
- lens
|
||||||
- jose
|
- jose
|
||||||
- cryptonite
|
- cryptonite
|
||||||
|
- memory
|
||||||
- mtl
|
- mtl
|
||||||
- transformers
|
- transformers
|
||||||
- dhall
|
- dhall
|
||||||
|
@ -4,8 +4,7 @@ CREATE TABLE IF NOT EXISTS users (
|
|||||||
user_id SERIAL PRIMARY KEY
|
user_id SERIAL PRIMARY KEY
|
||||||
, user_email VARCHAR(64) UNIQUE NOT NULL
|
, user_email VARCHAR(64) UNIQUE NOT NULL
|
||||||
, user_username VARCHAR(64) UNIQUE NOT NULL
|
, user_username VARCHAR(64) UNIQUE NOT NULL
|
||||||
, user_password VARCHAR(64) NOT NULL
|
, user_password VARCHAR(60) NOT NULL
|
||||||
, user_salt VARCHAR(64) NOT NULL
|
|
||||||
, user_bio TEXT
|
, user_bio TEXT
|
||||||
, user_image TEXT
|
, user_image TEXT
|
||||||
, user_createdAt TIMESTAMP DEFAULT CURRENT_TIMESTAMP
|
, user_createdAt TIMESTAMP DEFAULT CURRENT_TIMESTAMP
|
||||||
|
@ -15,6 +15,7 @@ import Conduit.Core.Password
|
|||||||
import Conduit.Core.User
|
import Conduit.Core.User
|
||||||
import Conduit.JWT
|
import Conduit.JWT
|
||||||
import Conduit.Util
|
import Conduit.Util
|
||||||
|
import Conduit.Environment
|
||||||
|
|
||||||
data LoginUser = LoginUser
|
data LoginUser = LoginUser
|
||||||
{ loginEmail :: Text
|
{ loginEmail :: Text
|
||||||
@ -90,7 +91,7 @@ registerHandler (UserData u) =
|
|||||||
genUserResponse :: User -> AppM LoginResponse
|
genUserResponse :: User -> AppM LoginResponse
|
||||||
genUserResponse user = do
|
genUserResponse user = do
|
||||||
let username = userName user
|
let username = userName user
|
||||||
jwtKey <- getJwtKey
|
jwtKey <- getJwtKey'
|
||||||
claims <- liftIO $ mkClaims username
|
claims <- liftIO $ mkClaims username
|
||||||
liftIO $ signJwt jwtKey claims
|
liftIO $ signJwt jwtKey claims
|
||||||
>>= either (\_ -> throwIO err422) (return . mapUserToLoginResponse user)
|
>>= either (\_ -> throwIO err422) (return . mapUserToLoginResponse user)
|
||||||
|
@ -13,6 +13,7 @@ import Hasql.Pool (Pool)
|
|||||||
import Crypto.JOSE.JWK ( JWK )
|
import Crypto.JOSE.JWK ( JWK )
|
||||||
import Control.Monad.Trans.Except ( ExceptT(ExceptT) )
|
import Control.Monad.Trans.Except ( ExceptT(ExceptT) )
|
||||||
import qualified Servant
|
import qualified Servant
|
||||||
|
import Conduit.Environment
|
||||||
|
|
||||||
data AppEnv = AppEnv
|
data AppEnv = AppEnv
|
||||||
{ envDbPool :: Pool
|
{ envDbPool :: Pool
|
||||||
@ -24,8 +25,8 @@ type AppM = RIO AppEnv
|
|||||||
runHandler ∷ AppEnv → AppM a → Servant.Handler a
|
runHandler ∷ AppEnv → AppM a → Servant.Handler a
|
||||||
runHandler env app = Servant.Handler $ ExceptT $ try $ runRIO env app
|
runHandler env app = Servant.Handler $ ExceptT $ try $ runRIO env app
|
||||||
|
|
||||||
getDbPool :: AppM Pool
|
instance HasDbPool AppEnv where
|
||||||
getDbPool = ask <&> envDbPool
|
getDbPool = envDbPool
|
||||||
|
|
||||||
getJwtKey :: AppM JWK
|
instance HasJwtKey AppEnv where
|
||||||
getJwtKey = ask <&> envJwtKey
|
getJwtKey = envJwtKey
|
||||||
|
@ -7,10 +7,12 @@ import Rel8 ( DBEq, DBType )
|
|||||||
import Data.Aeson ( FromJSON, ToJSON )
|
import Data.Aeson ( FromJSON, ToJSON )
|
||||||
import Crypto.Random ( MonadRandom(getRandomBytes) )
|
import Crypto.Random ( MonadRandom(getRandomBytes) )
|
||||||
import Crypto.Hash ( hashWith, SHA256(SHA256) )
|
import Crypto.Hash ( hashWith, SHA256(SHA256) )
|
||||||
|
import Crypto.KDF.BCrypt as Bcrypt (bcrypt, validatePassword)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
|
import Data.ByteArray (Bytes, convert)
|
||||||
|
import Conduit.Util (fromTextToBytes, fromBytesToText)
|
||||||
|
|
||||||
newtype Salt = Salt { getSalt :: Text }
|
newtype Salt = Salt Bytes
|
||||||
deriving newtype (Eq, Show, Read, DBEq, DBType)
|
|
||||||
|
|
||||||
newtype HashedPassword = HashedPassword { getHashedPasswd :: Text }
|
newtype HashedPassword = HashedPassword { getHashedPasswd :: Text }
|
||||||
deriving newtype (Eq, Show, Read, DBEq, DBType)
|
deriving newtype (Eq, Show, Read, DBEq, DBType)
|
||||||
@ -18,24 +20,24 @@ newtype HashedPassword = HashedPassword { getHashedPasswd :: Text }
|
|||||||
newtype Password = Password { getPassword :: Text }
|
newtype Password = Password { getPassword :: Text }
|
||||||
deriving newtype (Eq, Show, Read, FromJSON, ToJSON, DBEq, DBType)
|
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 :: MonadIO m => m Salt
|
||||||
newSalt = do
|
newSalt = liftIO $ Salt <$> getRandomBytes 16
|
||||||
rnd <- liftIO $ getRandomBytes 32
|
|
||||||
return $ Salt $ T.pack $ show $ hashWith SHA256 (rnd :: ByteString)
|
|
||||||
|
|
||||||
hashPasswordWithSalt :: Password -> Salt -> HashedPassword
|
hashPasswordWithSalt :: Password -> Salt -> HashedPassword
|
||||||
hashPasswordWithSalt (Password password) (Salt salt) =
|
hashPasswordWithSalt (Password password) (Salt salt) =
|
||||||
let _salt = hashWith SHA256 (encodeUtf8 salt)
|
let hash = Bcrypt.bcrypt 10 salt (fromTextToBytes password)
|
||||||
_password = hashWith SHA256 _salt
|
in HashedPassword $ fromBytesToText hash
|
||||||
in HashedPassword $ T.pack $ show _password
|
|
||||||
|
|
||||||
hashPassword :: MonadIO m => Password -> m (HashedPassword, Salt)
|
hashPassword :: MonadIO m => Password -> m HashedPassword
|
||||||
hashPassword password = do
|
hashPassword password = hashPasswordWithSalt password <$> newSalt
|
||||||
salt <- newSalt
|
|
||||||
let hash = hashPasswordWithSalt password salt
|
|
||||||
return (hash, salt)
|
|
||||||
|
|
||||||
verifyPassword :: Password -> Salt -> HashedPassword -> Bool
|
verifyPassword :: Password -> HashedPassword -> Bool
|
||||||
verifyPassword password salt hash =
|
verifyPassword (Password password) (HashedPassword hash) = Bcrypt.validatePassword (fromTextToBytes password) (fromTextToBytes hash)
|
||||||
let _hash = hashPasswordWithSalt password salt
|
|
||||||
in hash == _hash
|
|
||||||
|
@ -20,7 +20,6 @@ data UserEntity f = UserEntity
|
|||||||
, entityUserName :: Column f Username
|
, entityUserName :: Column f Username
|
||||||
, entityUserEmail :: Column f EmailAddress
|
, entityUserEmail :: Column f EmailAddress
|
||||||
, entityUserPassword :: Column f HashedPassword
|
, entityUserPassword :: Column f HashedPassword
|
||||||
, entityUserSalt :: Column f Salt
|
|
||||||
, entityUserBio :: Column f Text
|
, entityUserBio :: Column f Text
|
||||||
, entityUserImage :: Column f Text
|
, entityUserImage :: Column f Text
|
||||||
}
|
}
|
||||||
@ -38,7 +37,6 @@ userSchema = TableSchema
|
|||||||
, entityUserName = "user_username"
|
, entityUserName = "user_username"
|
||||||
, entityUserEmail = "user_email"
|
, entityUserEmail = "user_email"
|
||||||
, entityUserPassword = "user_password"
|
, entityUserPassword = "user_password"
|
||||||
, entityUserSalt = "user_salt"
|
|
||||||
, entityUserBio = "user_bio"
|
, entityUserBio = "user_bio"
|
||||||
, entityUserImage = "user_image"
|
, entityUserImage = "user_image"
|
||||||
}
|
}
|
||||||
@ -61,11 +59,10 @@ updateUserProperties user expr = expr
|
|||||||
, entityUserImage = lit (userImage user)
|
, entityUserImage = lit (userImage user)
|
||||||
}
|
}
|
||||||
|
|
||||||
updatePasswordAndSalt :: (HashedPassword, Salt) -> UserEntity Expr -> UserEntity Expr
|
updatePassword :: HashedPassword -> UserEntity Expr -> UserEntity Expr
|
||||||
updatePasswordAndSalt (hash, salt) expr = expr
|
updatePassword hash expr = expr
|
||||||
{ entityUserSalt = lit salt
|
{ entityUserPassword = lit hash
|
||||||
, entityUserPassword = lit hash
|
}
|
||||||
}
|
|
||||||
|
|
||||||
getUserByIdStmt :: Expr UserId -> Query (UserEntity Expr)
|
getUserByIdStmt :: Expr UserId -> Query (UserEntity Expr)
|
||||||
getUserByIdStmt uid = do
|
getUserByIdStmt uid = do
|
||||||
@ -85,8 +82,8 @@ getUserByEmailStmt email = do
|
|||||||
where_ $ entityUserEmail a ==. lit email
|
where_ $ entityUserEmail a ==. lit email
|
||||||
return a
|
return a
|
||||||
|
|
||||||
insertUserStmt :: User -> (HashedPassword, Salt) -> Insert [UserId]
|
insertUserStmt :: User -> HashedPassword -> Insert [UserId]
|
||||||
insertUserStmt user (hash, salt) = Insert
|
insertUserStmt user hash = Insert
|
||||||
{ into = userSchema
|
{ into = userSchema
|
||||||
, rows = values [ UserEntity
|
, rows = values [ UserEntity
|
||||||
{ entityUserId = unsafeCastExpr $ nextval "users_user_id_seq"
|
{ entityUserId = unsafeCastExpr $ nextval "users_user_id_seq"
|
||||||
@ -95,14 +92,13 @@ insertUserStmt user (hash, salt) = Insert
|
|||||||
, entityUserBio = lit (userBio user)
|
, entityUserBio = lit (userBio user)
|
||||||
, entityUserImage = lit (userImage user)
|
, entityUserImage = lit (userImage user)
|
||||||
, entityUserPassword = lit hash
|
, entityUserPassword = lit hash
|
||||||
, entityUserSalt = lit salt
|
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
, onConflict = DoNothing
|
, onConflict = DoNothing
|
||||||
, returning = Projection entityUserId
|
, returning = Projection entityUserId
|
||||||
}
|
}
|
||||||
|
|
||||||
updateUserStmt :: User -> Maybe (HashedPassword, Salt) -> Update Int64
|
updateUserStmt :: User -> Maybe HashedPassword -> Update Int64
|
||||||
updateUserStmt user mbPassword =
|
updateUserStmt user mbPassword =
|
||||||
Update
|
Update
|
||||||
{ target = userSchema
|
{ target = userSchema
|
||||||
@ -113,5 +109,5 @@ updateUserStmt user mbPassword =
|
|||||||
}
|
}
|
||||||
where
|
where
|
||||||
setter _ = case mbPassword of
|
setter _ = case mbPassword of
|
||||||
Just password -> updatePasswordAndSalt password . updateUserProperties user
|
Just password -> updatePassword password . updateUserProperties user
|
||||||
_ -> updateUserProperties user
|
_ -> updateUserProperties user
|
||||||
|
@ -13,6 +13,7 @@ import Hasql.Statement (Statement)
|
|||||||
|
|
||||||
import Conduit.Config
|
import Conduit.Config
|
||||||
import Conduit.App
|
import Conduit.App
|
||||||
|
import Conduit.Environment
|
||||||
|
|
||||||
loadPool :: DbConfig -> IO Pool
|
loadPool :: DbConfig -> IO Pool
|
||||||
loadPool cfg = acquire (poolSize, 1, postgresSettings)
|
loadPool cfg = acquire (poolSize, 1, postgresSettings)
|
||||||
@ -36,9 +37,9 @@ runTransactionWithPool pool transaction = do
|
|||||||
runStmt :: Statement () a -> Transaction a
|
runStmt :: Statement () a -> Transaction a
|
||||||
runStmt = statement ()
|
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
|
runTransaction transaction = do
|
||||||
pool <- getDbPool
|
pool <- getDbPool'
|
||||||
runTransactionWithPool pool transaction
|
runTransactionWithPool pool transaction
|
||||||
|
|
||||||
executeStmt :: Statement () a -> AppM a
|
executeStmt :: Statement () a -> AppM a
|
||||||
|
18
src/Conduit/Environment.hs
Normal file
18
src/Conduit/Environment.hs
Normal file
@ -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
|
@ -32,7 +32,7 @@ getUserByEmailAndPassword email password = do
|
|||||||
return $ verifyPassword' =<< listToMaybe users
|
return $ verifyPassword' =<< listToMaybe users
|
||||||
where
|
where
|
||||||
verifyPassword' user =
|
verifyPassword' user =
|
||||||
if verifyPassword password (entityUserSalt user) (entityUserPassword user)
|
if verifyPassword password (entityUserPassword user)
|
||||||
then
|
then
|
||||||
Just $ mapUserEntityToUser user
|
Just $ mapUserEntityToUser user
|
||||||
else
|
else
|
||||||
|
@ -8,6 +8,8 @@ import Data.List ( head, tail )
|
|||||||
import Data.Char ( toLower )
|
import Data.Char ( toLower )
|
||||||
import Data.UUID
|
import Data.UUID
|
||||||
import System.Random
|
import System.Random
|
||||||
|
import Data.ByteArray (Bytes, convert)
|
||||||
|
import Data.Text.Encoding (decodeUtf8)
|
||||||
|
|
||||||
toJsonOptions :: Int -> Options
|
toJsonOptions :: Int -> Options
|
||||||
toJsonOptions prefixLength =
|
toJsonOptions prefixLength =
|
||||||
@ -22,8 +24,11 @@ hoistMaybe = MaybeT . return
|
|||||||
newUUID :: IO UUID
|
newUUID :: IO UUID
|
||||||
newUUID = randomIO
|
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 :: Maybe a -> b -> (a -> b) -> b
|
||||||
flipMaybe mb error f = maybe error f mb
|
flipMaybe mb error f = maybe error f mb
|
||||||
|
|
||||||
|
fromTextToBytes :: Text -> Bytes
|
||||||
|
fromTextToBytes = convert . encodeUtf8
|
||||||
|
|
||||||
|
fromBytesToText :: Bytes -> Text
|
||||||
|
fromBytesToText = decodeUtf8 . convert
|
||||||
|
@ -71,18 +71,16 @@ setupTestUser :: Text -> IO ()
|
|||||||
setupTestUser username = do
|
setupTestUser username = do
|
||||||
let email = T.append username "@test.com"
|
let email = T.append username "@test.com"
|
||||||
let password = Password $ T.append username "password"
|
let password = Password $ T.append username "password"
|
||||||
(hash, salt) <- hashPassword password
|
hash <- hashPassword password
|
||||||
setupSeedData $
|
setupSeedData $
|
||||||
sql $ mconcat
|
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 ('"
|
, "VALUES ('"
|
||||||
, T.encodeUtf8 email
|
, T.encodeUtf8 email
|
||||||
, "', '"
|
, "', '"
|
||||||
, T.encodeUtf8 username
|
, T.encodeUtf8 username
|
||||||
, "', '"
|
, "', '"
|
||||||
, T.encodeUtf8 . getHashedPasswd $ hash
|
, T.encodeUtf8 . getHashedPasswd $ hash
|
||||||
, "', '"
|
|
||||||
, T.encodeUtf8 . getSalt $ salt
|
|
||||||
, "', ''"
|
, "', ''"
|
||||||
, ", '');"
|
, ", '');"
|
||||||
]
|
]
|
||||||
|
Loading…
Reference in New Issue
Block a user