From 315eedd1bc74be2f97ce80ea3160b31e13da2ed6 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 12:47:35 +0000 Subject: [PATCH 1/2] chore(users): allow admins to change foreign emails without confirmation --- src/Handler/Profile.hs | 12 +++++++----- src/Handler/Utils.hs | 4 ++++ 2 files changed, 11 insertions(+), 5 deletions(-) diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 39730ffd5..3dde9b54d 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -102,7 +102,6 @@ instance RenderMessage UniWorX NotificationTriggerKind where where mr = renderMessage f ls - makeSettingForm :: Maybe SettingsForm -> Form SettingsForm makeSettingForm template html = do MsgRenderer mr <- getMsgRenderer @@ -169,7 +168,7 @@ schoolsForm template = formToAForm $ schoolsFormView =<< renderWForm FormStandar notificationForm :: Maybe NotificationSettings -> AForm Handler NotificationSettings notificationForm template = wFormToAForm $ do mbUid <- liftHandler maybeAuthId - isAdmin <- lift . lift $ hasReadAccessTo AdminR + isAdmin <- checkAdmin let sectionIsHidden :: NotificationTriggerKind -> DB Bool @@ -376,7 +375,7 @@ validateSettings User{..} = do let pinBad = validCmdArgument =<< userPinPassword' pinMinChar = 5 pinLength = maybe 0 length userPinPassword' - pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else liftHandler $ hasReadAccessTo AdminR -- admins are allowed to ignore pin requirements + pinOk <- if userPrefersPostal' || pinMinChar <= pinLength then pure True else checkAdmin -- admins are allowed to ignore pin requirements whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk guardValidation (MsgPDFPasswordTooShort pinMinChar) pinOk @@ -450,9 +449,12 @@ serveProfileR (uid, user@User{..}) = do formResult res $ \SettingsForm{..} -> do now <- liftIO getCurrentTime + isAdmin <- checkAdmin + thisUser <- fromMaybe uid <$> maybeAuthId + let changeEmailByUser = userDisplayEmail /= stgDisplayEmail && (not isAdmin || thisUser == uid) runDBJobs $ do update uid $ - [ UserDisplayEmail =. stgDisplayEmail | userDisplayEmail == stgDisplayEmail ] ++ -- Note that DisplayEmail changes must be confirmed, see 472 + [ UserDisplayEmail =. stgDisplayEmail | not changeEmailByUser ] ++ -- DisplayEmail changes by Users must be confirmed, see 480 below [ UserPostLastUpdate =. Just now | userPostAddress /= stgPostAddress ] ++ [ UserDisplayName =. stgDisplayName , UserMaxFavourites =. stgMaxFavourites @@ -472,7 +474,7 @@ serveProfileR (uid, user@User{..}) = do , UserExamOfficeGetLabels =. (stgExamOfficeSettings & eosettingsGetLabels) ] updateFavourites Nothing - when (stgDisplayEmail /= userDisplayEmail) $ do + when changeEmailByUser $ do queueDBJob $ JobChangeUserDisplayEmail uid stgDisplayEmail addMessageI Info $ MsgUserDisplayEmailChangeSent stgDisplayEmail let diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index d13be8cee..2460eb65d 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -38,6 +38,10 @@ import Handler.Utils.Term as Handler.Utils import Control.Monad.Logger +-- | default check if the user an active admin +checkAdmin :: (MonadHandler m, MonadAP (HandlerFor (HandlerSite m) )) => m Bool +checkAdmin = liftHandler $ hasReadAccessTo AdminR + -- | Prefix a message with a short course id, -- eg. for window title bars, etc. From 9ca9c38830060dc73722a2da796280bbfa34115f Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Tue, 24 Oct 2023 14:55:55 +0000 Subject: [PATCH 2/2] chore(users): allow multiple filter criteria for avs no and personal no --- .../utils/table_column/de-de-formal.msg | 2 +- messages/uniworx/utils/table_column/en-eu.msg | 2 +- src/Database/Esqueleto/Utils.hs | 13 ++++- src/Handler/PrintCenter.hs | 6 +-- src/Handler/Users.hs | 50 ++++++++----------- 5 files changed, 39 insertions(+), 34 deletions(-) diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index fdf42b885..86b07953e 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -16,7 +16,7 @@ TableTerm !ident-ok: Jahr TableCourseSchool: Bereich TableSubmissionGroup: Feste Abgabegruppe TableNoSubmissionGroup: Keine feste Abgabegruppe -TableMatrikelNr: AVS Nr +TableMatrikelNr: AVS Personennummer TableSex: Geschlecht TableBirthday: Geburtsdatum TableSchool: Bereich diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index b4fe83d34..8a9c79bf8 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -16,7 +16,7 @@ TableTerm: Year TableCourseSchool: Department TableSubmissionGroup: Registered submission group TableNoSubmissionGroup: No registered submission group -TableMatrikelNr: AVS No +TableMatrikelNr: AVS person no TableSex: Sex TableBirthday: Birthday TableSchool: Department diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 70cdaaecc..139e955e1 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -24,7 +24,7 @@ module Database.Esqueleto.Utils , mkContainsFilter, mkContainsFilterWith , mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus , mkDayFilter, mkDayFilterFrom, mkDayFilterTo - , mkExistsFilter + , mkExistsFilter, mkExistsFilterWithComma , anyFilter, allFilter , ascNullsFirst, descNullsLast , orderByList @@ -421,6 +421,17 @@ mkExistsFilter query row criterias | Set.null criterias = true | otherwise = any (E.exists . query row) $ Set.toList criterias +mkExistsFilterWithComma :: PathPiece a + => (Text -> a) + -> (t -> a -> E.SqlQuery ()) + -> t + -> Set.Set Text + -> E.SqlExpr (E.Value Bool) +mkExistsFilterWithComma cast query row (foldMap commaSeparatedText -> criterias) + | Set.null criterias = true + | otherwise = any (E.exists . query row) (cast <$> Set.toList criterias) + + -- | Combine several filters, using logical or anyFilter :: Foldable f => f (t -> cs -> E.SqlExpr (E.Value Bool)) diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 083d8572d..6be31bf20 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -225,9 +225,9 @@ mkPJTable = do dbtFilter = mconcat [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) , single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent)) - , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) - , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) - --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + , single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename)) + , single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) + --, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName)) , single ("sender" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to querySender) (E.?. UserDisplayName)) , single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName)) diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index d72bdc9ac..d856a29c4 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -101,7 +101,7 @@ postUsersR = do (AdminUserR <$> encrypt uid) (nameWidget userDisplayName userSurname) , sortable (Just "matriculation") (i18nCell MsgTableMatrikelNr) $ \DBRow{ dbrOutput = entUsr } -> cellHasMatrikelnummerLinked entUsr - , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" + , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do -- why does sqlCell not work here? Mismatch "YesodDB UniWorX" and "RWST (Maybe (Env,FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerFor UniWorX" companies' <- liftHandler . runDB . E.select $ E.from $ \(usrComp `E.InnerJoin` comp) -> do E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid @@ -265,15 +265,9 @@ postUsersR = do Just needle -> (E.castString (user E.^. UserEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) E.||. (E.castString (user E.^. UserDisplayEmail) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)) ) - , ( "matriculation", FilterColumn $ \user (criteria :: Set.Set Text) -> if - | Set.null criteria -> E.true - | otherwise -> E.any (\c -> user E.^. UserMatrikelnummer `E.hasInfix` E.val c) criteria - ) - , ( "personal-number", FilterColumn $ \user (criteria :: Set.Set Text) -> if - | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? - | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria - ) - , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if + , ( "personal-number" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserCompanyPersonalNumber)) + , ( "matriculation" , FilterColumn . E.mkContainsFilterWithComma Just $ (E.^. UserMatrikelnummer)) -- allows partial matches + , ( "company-department", FilterColumn $ \user (criteria :: Set.Set Text) -> if -- exact filter on table UserAvs | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still? | otherwise -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria ) @@ -312,12 +306,12 @@ postUsersR = do E.where_ $ (spvr E.^. UserSupervisorUser E.==. user E.^.UserId) E.&&. E.any (E.hasInfix (usrSpvr E.^. UserDisplayName)) (E.val <$> Set.toList criteria) ) - , ( "avs-number", FilterColumn $ E.mkExistsFilter $ \user criterion -> - E.from $ \usrAvs -> -- do - E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser - E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. - (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) - ) + -- , ( "avs-number", FilterColumn $ E.mkExistsFilterWithComma CI.mk $ \user criterion -> -- note that this is an exact filter + -- E.from $ \usrAvs -> -- do + -- E.where_ $ user E.^. UserId E.==. usrAvs E.^. UserAvsUser + -- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==. + -- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ) + -- ) , ( "is-supervisor", FilterColumn $ \user criterion -> case criterion of Last (Just True) -> E.exists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor Last (Just False) -> E.notExists . E.from $ \usrSpr -> E.where_ $ user E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor @@ -325,19 +319,19 @@ postUsersR = do ) ] , dbtFilterUI = \mPrev -> mconcat - [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) - , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) - , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) - -- , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr) - , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber) - , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo) - , prismAForm (singletonFilter "company-department" ) mPrev $ aopt textField (fslI MsgCompanyDepartment) - , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) - , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + [ prismAForm (singletonFilter "user-search") mPrev $ aopt textField (fslI MsgName) + , prismAForm (singletonFilter "user-ident") mPrev $ aopt textField (fslI MsgAdminUserIdent) + , prismAForm (singletonFilter "user-email") mPrev $ aopt textField (fslI MsgAdminUserEmail) + , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber & setTooltip MsgTableFilterCommaPlus) + , prismAForm (singletonFilter "matriculation") mPrev $ aopt matriculationField (fslI MsgTableMatrikelNr & setTooltip MsgTableFilterCommaPlus) -- contains filter on UserMatrikelnummer + -- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo & setTooltip MsgTableFilterCommaPlus) -- exact filter on table UserAvs + , prismAForm (singletonFilter "company-department") mPrev $ aopt textField (fslI MsgCompanyDepartment) + , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany) + , prismAForm (singletonFilter "user-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor) - , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) - , prismAForm (singletonFilter "school") mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool) - , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) + , prismAForm (singletonFilter "auth-ldap" . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) + , prismAForm (singletonFilter "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = DBParamsForm