-- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Handler.Users.Add ( getAdminUserAddR, postAdminUserAddR , AdminUserForm(..), AuthenticationKind(..) , addNewUser, addNewUserNoNotfication --, adminUserForm , classifyAuth, mkAuthMode -- no longer needed elsewhere ) where import Import import Handler.Utils import Jobs data AdminUserForm = AdminUserForm { aufTitle :: Maybe Text , aufFirstName :: Text , aufSurname :: UserSurname , aufDisplayName :: UserDisplayName , aufDisplayEmail :: UserEmail , aufMatriculation :: Maybe UserMatriculation , aufSex :: Maybe Sex , aufMobile :: Maybe Text , aufTelephone :: Maybe Text , aufFPersonalNumber :: Maybe Text , aufFDepartment :: Maybe Text , aufPostAddress :: Maybe StoredMarkup , aufPrefersPostal :: Bool , aufPinPassword :: Maybe Text , aufEmail :: UserEmail , aufIdent :: UserIdent , aufAuth :: AuthenticationKind } data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable, Universe, Finite) --instance Universe AuthenticationKind --instance Finite AuthenticationKind embedRenderMessage ''UniWorX ''AuthenticationKind id nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2 {- classifyAuth :: AuthenticationMode -> AuthenticationKind classifyAuth AuthLDAP = AuthKindLDAP classifyAuth AuthPWHash{} = AuthKindPWHash classifyAuth AuthNoLogin = AuthKindNoLogin -} mkAuthMode :: AuthenticationKind -> AuthenticationMode mkAuthMode AuthKindLDAP = AuthLDAP mkAuthMode AuthKindPWHash = AuthPWHash "" mkAuthMode AuthKindNoLogin = AuthNoLogin adminUserForm :: Maybe AdminUserForm -> Form AdminUserForm adminUserForm template = renderAForm FormStandard $ AdminUserForm <$> aopt (textField & cfStrip) (fslI MsgAdminUserTitle) (aufTitle <$> template) <*> areq (textField & cfStrip) (fslI MsgAdminUserFirstName) (aufFirstName <$> template) <*> areq (textField & cfStrip) (fslI MsgAdminUserSurname) (aufSurname <$> template) <*> areq (textField & cfStrip) (fslI MsgAdminUserDisplayName) (aufDisplayName <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (aufDisplayEmail <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template) <*> aopt (selectField optionsFinite) (fslI MsgAdminUserSex) (aufSex <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserMobile) (aufMobile <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserTelephone) (aufTelephone <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserFPersonalNumber) (aufFPersonalNumber <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template) <*> aopt htmlField (fslI MsgAdminUserPostAddress) (aufPostAddress <$> template) <*> areq checkBoxField (fslI MsgAdminUserPrefersPostal) (aufPrefersPostal <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserPinPassword) (aufPinPassword <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template) <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth & setTooltip MsgAdminUserAuthTooltip) (aufAuth <$> template <|> Just AuthKindLDAP) addNewUser :: AdminUserForm -> Handler (Maybe UserId) addNewUser = addNewUser' True -- | Like `addNewUser`, but tries to avoid user notification. A notficiation is necessary for AuthPWHash. addNewUserNoNotfication :: AdminUserForm -> Handler (Maybe UserId) addNewUserNoNotfication = addNewUser' False addNewUser' :: Bool -> AdminUserForm -> Handler (Maybe UserId) addNewUser' notifyUsr AdminUserForm{..} = do now <- liftIO getCurrentTime UserDefaultConf{..} <- getsYesod $ view _appUserDefaults let newUser = User { userIdent = aufIdent , userMaxFavourites = userDefaultMaxFavourites , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms , userTheme = userDefaultTheme , userDateTimeFormat = userDefaultDateTimeFormat , userDateFormat = userDefaultDateFormat , userTimeFormat = userDefaultTimeFormat , userDownloadFiles = userDefaultDownloadFiles , userWarningDays = userDefaultWarningDays , userShowSex = userDefaultShowSex , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels , userNotificationSettings = def , userLanguages = Nothing , userCsvOptions = def , userTokensIssuedAfter = Nothing , userCreated = now , userLastLdapSynchronisation = Nothing , userLdapPrimaryKey = aufFPersonalNumber , userLastAuthentication = Nothing , userEmail = aufEmail , userDisplayName = aufDisplayName , userDisplayEmail = aufDisplayEmail , userFirstName = aufFirstName , userSurname = aufSurname , userTitle = aufTitle , userSex = aufSex , userMobile = aufMobile , userTelephone = aufTelephone , userCompanyPersonalNumber = aufFPersonalNumber , userCompanyDepartment = aufFDepartment , userPostAddress = aufPostAddress , userPrefersPostal = aufPrefersPostal , userPinPassword = aufPinPassword , userMatrikelnummer = aufMatriculation , userAuthentication = mkAuthMode aufAuth } runDBJobs . runMaybeT $ do uid <- MaybeT $ insertUnique newUser lift . queueDBJob $ JobSynchroniseLdapUser uid when (notifyUsr && aufAuth /= AuthKindNoLogin) $ lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid (newUser ^. _userAuthentication) when (aufAuth == AuthKindPWHash) $ lift . queueDBJob $ JobSendPasswordReset uid return uid getAdminUserAddR, postAdminUserAddR :: Handler Html getAdminUserAddR = postAdminUserAddR postAdminUserAddR = do ((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing formResult userRes $ addNewUser >=> \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 }