MasseR/ebook-manager
1
0
Fork 0
Code Issues 9 Pull Requests Releases Wiki Activity

Finish the password validation

Browse Source
This commit is contained in:
Mats Rauhala 2018-08-05 21:39:38 +03:00
parent 8ff50d21ed
commit a4129ae5cf
1 changed files with 8 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
src/Database/User.hs
View File

@ -8,11 +8,12 @@ import ClassyPrelude
import Database import Database
import Database.Schema import Database.Schema
import Database.Selda import Database.Selda
import Control.Lens (over, _Just) import Control.Lens (view, over, _Just)
import Data.Generics.Product import Data.Generics.Product
import Crypto.KDF.BCrypt import Crypto.KDF.BCrypt
import Crypto.Random.Types (MonadRandom) import Crypto.Random.Types (MonadRandom)
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad (mfilter)
data UserExistsError = UserExistsError data UserExistsError = UserExistsError
@ -43,7 +44,12 @@ getUser :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe (User NoPassw
getUser name = over (_Just . field @"password") (const NoPassword) <$> getUser' name getUser name = over (_Just . field @"password") (const NoPassword) <$> getUser' name
validateUser :: (MonadMask m, MonadIO m) => Username -> PlainPassword -> SeldaT m (Maybe (User NoPassword)) validateUser :: (MonadMask m, MonadIO m) => Username -> PlainPassword -> SeldaT m (Maybe (User NoPassword))
validateUser name _ = getUser name validateUser name (PlainPassword password) =
asHidden . mfilter valid <$> getUser' name
where
valid = validatePassword password' . unHashed . view (field @"password")
password' = encodeUtf8 password
asHidden = over (_Just . field @"password") (const NoPassword)
getUser' :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe ( User HashedPassword )) getUser' :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe ( User HashedPassword ))
getUser' name = listToMaybe . fmap fromRel <$> query q getUser' name = listToMaybe . fmap fromRel <$> query q