fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

chore: refactor to fix circular depenency, update receivers before sending, improve company model

Browse Source
This commit is contained in:
Steffen Jost 2023-01-19 17:59:58 +01:00
parent 929cdb0e4a
commit ad4fbc41c6
13 changed files with 183 additions and 168 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
models/company.model
View File

@ -4,13 +4,15 @@
-- Description of companies associated with users -- Description of companies associated with users
Company Company
name CompanyName -- == (CI Text) 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 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 -- primary key from avs
-- avsId Int -- FUTURE TODO: once this number becomes available through AVS interface; this could be the primary key prefersPostal Bool default=false -- new company users prefers letters by post instead of email
postAddress StoredMarkup Maybe -- default company postal address
UniqueCompanyName name UniqueCompanyName name
UniqueCompanyShorthand shorthand 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 } Primary shorthand -- newtype Key Company = CompanyKey { unSchoolKey :: CompanyShorthand }
deriving Ord Eq Show Generic deriving Ord Eq Show Generic

3
package.yaml
View File

@ -255,8 +255,7 @@ ghc-options:
- -fno-warn-partial-type-signatures - -fno-warn-partial-type-signatures
- -fno-max-relevant-binds - -fno-max-relevant-binds
- -j1 - -j1
- -freduction-depth=0 - -freduction-depth=0
- -split-sections
when: when:
- condition: flag(pedantic) - condition: flag(pedantic)
ghc-options: ghc-options:

1
src/Application.hs
View File

@ -133,6 +133,7 @@ import Handler.Info
import Handler.Help import Handler.Help
import Handler.Profile import Handler.Profile
import Handler.Users import Handler.Users
import Handler.Users.Add
import Handler.Admin import Handler.Admin
import Handler.Term import Handler.Term
import Handler.School import Handler.School

6
src/Handler/Users.hs
View File

@ -35,7 +35,7 @@ import qualified Data.ByteString.Base64 as Base64
import Data.Aeson hiding (Result(..)) 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 import qualified Data.Conduit.List as C
@ -502,7 +502,7 @@ postAdminUserR uuid = do
Just () -> do Just () -> do
runDBJobs $ do runDBJobs $ do
update uid [ UserAuthentication =. AuthLDAP ] update uid [ UserAuthentication =. AuthLDAP ]
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
addMessageI Success MsgAuthLDAPConfigured addMessageI Success MsgAuthLDAPConfigured
redirect $ AdminUserR uuid redirect $ AdminUserR uuid
@ -514,7 +514,7 @@ postAdminUserR uuid = do
-> do -> do
runDBJobs $ do runDBJobs $ do
update uid [ UserAuthentication =. AuthPWHash "" ] update uid [ UserAuthentication =. AuthPWHash "" ]
queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid userAuthentication queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
queueDBJob $ JobSendPasswordReset uid queueDBJob $ JobSendPasswordReset uid
addMessageI Success MsgAuthPWHashConfigured addMessageI Success MsgAuthPWHashConfigured

162
src/Handler/Users/Add.hs
View File

@ -3,146 +3,58 @@
-- SPDX-License-Identifier: AGPL-3.0-or-later -- SPDX-License-Identifier: AGPL-3.0-or-later
module Handler.Users.Add module Handler.Users.Add
( getAdminUserAddR, postAdminUserAddR ( getAdminUserAddR, postAdminUserAddR
, AdminUserForm(..), AuthenticationKind(..)
, addNewUser, addNewUserNoNotfication
--, adminUserForm , classifyAuth, mkAuthMode -- no longer needed elsewhere
) where ) where
import Import import Import
import Utils.Users
import Handler.Utils import Handler.Utils
import Jobs import Jobs
data AdminUserForm = AdminUserForm adminUserForm :: Maybe AddUserData -> Form AddUserData
{ 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 template = renderAForm FormStandard adminUserForm template = renderAForm FormStandard
$ AdminUserForm $ AddUserData
<$> aopt (textField & cfStrip) (fslI MsgAdminUserTitle) (aufTitle <$> template) <$> aopt (textField & cfStrip) (fslI MsgAdminUserTitle) (audTitle <$> template)
<*> areq (textField & cfStrip) (fslI MsgAdminUserFirstName) (aufFirstName <$> template) <*> areq (textField & cfStrip) (fslI MsgAdminUserFirstName) (audFirstName <$> template)
<*> areq (textField & cfStrip) (fslI MsgAdminUserSurname) (aufSurname <$> template) <*> areq (textField & cfStrip) (fslI MsgAdminUserSurname) (audSurname <$> template)
<*> areq (textField & cfStrip) (fslI MsgAdminUserDisplayName) (aufDisplayName <$> template) <*> areq (textField & cfStrip) (fslI MsgAdminUserDisplayName) (audDisplayName <$> template)
<*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (aufDisplayEmail <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserDisplayEmail) (audDisplayEmail <$> template)
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (aufMatriculation <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserMatriculation) (audMatriculation <$> template)
<*> aopt (selectField optionsFinite) (fslI MsgAdminUserSex) (aufSex <$> template) <*> aopt (selectField optionsFinite) (fslI MsgAdminUserSex) (audSex <$> template)
<*> aopt dayField (fslI MsgAdminUserBirthday) (aufBirthday <$> template) <*> aopt dayField (fslI MsgAdminUserBirthday) (audBirthday <$> template)
<*> aopt (textField & cfStrip) (fslI MsgAdminUserMobile) (aufMobile <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserMobile) (audMobile <$> template)
<*> aopt (textField & cfStrip) (fslI MsgAdminUserTelephone) (aufTelephone <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserTelephone) (audTelephone <$> template)
<*> aopt (textField & cfStrip) (fslI MsgAdminUserFPersonalNumber) (aufFPersonalNumber <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserFPersonalNumber) (audFPersonalNumber <$> template)
<*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (aufFDepartment <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserFDepartment) (audFDepartment <$> template)
<*> aopt htmlField (fslI MsgAdminUserPostAddress) (aufPostAddress <$> template) <*> aopt htmlField (fslI MsgAdminUserPostAddress) (audPostAddress <$> template)
<*> areq checkBoxField (fslI MsgAdminUserPrefersPostal) (aufPrefersPostal <$> template) <*> areq checkBoxField (fslI MsgAdminUserPrefersPostal) (audPrefersPostal <$> template)
<*> aopt (textField & cfStrip) (fslI MsgAdminUserPinPassword) (aufPinPassword <$> template) <*> aopt (textField & cfStrip) (fslI MsgAdminUserPinPassword) (audPinPassword <$> template)
<*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (aufEmail <$> template) <*> areq (emailField & cfCI) (fslI MsgAdminUserEmail) (audEmail <$> template)
<*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (aufIdent <$> template) <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent) (audIdent <$> template)
<*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth & setTooltip MsgAdminUserAuthTooltip) (aufAuth <$> template <|> Just AuthKindLDAP) <*> areq (selectField optionsFinite) (fslI MsgAdminUserAuth & setTooltip MsgAdminUserAuthTooltip) (audAuth <$> 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
-- | 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 :: Handler Html
getAdminUserAddR = postAdminUserAddR getAdminUserAddR = postAdminUserAddR
postAdminUserAddR = do postAdminUserAddR = do
((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing ((userRes, userView), userEnctype) <- runFormPost $ adminUserForm Nothing
formResult userRes $ addNewUser >=> \case formResult userRes $ addNewUserNotify >=> \case
(Just uid) -> do (Just uid) -> do
addMessageI Success MsgUserAdded addMessageI Success MsgUserAdded
cID <- encrypt uid cID <- encrypt uid

42
src/Handler/Utils/Avs.hs
View File

@ -32,8 +32,8 @@ import qualified Data.CaseInsensitive as CI
-- import Auth.LDAP (ldapUserPrincipalName) -- import Auth.LDAP (ldapUserPrincipalName)
import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException()) import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
import Utils.Users
import Handler.Utils.Company import Handler.Utils.Company
import Handler.Users.Add
import Database.Esqueleto.Experimental ((:&)(..)) import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
@ -362,27 +362,27 @@ upsertAvsUserById api = do
userPin = personCard2pin <$> pinCard userPin = personCard2pin <$> pinCard
fakeIdent = CI.mk $ "AVSID:" <> tshow api fakeIdent = CI.mk $ "AVSID:" <> tshow api
fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo fakeNo = CI.mk $ "AVSNO:" <> tshow avsPersonPersonNo
newUsr = AdminUserForm newUsr = AddUserData
{ aufTitle = Nothing { audTitle = Nothing
, aufFirstName = avsPersonFirstName , audFirstName = avsPersonFirstName
, aufSurname = avsPersonLastName , audSurname = avsPersonLastName
, aufDisplayName = avsPersonFirstName <> " " <> avsPersonLastName , audDisplayName = avsPersonFirstName <> " " <> avsPersonLastName
, aufDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , audDisplayEmail = "" -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
, aufMatriculation = Nothing , audMatriculation = Nothing
, aufSex = Nothing , audSex = Nothing
, aufBirthday = Nothing , audBirthday = Nothing
, aufMobile = Nothing , audMobile = Nothing
, aufTelephone = Nothing , audTelephone = Nothing
, aufFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo , audFPersonalNumber = avsInternalPersonalNo <$> canonical avsPersonInternalPersonalNo
, aufFDepartment = Nothing , audFDepartment = Nothing
, aufPostAddress = userFirmAddr , audPostAddress = userFirmAddr
, aufPrefersPostal = True , audPrefersPostal = True
, aufPinPassword = userPin , audPinPassword = userPin
, aufEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO) , audEmail = fakeNo -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
, aufIdent = fakeIdent -- use AvsPersonId instead , audIdent = 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 , 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 whenIsJust mbUid $ \uid -> runDB $ do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo

4
src/Handler/Utils/Company.hs
View File

@ -32,14 +32,14 @@ upsertCompany cName =
Nothing -> do Nothing -> do
let cShort = companyShorthandFromName cName let cShort = companyShorthandFromName cName
cShort' <- findShort cName' $ CI.mk cShort 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 either entityKey id <$> insertBy compy
where where
findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand findShort :: CompanyName -> CompanyShorthand -> DB CompanyShorthand
findShort fna fsh = aux 0 findShort fna fsh = aux 0
where where
aux n = let fsh' = if n==0 then fsh else fsh <> CI.mk (tshow n) in 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' Nothing -> return fsh'
_other -> aux (n+1) _other -> aux (n+1)

2
src/Handler/Utils/Users.hs
View File

@ -87,7 +87,7 @@ getPostalAddress User{..}
| otherwise | otherwise
= Nothing = 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 -- Return Entity User and all Supervisors with rerouteNotifications as well as
-- a boolean indicating if the user is own supervisor with rerouteNotifications -- a boolean indicating if the user is own supervisor with rerouteNotifications
getReceivers :: UserId -> DB (Entity User, [Entity User], Bool) getReceivers :: UserId -> DB (Entity User, [Entity User], Bool)

4
src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs
View File

@ -19,8 +19,8 @@ import Jobs.Handler.SendNotification.Utils
import Text.Hamlet import Text.Hamlet
-- import qualified Data.CaseInsensitive as CI -- import qualified Data.CaseInsensitive as CI
dispatchNotificationUserAuthModeUpdate :: UserId -> AuthenticationMode -> UserId -> Handler () dispatchNotificationUserAuthModeUpdate :: UserId -> UserId -> Handler ()
dispatchNotificationUserAuthModeUpdate nUser _nOriginalAuthMode jRecipient = userMailT jRecipient $ do dispatchNotificationUserAuthModeUpdate nUser jRecipient = userMailT jRecipient $ do
User{..} <- liftHandler . runDB $ getJust nUser User{..} <- liftHandler . runDB $ getJust nUser
replaceMailHeader "Auto-Submitted" $ Just "auto-generated" replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
setSubjectI MsgMailSubjectUserAuthModeUpdate setSubjectI MsgMailSubjectUserAuthModeUpdate

2
src/Jobs/Types.hs
View File

@ -129,7 +129,7 @@ data Notification
| NotificationCorrectionsNotDistributed { nSheet :: SheetId } | NotificationCorrectionsNotDistributed { nSheet :: SheetId }
| NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) } | NotificationUserRightsUpdate { nUser :: UserId, nOriginalRights :: Set (SchoolFunction, SchoolShorthand) }
| NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction } | NotificationUserSystemFunctionsUpdate { nUser :: UserId, nOriginalSystemFunctions :: Set SystemFunction }
| NotificationUserAuthModeUpdate { nUser :: UserId, nOriginalAuthMode :: AuthenticationMode } | NotificationUserAuthModeUpdate { nUser :: UserId }
| NotificationExamRegistrationActive { nExam :: ExamId } | NotificationExamRegistrationActive { nExam :: ExamId }
| NotificationExamRegistrationSoonInactive { nExam :: ExamId } | NotificationExamRegistrationSoonInactive { nExam :: ExamId }
| NotificationExamDeregistrationSoonInactive { nExam :: ExamId } | NotificationExamDeregistrationSoonInactive { nExam :: ExamId }

3
src/Utils/Print.hs
View File

@ -43,6 +43,7 @@ import Handler.Utils.Users
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.Mail import Handler.Utils.Mail
import Handler.Utils.Widgets (nameHtml') import Handler.Utils.Widgets (nameHtml')
import Handler.Utils.Avs (updateReceivers)
import Jobs.Handler.SendNotification.Utils import Jobs.Handler.SendNotification.Utils
-- import Model.Types.Markup -- TODO-QSV: should this module be moved accordingly? -- 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 :: (MDLetter l) => UserId -> l -> Handler Bool
sendEmailOrLetter recipient letter = do sendEmailOrLetter recipient letter = do
(underling, receivers, undercopy) <- runDB $ getReceivers recipient (underling, receivers, undercopy) <- updateReceivers recipient
let tmpl = getTemplate $ pure letter let tmpl = getTemplate $ pure letter
pjid = getPJId letter pjid = getPJId letter
-- Below are only needed if sent by email -- Below are only needed if sent by email

100
src/Utils/Users.hs Normal file
View File

@ -0,0 +1,100 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- 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

10
test/Database/Fill.hs
View File

@ -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. 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" fraportAg <- insert' $ Company "Fraport AG" "Fraport" 1 False Nothing
_fraGround <- insert' $ Company "Fraport Ground Handling Professionals GmbH" "FraGround" _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" nice <- insert' $ Company "N*ICE Aircraft Services & Support GmbH" "N*ICE" 33 False Nothing
_ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" _ffacil <- insert' $ Company "Fraport Facility Services GmbH" "GCS" 44 False Nothing
bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" bpol <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main" "BPol" 5555 False Nothing
void . insert' $ UserCompany jost fraportAg True void . insert' $ UserCompany jost fraportAg True
void . insert' $ UserCompany svaupel nice True void . insert' $ UserCompany svaupel nice True
void . insert' $ UserCompany gkleen nice False void . insert' $ UserCompany gkleen nice False