156 lines
7.1 KiB
Haskell
156 lines
7.1 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.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
|
|
|
|
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
|
|
}
|