Commit 4ed12b16 authored by Ibnu Daru Aji's avatar Ibnu Daru Aji

finished postRegistrationCoach.

parent 53c9063e
......@@ -24,6 +24,7 @@ library
, API.Profile
, API.Tags
, Que.Tags
, Que.Users
, Coach.Tags
, RealWorld
, DevelMain
......
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
module Coach.Users where
import Protolude
import Crypto.BCrypt
import Data.ByteString.Char8 (pack)
import Data.ByteString.Lazy as BL (toStrict)
import Data.Text (unpack)
import Database.Esqueleto
import Servant
import Servant.Auth.Server
import Conf
import Model
import Types
import Que.Users
postRegistrationCoach :: MonadIO m => RequestRegistration -> CoachT m ResponseUser
postRegistrationCoach (RequestRegistration reqreg) = do
(usernameEmailDontConflict
(reqregbodyUsername reqreg)
(reqregbodyEmail reqreg))
hashedpassword <- liftIO $ generatePassword (reqregbodyPassword reqreg)
(Entity _ user) <-
runDb $
insertUserEntity $
User
(reqregbodyEmail reqreg)
(reqregbodyUsername reqreg)
hashedpassword
Nothing
Nothing
token <- generateToken user
return $
ResponseUser $
ResponseUserBody
(userEmail user)
(Just token)
(userUsername user)
(userBio user)
(userImage user)
where
usernameEmailDontConflict username email = do
existings <- runDb (selectUserByUsernameEmail username email)
case existings of
[] -> return ()
_ -> throwError err422
generatePassword password = do
mpass <-
hashPasswordUsingPolicy
slowerBcryptHashingPolicy
(pack $ unpack password)
case mpass of
Nothing -> generatePassword password
Just pa -> return (decodeUtf8 pa)
generateToken user = do
jws <- asks configurationJWTSettings
etoken <- liftIO $ makeJWT user jws Nothing
token <- eitherToCoach etoken (decodeUtf8 . BL.toStrict) err500
return token
eitherToCoach (Left x) _ onFail = throwError $ onFail {errBody = show x}
eitherToCoach (Right v) onSuccess _ = return $ onSuccess v
postLoginCoach :: MonadIO m => RequestLogin -> CoachT m ResponseUser
postLoginCoach (RequestLogin (RequestLoginBody email password)) = panic ""
getUserInformationCoach :: MonadIO m => AuthResult User -> CoachT m ResponseUser
getUserInformationCoach (Authenticated user) = panic ""
getUserInformationCoach _ = throwError err401
putUserInformationCoach :: MonadIO m => AuthResult User -> RequestUpdateUser -> CoachT m ResponseUser
putUserInformationCoach (Authenticated user) (RequestUpdateUser reqbody) = panic ""
putUserInformationCoach _ _ = throwError err401
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module Que.Users where
import Lib.Prelude hiding (from, get, on, (<&>))
import Database.Esqueleto
import Model
selectUserByUsernameEmail ::
( PersistUniqueRead backend
, PersistQueryRead backend
, BackendCompatible SqlBackend backend
, MonadIO m
)
=> Text
-> Text
-> ReaderT backend m [Entity User]
selectUserByUsernameEmail username email = do
select $
from $ \user -> do
where_
(user ^. UserUsername ==. val username
||. user ^. UserEmail ==. val email)
return user
insertUserEntity ::
( BaseBackend backend ~ SqlBackend
, MonadIO m
, PersistStoreWrite backend
)
=> User
-> ReaderT backend m (Entity User)
insertUserEntity user = insertEntity user
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