71 lines
3.5 KiB
Haskell
71 lines
3.5 KiB
Haskell
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
{-# OPTIONS_GHC -O0 -fno-ignore-interface-pragmas -fno-omit-interface-pragmas #-}
|
|
|
|
module Handler.Users.Add
|
|
( getAdminUserAddR, postAdminUserAddR
|
|
) where
|
|
|
|
|
|
import Import
|
|
import Utils.Users
|
|
import Handler.Utils
|
|
import Jobs
|
|
|
|
|
|
adminUserForm :: Maybe AddUserData -> Form AddUserData
|
|
adminUserForm template = renderAForm FormStandard
|
|
$ AddUserData
|
|
<$> aopt (textField & cfStrip) (fslI MsgAdminUserTitle) (audTitle <$> template)
|
|
<*> areq (textField & cfStrip) (fslI MsgAdminUserFirstName) (audFirstName <$> template)
|
|
<*> areq (textField & cfStrip) (fslI MsgAdminUserSurname) (audSurname <$> template)
|
|
<*> areq (textField & cfStrip) (fslI MsgAdminUserDisplayName) (audDisplayName <$> template)
|
|
<*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (audDisplayEmail <$> template)
|
|
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (audMatriculation <$> template)
|
|
<*> aopt (selectField optionsFinite) (fslI MsgAdminUserSex) (audSex <$> template)
|
|
<*> aopt dayField (fslI MsgAdminUserBirthday) (audBirthday <$> template)
|
|
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMobile) (audMobile <$> template)
|
|
<*> aopt (textField & cfStrip) (fslI MsgAdminUserTelephone) (audTelephone <$> template)
|
|
<*> aopt (textField & cfStrip) (fslI MsgAdminUserFPersonalNumber) (audFPersonalNumber <$> template)
|
|
<*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (audFDepartment <$> template)
|
|
<*> aopt htmlField (fslI MsgAdminUserPostAddress) (audPostAddress <$> template)
|
|
<*> areq checkBoxField (fslI MsgAdminUserPrefersPostal) (audPrefersPostal <$> template)
|
|
<*> aopt (textField & cfStrip) (fslI MsgAdminUserPinPassword) (audPinPassword <$> template)
|
|
<*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (audEmail <$> template)
|
|
<*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (audIdent <$> template)
|
|
<*> aopt passwordField (fslI MsgAdminUserPassword) (audPassword <$> template)
|
|
|
|
-- | Like `addNewUser`, but starts background jobs and tries to notify users
|
|
addNewUserNotify :: AddUserData -> Handler (Maybe UserId)
|
|
addNewUserNotify aud = do
|
|
mbUid <- addNewUser aud
|
|
case mbUid of
|
|
Nothing -> return Nothing
|
|
Just uid -> runDBJobs $ do
|
|
queueDBJob $ JobSynchroniseUser uid
|
|
when (is _Just $ audPassword aud) $ do
|
|
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
|
|
queueDBJob $ JobSendPasswordReset uid
|
|
return $ Just uid
|
|
|
|
getAdminUserAddR, postAdminUserAddR :: Handler Html
|
|
getAdminUserAddR = postAdminUserAddR
|
|
postAdminUserAddR = do
|
|
((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing
|
|
formResult userRes $ addNewUserNotify >=> \case
|
|
(Just uid) -> do
|
|
addMessageI Success MsgUserAdded
|
|
cID <- encrypt uid
|
|
redirect $ AdminUserR cID
|
|
Nothing ->
|
|
addMessageI Error MsgUserCollision
|
|
|
|
siteLayoutMsg MsgHeadingUserAdd $ do
|
|
setTitleI MsgHeadingUserAdd
|
|
wrapForm userView def
|
|
{ formAction = Just $ SomeRoute AdminUserAddR
|
|
, formEncoding = userEnctype
|
|
}
|