From ad4fbc41c6225bfa63ab8272c16a24233d6f6e1b Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 19 Jan 2023 17:59:58 +0100 Subject: [PATCH] chore: refactor to fix circular depenency, update receivers before sending, improve company model --- models/company.model | 12 +- package.yaml | 3 +- src/Application.hs | 1 + src/Handler/Users.hs | 6 +- src/Handler/Users/Add.hs | 162 ++++-------------- src/Handler/Utils/Avs.hs | 42 ++--- src/Handler/Utils/Company.hs | 4 +- src/Handler/Utils/Users.hs | 2 +- .../SendNotification/UserAuthModeUpdate.hs | 4 +- src/Jobs/Types.hs | 2 +- src/Utils/Print.hs | 3 +- src/Utils/Users.hs | 100 +++++++++++ test/Database/Fill.hs | 10 +- 13 files changed, 183 insertions(+), 168 deletions(-) create mode 100644 src/Utils/Users.hs diff --git a/models/company.model b/models/company.model index da7b295e8..4c6259408 100644 --- a/models/company.model +++ b/models/company.model @@ -4,13 +4,15 @@ -- Description of companies associated with users -Company - name CompanyName -- == (CI Text) - shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future - -- postAddress StoredMarkup Maybe -- - -- avsId Int -- FUTURE TODO: once this number becomes available through AVS interface; this could be the primary key +Company + name CompanyName -- == (CI Text) + shorthand CompanyShorthand -- == (CI Text) and CompanyKey :: CompanyShorthand -> CompanyId FUTURE TODO: a shorthand will become available through the AVS interface in the future + avsId Int -- primary key from avs + prefersPostal Bool default=false -- new company users prefers letters by post instead of email + postAddress StoredMarkup Maybe -- default company postal address UniqueCompanyName name UniqueCompanyShorthand shorthand + -- UniqueCompanyAvsId avsId -- should be the case, unclear if enforcing works here, since we cannot query avs by company id Primary shorthand -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand } deriving Ord Eq Show Generic diff --git a/package.yaml b/package.yaml index 7baa68f55..18b8c4014 100644 --- a/package.yaml +++ b/package.yaml @@ -255,8 +255,7 @@ ghc-options: - -fno-warn-partial-type-signatures - -fno-max-relevant-binds - -j1 - - -freduction-depth=0 - - -split-sections + - -freduction-depth=0 when: - condition: flag(pedantic) ghc-options: diff --git a/src/Application.hs b/src/Application.hs index 3029ba0ab..0c3024a6e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -133,6 +133,7 @@ import Handler.Info import Handler.Help import Handler.Profile import Handler.Users +import Handler.Users.Add import Handler.Admin import Handler.Term import Handler.School diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 80225946f..0de5653cf 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -35,7 +35,7 @@ import qualified Data.ByteString.Base64 as Base64 import Data.Aeson hiding (Result(..)) -import Handler.Users.Add as Handler.Users +-- import Handler.Users.Add as Handler.Users import qualified Data.Conduit.List as C @@ -502,7 +502,7 @@ postAdminUserR uuid = do Just () -> do runDBJobs $ do update uid [ UserAuthentication =. AuthLDAP ] - queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication + queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid addMessageI Success MsgAuthLDAPConfigured redirect $ AdminUserR uuid @@ -514,7 +514,7 @@ postAdminUserR uuid = do -> do runDBJobs $ do update uid [ UserAuthentication =. AuthPWHash "" ] - queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication + queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid queueDBJob $ JobSendPasswordReset uid addMessageI Success MsgAuthPWHashConfigured diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 366cd43c2..9aae6137c 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -3,146 +3,58 @@ -- 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 + ( getAdminUserAddR, postAdminUserAddR ) where import Import +import Utils.Users 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 - , aufBirthday :: Maybe Day - , 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 :: Maybe AddUserData -> Form AddUserData 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 dayField (fslI MsgAdminUserBirthday) (aufBirthday <$> 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 - , userBirthday = aufBirthday - , 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 + $ 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) + <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth & setTooltip MsgAdminUserAuthTooltip) (audAuth <$> template <|> Just AuthKindLDAP) +-- | Like `addNewUser`, but starts background jobs and tries to notify users, if applicable (i.e. /= AuthNoLogin ) +addNewUserNotify :: AddUserData -> Handler (Maybe UserId) +addNewUserNotify aud = do + mbUid <- addNewUser aud + case mbUid of + Nothing -> return Nothing + Just uid -> runDBJobs $ do + queueDBJob $ JobSynchroniseLdapUser uid + let authKind = audAuth aud + when (authKind /= AuthKindNoLogin) $ + queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid + when (authKind == AuthKindPWHash) $ + queueDBJob $ JobSendPasswordReset uid + return $ Just uid getAdminUserAddR, postAdminUserAddR :: Handler Html getAdminUserAddR = postAdminUserAddR postAdminUserAddR = do ((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing - formResult userRes $ addNewUser >=> \case + formResult userRes $ addNewUserNotify >=> \case (Just uid) -> do addMessageI Success MsgUserAdded cID <- encrypt uid diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 555cfd12c..6808ce6e7 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -32,8 +32,8 @@ import qualified Data.CaseInsensitive as CI -- import Auth.LDAP (ldapUserPrincipalName) import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) +import Utils.Users import Handler.Utils.Company -import Handler.Users.Add import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma @@ -362,27 +362,27 @@ upsertAvsUserById api = do userPin = personCard2pin <$> pinCard fakeIdent = CI.mk $ "AVSID:" <> tshow api fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo - newUsr = AdminUserForm - { aufTitle = Nothing - , aufFirstName = avsPersonFirstName - , aufSurname = avsPersonLastName - , aufDisplayName = avsPersonFirstName <> " " <> avsPersonLastName - , aufDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) - , aufMatriculation = Nothing - , aufSex = Nothing - , aufBirthday = Nothing - , aufMobile = Nothing - , aufTelephone = Nothing - , aufFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo - , aufFDepartment = Nothing - , aufPostAddress = userFirmAddr - , aufPrefersPostal = True - , aufPinPassword = userPin - , aufEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) - , aufIdent = fakeIdent -- use AvsPersonId instead - , aufAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known + newUsr = AddUserData + { audTitle = Nothing + , audFirstName = avsPersonFirstName + , audSurname = avsPersonLastName + , audDisplayName = avsPersonFirstName <> " " <> avsPersonLastName + , audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) + , audMatriculation = Nothing + , audSex = Nothing + , audBirthday = Nothing + , audMobile = Nothing + , audTelephone = Nothing + , audFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo + , audFDepartment = Nothing + , audPostAddress = userFirmAddr + , audPrefersPostal = True + , audPinPassword = userPin + , audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) + , audIdent = fakeIdent -- use AvsPersonId instead + , audAuth = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known } - mbUid <- addNewUserNoNotfication newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe + mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe whenIsJust mbUid $ \uid -> runDB $ do now <- liftIO getCurrentTime insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo diff --git a/src/Handler/Utils/Company.hs b/src/Handler/Utils/Company.hs index 9d55090a0..ad9b9e1a1 100644 --- a/src/Handler/Utils/Company.hs +++ b/src/Handler/Utils/Company.hs @@ -32,14 +32,14 @@ upsertCompany cName = Nothing -> do let cShort = companyShorthandFromName cName cShort' <- findShort cName' $ CI.mk cShort - let compy = Company cName' cShort' + let compy = Company cName' cShort' 0 False Nothing -- TODO either entityKey id <$> insertBy compy where findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand findShort fna fsh = aux 0 where aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in - checkUnique (Company fna fsh') >>= \case + checkUnique (Company fna fsh' 0 False Nothing) >>= \case Nothing -> return fsh' _other -> aux (n+1) diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index aa0246917..01991de25 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -87,7 +87,7 @@ getPostalAddress User{..} | otherwise = Nothing --- | DEPRECATED, use Handler.Utis.Avs. updateReceivers instead +-- | DEPRECATED, use Handler.Utils.Avs.updateReceivers instead -- Return Entity User and all Supervisors with rerouteNotifications as well as -- a boolean indicating if the user is own supervisor with rerouteNotifications getReceivers :: UserId -> DB (Entity User, [Entity User], Bool) diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs index 5296dd84e..b89e45c82 100644 --- a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs @@ -19,8 +19,8 @@ import Jobs.Handler.SendNotification.Utils import Text.Hamlet -- import qualified Data.CaseInsensitive as CI -dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Handler () -dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = userMailT jRecipient $ do +dispatchNotificationUserAuthModeUpdate :: UserId -> UserId -> Handler () +dispatchNotificationUserAuthModeUpdate nUser jRecipient = userMailT jRecipient $ do User{..} <- liftHandler . runDB $ getJust nUser replaceMailHeader "Auto-Submitted" $ Just "auto-generated" setSubjectI MsgMailSubjectUserAuthModeUpdate diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index bbe8fff4f..7aa1cfd0b 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -129,7 +129,7 @@ data Notification | NotificationCorrectionsNotDistributed { nSheet :: SheetId } | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) } | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction } - | NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } + | NotificationUserAuthModeUpdate { nUser :: UserId } | NotificationExamRegistrationActive { nExam :: ExamId } | NotificationExamRegistrationSoonInactive { nExam :: ExamId } | NotificationExamDeregistrationSoonInactive { nExam :: ExamId } diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 4f6d018d2..e43c45215 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -43,6 +43,7 @@ import Handler.Utils.Users import Handler.Utils.DateTime import Handler.Utils.Mail import Handler.Utils.Widgets (nameHtml') +import Handler.Utils.Avs (updateReceivers) import Jobs.Handler.SendNotification.Utils -- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? @@ -413,7 +414,7 @@ instance MDLetter LetterRenewQualificationF where sendEmailOrLetter :: (MDLetter l) => UserId -> l -> Handler Bool sendEmailOrLetter recipient letter = do - (underling, receivers, undercopy) <- runDB $ getReceivers recipient + (underling, receivers, undercopy) <- updateReceivers recipient let tmpl = getTemplate $ pure letter pjid = getPJId letter -- Below are only needed if sent by email diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs new file mode 100644 index 000000000..2629aaba5 --- /dev/null +++ b/src/Utils/Users.hs @@ -0,0 +1,100 @@ +-- SPDX-FileCopyrightText: 2022 Steffen Jost +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-unused-top-binds #-} + +module Utils.Users + ( AuthenticationKind(..) + , AddUserData(..) + , addNewUser + ) where + +import Import + +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 + +mkAuthMode :: AuthenticationKind -> AuthenticationMode +mkAuthMode AuthKindLDAP = AuthLDAP +mkAuthMode AuthKindPWHash = AuthPWHash "" +mkAuthMode AuthKindNoLogin = AuthNoLogin + +{- +classifyAuth :: AuthenticationMode -> AuthenticationKind +classifyAuth AuthLDAP = AuthKindLDAP +classifyAuth AuthPWHash{} = AuthKindPWHash +classifyAuth AuthNoLogin = AuthKindNoLogin +-} + +data AddUserData = AddUserData + { audTitle :: Maybe Text + , audFirstName :: Text + , audSurname :: UserSurname + , audDisplayName :: UserDisplayName + , audDisplayEmail :: UserEmail + , audMatriculation :: Maybe UserMatriculation + , audSex :: Maybe Sex + , audBirthday :: Maybe Day + , audMobile :: Maybe Text + , audTelephone :: Maybe Text + , audFPersonalNumber :: Maybe Text + , audFDepartment :: Maybe Text + , audPostAddress :: Maybe StoredMarkup + , audPrefersPostal :: Bool + , audPinPassword :: Maybe Text + , audEmail :: UserEmail + , audIdent :: UserIdent + , audAuth :: AuthenticationKind + } + +-- | Adds a new user to database, no background jobs are scheduled, no notifications send +addNewUser :: AddUserData -> Handler (Maybe UserId) +addNewUser AddUserData{..} = do + now <- liftIO getCurrentTime + UserDefaultConf{..} <- getsYesod $ view _appUserDefaults + let + newUser = User + { userIdent = audIdent + , 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 = audFPersonalNumber + , userLastAuthentication = Nothing + , userEmail = audEmail + , userDisplayName = audDisplayName + , userDisplayEmail = audDisplayEmail + , userFirstName = audFirstName + , userSurname = audSurname + , userTitle = audTitle + , userSex = audSex + , userBirthday = audBirthday + , userMobile = audMobile + , userTelephone = audTelephone + , userCompanyPersonalNumber = audFPersonalNumber + , userCompanyDepartment = audFDepartment + , userPostAddress = audPostAddress + , userPrefersPostal = audPrefersPostal + , userPinPassword = audPinPassword + , userMatrikelnummer = audMatriculation + , userAuthentication = mkAuthMode audAuth + } + runDB $ insertUnique newUser \ No newline at end of file diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 31a787ba2..9de3b3292 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -475,11 +475,11 @@ fillDb = do I am aware that violations in the form plagiarism or collaboration with third parties will lead to expulsion from the course. |] } - fraportAg <- insert' $ Company "Fraport AG" "Fraport" - _fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" - nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" - _ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" - bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" + fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 False Nothing + _fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" 2 False Nothing -- TODO: better testcases + nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False Nothing + _ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing + bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing void . insert' $ UserCompany jost fraportAg True void . insert' $ UserCompany svaupel nice True void . insert' $ UserCompany gkleen nice False