finished putUserInformationCoach.

parent 26c42523
......@@ -19,6 +19,7 @@ library
exposed-modules: Types
, Conf
, Model
, Util
, API.User
, API.Articles
, API.Profile
......
......@@ -28,7 +28,8 @@ type UserInformationAPI =
userInformationApi ::
MonadIO m => AuthResult User -> ServerT UserInformationAPI (CoachT m)
userInformationApi authres = panic ""
userInformationApi authres =
getUserInformationCoach authres :<|> putUserInformationCoach authres
userInformationProxy :: Proxy UserInformationAPI
userInformationProxy = Proxy
......
......@@ -15,6 +15,7 @@ import Servant.Auth.Server
import Conf
import Model
import Types
import Util
import Que.Users
......@@ -48,14 +49,6 @@ postRegistrationCoach (RequestRegistration reqreg) = do
case existings of
[] -> return ()
_ -> throwError err409 { errBody = "User already exists."}
generatePassword password = do
mpass <-
hashPasswordUsingPolicy
slowerBcryptHashingPolicy
(pack $ unpack password)
case mpass of
Nothing -> generatePassword password
Just pa -> return (decodeUtf8 pa)
generateToken ::
MonadIO m
......@@ -98,9 +91,51 @@ postLoginCoach (RequestLogin (RequestLoginBody email password)) = do
notFoundIfNothing (Just x) = return x
getUserInformationCoach :: MonadIO m => AuthResult User -> CoachT m ResponseUser
getUserInformationCoach (Authenticated user) = panic ""
getUserInformationCoach (Authenticated user) = do
token <- generateToken user
return $
ResponseUser $
ResponseUserBody
(userEmail user)
(Just token)
(userUsername user)
(userBio user)
(userImage user)
getUserInformationCoach _ = throwError err401
putUserInformationCoach :: MonadIO m => AuthResult User -> RequestUpdateUser -> CoachT m ResponseUser
putUserInformationCoach (Authenticated user) (RequestUpdateUser reqbody) = panic ""
putUserInformationCoach (Authenticated _) (RequestUpdateUser (RequestUpdateUserBody Nothing Nothing Nothing Nothing Nothing)) =
throwError err422 { errBody = "What are you going to update?"}
putUserInformationCoach (Authenticated user) (RequestUpdateUser requpdate) = do
let newUsernameEmail old (Just x) =
if old == x
then Nothing
else Just x
newUsernameEmail _ Nothing = Nothing
perhapsnewusername =
newUsernameEmail (userUsername user) (requpdtuserbodyUsername requpdate)
perhapsnewemail =
newUsernameEmail (userEmail user) (requpdtuserbodyEmail requpdate)
existings <-
runDb $ selectUserByMaybeUsernameEmail perhapsnewusername perhapsnewemail
unless (null existings) $ throwError err409 {errBody = "Already used."}
runDb $
updateUser
(userUsername user)
(requpdtuserbodyEmail requpdate)
(requpdtuserbodyUsername requpdate)
(requpdtuserbodyPassword requpdate)
(requpdtuserbodyImage requpdate)
(requpdtuserbodyBio requpdate)
(Just (Entity _ u)) <-
runDb $ getBy $ UniqueEmail $ fromMaybe (userEmail user) perhapsnewemail
token <- generateToken u
return $
ResponseUser $
ResponseUserBody
(userEmail u)
(Just token)
(userUsername u)
(userBio u)
(userImage u)
putUserInformationCoach _ _ = throwError err401
......@@ -7,11 +7,12 @@
{-# LANGUAGE TypeFamilies #-}
module Que.Users where
import Lib.Prelude hiding (from, get, on, (<&>))
import Lib.Prelude hiding (from, get, on, (<&>))
import Database.Esqueleto
import Model
import Util
selectUserByUsernameEmail ::
( PersistUniqueRead backend
......@@ -30,6 +31,25 @@ selectUserByUsernameEmail username email = do
||. user ^. UserEmail ==. val email)
return user
selectUserByMaybeUsernameEmail ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Maybe Text
-> Maybe Text
-> ReaderT backend m [Entity User]
selectUserByMaybeUsernameEmail musername memail = do
select $
from $ \user -> do
where_ (whereBuilderOr musername user UserUsername
||. whereBuilderOr memail user UserEmail)
return user
where
whereBuilderOr Nothing _ _ = val False
whereBuilderOr (Just x) entity accessor = entity ^. accessor ==. val x
insertUserEntity ::
( BaseBackend backend ~ SqlBackend
, MonadIO m
......@@ -38,3 +58,28 @@ insertUserEntity ::
=> User
-> ReaderT backend m (Entity User)
insertUserEntity user = insertEntity user
updateUser ::
MonadIO m
=> Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> Maybe Text
-> ReaderT SqlBackend m ()
updateUser username memail musername mpassword mimage mbio = do
mpassword' <- liftIO $ mapM generatePassword mpassword
update $ \user -> do
set
user
[ updateByMaybe memail user UserEmail
, updateByMaybe musername user UserUsername
, updateByMaybe mpassword' user UserPassword
, UserImage =. val mimage
, UserBio =. val mbio
]
where_ (user ^. UserUsername ==. val username)
where
updateByMaybe (Just x) _ accessor = accessor =. val x
updateByMaybe Nothing entity accessor = accessor =. entity ^. accessor
module Util where
import Lib.Prelude
import Crypto.BCrypt
import Data.ByteString.Char8 (pack)
import Data.Text (unpack)
generatePassword :: Text -> IO Text
generatePassword password = do
mpass <-
hashPasswordUsingPolicy
slowerBcryptHashingPolicy
(pack $ unpack password)
case mpass of
Nothing -> generatePassword password
Just pa -> return (decodeUtf8 pa)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment