gonito/Handler/AccountReset.hs

169 lines
6.4 KiB
Haskell

module Handler.AccountReset where
import Import
import Handler.Shared
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3, bfs)
import Data.Time.Clock (addUTCTime)
import Handler.Common (passwordConfirmField, updatePassword, isPasswordAcceptable, tooWeakPasswordMessage)
data AccountStatus = NewlyCreated | PasswordReset
getCreateResetLinkR :: Handler Html
getCreateResetLinkR = do
(formWidget, formEnctype) <- generateFormPost createResetLinkForm
defaultLayout $ do
setTitle "Create a reset link"
$(widgetFile "create-reset-link")
postCreateResetLinkR :: Handler Html
postCreateResetLinkR = do
((result, _), _) <- runFormPost createResetLinkForm
let mUserIdentifier = case result of
FormSuccess (userIdentifier, _) -> Just userIdentifier
_ -> Nothing
let mCourseId = case result of
FormSuccess (_, Just courseId) -> Just courseId
_ -> Nothing
doCreateResetLink mUserIdentifier mCourseId
createLinkToken :: Handler (Text, UTCTime)
createLinkToken = do
key <- newToken
theNow <- liftIO getCurrentTime
let expirationMoment = addUTCTime (60*60*24) theNow
return (key, expirationMoment)
doCreateResetLink :: Maybe Text -> Maybe CourseId -> Handler Html
doCreateResetLink (Just userIdentifier) mCourseId = do
mUserEnt <- runDB $ getBy $ UniqueUser userIdentifier
userId <- createOrUse mUserEnt userIdentifier
addParticipant userId mCourseId
(key, expirationMoment) <- createLinkToken
runDB $ update userId [UserVerificationKey =. Just key, UserKeyExpirationDate =. Just expirationMoment]
defaultLayout $ do
setTitle "Creating a reset link"
$(widgetFile "reset-link-created")
doCreateResetLink Nothing _ = do
setMessage $ toHtml ("No user identifier given" :: Text)
getCreateResetLinkR
addParticipant :: (PersistStoreWrite (YesodPersistBackend site),
YesodPersist site,
BaseBackend (YesodPersistBackend site) ~ SqlBackend)
=> Key User -> Maybe (Key Course) -> HandlerFor site ()
addParticipant _ Nothing = return ()
addParticipant userId (Just courseId) = do
_ <- runDB $ insert $ Participant userId courseId
return ()
createOrUse :: Maybe (Entity User) -> Text -> Handler UserId
createOrUse (Just userEnt) _ = return $ entityKey userEnt
createOrUse Nothing userIdentifier = do
setMessage $ toHtml ("Created new user " ++ userIdentifier)
triggerToken <- newToken
userId <- runDB $ insert $ User userIdentifier
Nothing
Nothing
False
Nothing
True
Nothing
Nothing
Nothing
(Just triggerToken)
Nothing
return userId
createResetLinkForm :: Form (Text, Maybe CourseId)
createResetLinkForm = renderBootstrap3 BootstrapBasicForm $ (,)
<$> areq textField (bfs MsgUserIdentifier) Nothing
<*> coursesSelectFieldList
coursesSelectFieldList :: (PersistQueryRead (YesodPersistBackend site), YesodPersist site, RenderMessage site FormMessage, RenderMessage site AppMessage, BaseBackend (YesodPersistBackend site) ~ SqlBackend) => AForm (HandlerFor site) (Maybe (Key Course))
coursesSelectFieldList = aopt (selectField courses) (bfs MsgCourseOptional) Nothing
where
courses = do
courseEnts <- runDB $ selectList [] [Asc CourseName]
optionsPairs $ Import.map (\ch -> (courseName $ entityVal ch, entityKey ch)) courseEnts
getResetPasswordR :: Text -> Handler Html
getResetPasswordR key = do
mUserId <- checkVerificationKey key
accountStatus <- case mUserId of
(Just userId) -> do
user <- runDB$ get404 userId
return $ if isJust (userPassword user)
then
PasswordReset
else
NewlyCreated
_ -> return PasswordReset
(formWidget, formEnctype) <- generateFormPost $ changePasswordForm accountStatus
master <- getYesod
defaultLayout $ do
setTitle "Reset password"
$(widgetFile "reset-password")
postResetPasswordR :: Text -> Handler Html
postResetPasswordR key = do
((result, _), _) <- runFormPost $ changePasswordForm PasswordReset
mUserId <- checkVerificationKey key
let mPassword = case result of
FormSuccess password -> Just password
_ -> Nothing
doResetPassword key mUserId mPassword
doResetPassword :: Text -> Maybe (Key User) -> Maybe Text -> Handler Html
doResetPassword key _ Nothing = do
setMessage $ toHtml ("Password not given or does not match! Make sure you entered the same password" :: Text)
getResetPasswordR key
doResetPassword key (Just userId) (Just password) = do
doResetPassword' (isPasswordAcceptable password) key userId password
doResetPassword key Nothing _ = do
runDB $ updateWhere [UserVerificationKey ==. Just key, UserIsAdmin ==. False] removeVerificationKeyStatement
master <- getYesod
defaultLayout $ do
setTitle "Reset password"
$(widgetFile "password-reset-failed")
doResetPassword' :: Bool -> Text -> Key User -> Text -> Handler Html
doResetPassword' True _ userId password = do
updatePassword userId (Just password)
runDB $ update userId removeVerificationKeyStatement
setMessage $ toHtml ("Password set! Now, you can log in with your login." :: Text)
redirect HomeR
doResetPassword' False key _ _ = do
tooWeakPasswordMessage
getResetPasswordR key
removeVerificationKeyStatement :: [Update User]
removeVerificationKeyStatement = [UserVerificationKey =. Nothing, UserKeyExpirationDate =. Nothing]
checkVerificationKey :: Text -> Handler (Maybe UserId)
checkVerificationKey key = do
theNow <- liftIO getCurrentTime
userEnts <- runDB $ selectList [UserVerificationKey ==. Just key, UserKeyExpirationDate >. Just theNow] []
return $ case userEnts of
[Entity k _] -> Just k
_ -> Nothing
changePasswordForm :: AccountStatus -> Form Text
changePasswordForm accountStatus = renderBootstrap3 BootstrapBasicForm
$ areq passwordConfirmField (bfs $ passwordFormHeader accountStatus) Nothing
passwordFormHeader :: AccountStatus -> AppMessage
passwordFormHeader NewlyCreated = MsgPasswordForNewAccount
passwordFormHeader PasswordReset = MsgPassword