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

Modify types, create instances

Browse Source
This commit is contained in:
Mats Rauhala
2018-08-04 22:05:41 +03:00
parent ac82f6973b
commit 964972858b
4 changed files with 72 additions and 31 deletions
Download Patch File Download Diff File Expand all files Collapse all files

18
src/Database/User.hs
View File

@ -16,11 +16,8 @@ import Control.Monad.Logger
data UserExistsError = UserExistsError
newtype PlainPassword = PlainPassword Text
newtype HashedPassword = HashedPassword {unHashed :: ByteString}
data NoPassword = NoPassword
insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Text -> Text -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
insertUser :: (MonadLogger m, MonadIO m, MonadMask m, MonadRandom m) => Username -> Email -> PlainPassword -> SeldaT m (Either UserExistsError (User NoPassword))
insertUser username email (PlainPassword password) =
getUser' username >>= maybe insert' (const (return $ Left UserExistsError))
where
@ -29,7 +26,7 @@ insertUser username email (PlainPassword password) =
lift $ $logInfo $ "Inserting new user as " <> pack (show role)
let bytePass = encodeUtf8 password
user <- User def email username role . HashedPassword <$> lift (hashPassword 12 bytePass)
insert_ (gen users) [toRel (over (field @"password") unHashed user)] >> return (over (field @"password") (const NoPassword) user)
insert_ (gen users) [toRel user] >> return (over (field @"password") (const NoPassword) user)
adminExists :: (MonadMask m, MonadLogger m, MonadIO m) => SeldaT m Bool
adminExists = do
@ -42,13 +39,16 @@ adminExists = do
restrict (r .== literal AdminRole)
return (count r)
getUser :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe (User NoPassword))
getUser :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe (User NoPassword))
getUser name = over (_Just . field @"password") (const NoPassword) <$> getUser' name
getUser' :: (MonadMask m, MonadIO m) => Text -> SeldaT m (Maybe ( User HashedPassword ))
getUser' name = over (_Just . field @"password") HashedPassword . listToMaybe . fmap fromRel <$> query q
validateUser :: (MonadMask m, MonadIO m) => Username -> PlainPassword -> SeldaT m (Maybe (User NoPassword))
validateUser name _ = getUser name
getUser' :: (MonadMask m, MonadIO m) => Username -> SeldaT m (Maybe ( User HashedPassword ))
getUser' name = listToMaybe . fmap fromRel <$> query q
where
q = do
u@(_ :*: username :*: _ :*: _ :*: _) <- select (gen users)
u@(_ :*: _ :*: username :*: _ ) <- select (gen users)
restrict (username .== literal name)
return u