From 771bcd699323ab0437e34297a2aeeb30415f9cbc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 13 Jan 2023 19:04:36 +0100 Subject: [PATCH] chore(users): change supervisors in user list --- .../courses/courses/de-de-formal.msg | 2 +- .../categories/courses/courses/en-eu.msg | 2 +- .../send/send_notifications/de-de-formal.msg | 4 +- .../send/send_notifications/en-eu.msg | 4 +- .../uniworx/categories/user/de-de-formal.msg | 4 +- messages/uniworx/categories/user/en-eu.msg | 6 ++- src/Handler/Admin/Avs.hs | 4 +- src/Handler/Course/ParticipantInvite.hs | 4 -- src/Handler/SAP.hs | 2 +- src/Handler/Users.hs | 45 ++++++++++++++++--- src/Handler/Users/Add.hs | 4 +- src/Handler/Utils/Avs.hs | 18 +++++--- src/Utils/Avs.hs | 13 +++++- src/Utils/Form.hs | 6 ++- 14 files changed, 86 insertions(+), 32 deletions(-) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index a1f9e46e0..33a8e2f57 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -83,7 +83,7 @@ CourseParticipantsRegisterHeading: Kursteilnehmer:innen hinzufügen CourseParticipantsRegisterActionAddParticipants: Personen zum Kurs anmelden CourseParticipantsRegisterActionAddTutorialMembers: Personen zu Kurs und Übungsgruppe anmelden CourseParticipantsRegisterUsersField: Zum Kurs anzumeldende Personen -CourseParticipantsRegisterUsersFieldTip: Bitte Personalnummer angeben. Mehrere Personen bitte mit Komma getrennt angeben. +CourseParticipantsRegisterUsersFieldTip: Bitte Ausweiskartennummer inklusive Punkt, Fraport Personalnummer oder Email angeben. Mehrere Personen bitte mit Komma getrennt angeben. CourseParticipantsRegisterTutorialOption: Kursteilnehmer:innen zu Übungsgruppe anmelden? CourseParticipantsRegisterTutorialField: Übungsgruppe CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Übungsgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Übungsgruppe mit diesem Namen vorhanden, werden die Kursteilnehmenden dieser hinzugefügt. diff --git a/messages/uniworx/categories/courses/courses/en-eu.msg b/messages/uniworx/categories/courses/courses/en-eu.msg index a15538266..a15956131 100644 --- a/messages/uniworx/categories/courses/courses/en-eu.msg +++ b/messages/uniworx/categories/courses/courses/en-eu.msg @@ -83,7 +83,7 @@ CourseParticipantsRegisterHeading: Add course participants CourseParticipantsRegisterActionAddParticipants: Add course participants CourseParticipantsRegisterActionAddTutorialMembers: Add course and tutorial participants CourseParticipantsRegisterUsersField: Persons to register for course -CourseParticipantsRegisterUsersFieldTip: Please enter personal number. Please separate multiple entries with commas. +CourseParticipantsRegisterUsersFieldTip: Please enter id card no (including dot), Fraport personnel number or email. Please separate multiple entries with commas. CourseParticipantsRegisterTutorialOption: Register course participants for tutorial? CourseParticipantsRegisterTutorialField: Tutorial CourseParticipantsRegisterTutorialFieldTip: If there is no tutorial with this name, a new one will be created. If there is a tutorial with this name, the course participants will be registered for it. diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index 789af47a2..3e0070c26 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -101,4 +101,6 @@ MailSupervisorBody undername@Text supername@Text: Sie erhalten diese Nachricht, MailSupervisorCopy undermail@Text: Diese Nachricht ist eine Kopie einer Nachricht, welche an #{undermail} gesendet wurde. MailSupervisorNoCopy: Warnung: Diese Nachricht wurde nicht an den eigentlichen Empfänger versandt! Für die Weiterleitung sind alle für diesen Empfänger in FRADrive eingetragenen Ansprechpartner verantwortlich! MailSupervisedNote: Hinweis -MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet: \ No newline at end of file +MailSupervisedBody: Eine Kopie dieser Nachricht wurde auch an folgende in FRADrive eingetragene Ansprechpartner gesendet: +MailSupervisorReroute: Benachrichtigungsumleitung +MailSupervisorRerouteTooltip: Alle Benachrichtigungen werden stattdessen an alle Ansprechpartner mit Benachrichtigungsumleitung gesandt \ No newline at end of file diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index 8a0474a02..94a394d64 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -101,4 +101,6 @@ MailSupervisorBody undername supername: You receive this message, since #{supern MailSupervisorCopy undermail: This is a copy of a message originally sent to #{undermail}. MailSupervisorNoCopy: Warning: This message was not sent to the original recipient! The FRADrive registered supervisor, i.e. you, is responsible for forwarding this message to the recipient! MailSupervisedNote: Please note -MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely: \ No newline at end of file +MailSupervisedBody: A copy of this message has been sent to all supervisors registered for you in FRADrive, namely: +MailSupervisorReroute: Reroute notifications +MailSupervisorRerouteTooltip: All notification will be sent to all supervisors with notification rerouting instead \ No newline at end of file diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index 3ca1c79a8..e56ae4cff 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -93,4 +93,6 @@ UserSetSupervisor: Ansprechpartner ersetzen AuthKindLDAP: Fraport AG Kennung AuthKindPWHash: FRADrive Kennung AuthKindNoLogin: Kein Login möglich -Name !ident-ok: Name \ No newline at end of file +Name !ident-ok: Name +UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt +UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt. #{tshow bad} Ansprechpartner wurden nicht gefunden! diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 8ca26c3ba..9e55977d0 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -15,7 +15,7 @@ AdminUserMatriculation: Matriculation AdminUserSex: Sex AdminUserTelephone: Phone AdminUserMobile: Mobile -AdminUserFPersonalNumber: Personalnumber (Fraport AG only) +AdminUserFPersonalNumber: Personnel number (Fraport AG only) AdminUserFDepartment: Department AdminUserPostAddress: Postal Address AdminUserPrefersPostal: Prefers postal letters over email @@ -93,4 +93,6 @@ UserSetSupervisor: Replace supervisors AuthKindLDAP: Fraport AG account AuthKindPWHash: FRADrive account AuthKindNoLogin: No login -Name: Name \ No newline at end of file +Name: Name +UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Supervisors for #{tshow usr} Users set +UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur #{tshow spr} Supervisors for #{tshow usr} Users set. #{tshow bad} Supervisors could not be identified! diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index c5132356b..7749f8886 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -534,8 +534,8 @@ mkLicenceTable dbtIdent aLic apids = do , if aLic == AvsNoLicence then singletonMap LicenceTableRevokeFDrive $ pure LicenceTableRevokeFDriveData else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData - <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid - <*> apopt dayField (fslI MsgLmsQualificationValidUntil) Nothing + <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid + <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! ] dbtParams = DBParamsForm { dbParamsFormMethod = POST diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 99b874430..dc3575fa4 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -17,7 +17,6 @@ import qualified Data.Aeson as Aeson import qualified Data.CaseInsensitive as CI import Data.Map ((!)) import qualified Data.Map as Map -import qualified Data.Text as Text import qualified Data.Time.Zones as TZ import qualified Data.Set as Set @@ -144,9 +143,6 @@ postCAddUserR tid ssh csh = do ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - let - cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set Text) - cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . Set.toList) auReqUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty auReqTutorial <- optionalActionW ( areq (textField & cfCI) (fslI MsgCourseParticipantsRegisterTutorialField & setTooltip MsgCourseParticipantsRegisterTutorialFieldTip) (Just . CI.mk $ tshow today) ) -- TODO: use user date display setting diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 543ef0a92..cf83e6c22 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -53,7 +53,7 @@ instance ToNamedRecord SapUserTableCsv where , "Ausprägung" Csv..= csvSUTausprägung ] --- | Removes all elements containing Nothing, which should not be returend by the query anyway (only qualfications with sap id and users with internal personal number must be transmitted) +-- | Removes all elements containing Nothing, which should not be returend by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted) -- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv] sapRes2csv l = [ res | (Ex.Value (Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 9e88cd786..c1185e758 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -15,6 +15,7 @@ import Jobs import Handler.Utils import Handler.Utils.Users import Handler.Utils.Invitations +import Handler.Utils.Avs import qualified Auth.LDAP as Auth @@ -63,10 +64,19 @@ embedRenderMessage ''UniWorX ''UserAction id data UserActionData = UserLdapSyncData | UserHijack - | UserAddSupervisorData - | UserSetSupervisorData + | UserAddSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } + | UserSetSupervisorData { getActionSupervisors :: Set Text, getActionRerouteNotifications :: Bool } deriving (Eq, Ord, Read, Show, Generic, Typeable) +isNotSetSupervisor :: UserActionData -> Bool +isNotSetSupervisor UserSetSupervisorData{} = False +isNotSetSupervisor _ = True + +isActionSupervisor :: UserActionData -> Bool +isActionSupervisor UserAddSupervisorData{} = True +isActionSupervisor UserSetSupervisorData{} = True +isActionSupervisor _ = False + data AllUsersAction = AllUsersLdapSync deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable) @@ -175,9 +185,13 @@ postUsersR = do acts :: Map UserAction (AForm Handler UserActionData) acts = mconcat - [ singletonMap UserLdapSync $ pure UserLdapSyncData - , singletonMap UserAddSupervisor $ pure UserAddSupervisorData - , singletonMap UserSetSupervisor $ pure UserSetSupervisorData + [ singletonMap UserLdapSync $ pure UserLdapSyncData + , singletonMap UserAddSupervisor $ UserAddSupervisorData + <$> apopt (textField & cfCommaSeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) + , singletonMap UserSetSupervisor $ UserSetSupervisorData + <$> apopt (textField & cfCommaSeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) ] over _1 postprocess <$> dbTable psValidator DBTable @@ -315,8 +329,8 @@ postUsersR = do } formResult usersRes $ \case - (_, usersSet) - | Set.null usersSet -> do + (act, usersSet) + | Set.null usersSet && isNotSetSupervisor act -> do addMessageI Info MsgActionNoUsersSelected redirect UsersR (UserLdapSyncData, userSet) -> do @@ -325,6 +339,23 @@ postUsersR = do redirect UsersR (UserHijack, Set.minView -> Just (uid, _)) -> hijackUser uid >>= sendResponse + (act, usersSet) + | isActionSupervisor act -> do + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet upsertAvsUser $ getActionSupervisors act + let (supersFound, supersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers + users = Set.toList usersSet + nrSuperNotFound = length supersNotFound + runDB $ do + unless (isNotSetSupervisor act) $ deleteWhere [UserSupervisorUser <-. users] + putMany [UserSupervisor s u r + | let r = getActionRerouteNotifications act + , (_, Just s) <- supersFound + , u <- users + ] + if nrSuperNotFound > 0 + then addMessageI Warning $ MsgUsersChangeSupervisorsWarning (Set.size usersSet) (length supersFound) nrSuperNotFound + else addMessageI Success $ MsgUsersChangeSupervisorsSuccess (Set.size usersSet) (length supersFound) + redirect UsersR _other -> error "Should not be possible" ((allUsersRes, allUsersWgt), allUsersEnctype) <- runFormPost . identifyForm FIDAllUsersAction $ buttonForm diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 7059293c0..0c45743a7 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -83,7 +83,7 @@ addNewUserNoNotfication :: AdminUserForm -> Handler (Maybe UserId) addNewUserNoNotfication = addNewUser' False addNewUser' :: Bool -> AdminUserForm -> Handler (Maybe UserId) -addNewUser' notifyusr AdminUserForm{..} = do +addNewUser' notifyUsr AdminUserForm{..} = do now <- liftIO getCurrentTime UserDefaultConf{..} <- getsYesod $ view _appUserDefaults let @@ -128,7 +128,7 @@ addNewUser' notifyusr AdminUserForm{..} = do runDBJobs . runMaybeT $ do uid <- MaybeT $ insertUnique newUser lift . queueDBJob $ JobSynchroniseLdapUser uid - when (notifyusr && aufAuth /= AuthNoLogin) $ + when (notifyUsr && aufAuth /= AuthKindNoLogin) $ lift . queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid (newUser ^. _userAuthentication) when (aufAuth == AuthKindPWHash) $ lift . queueDBJob $ JobSendPasswordReset uid diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 8a0a546b1..f87efe660 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -289,15 +289,21 @@ getDifferingLicences (AvsResponseGetLicences licences) = do -} --- | Always update AVS Data +-- | Always update AVS Data, accepts AvsCardId (with dot), Fraport PersonalNumber or Fraport Email-Adress upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity -upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is a number, it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! +upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = upsertAvsUserByCard someid -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users! upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail try (runDB $ ldapLookupAndUpsert otherId) >>= \case Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) - Left (_err::SomeException) -> return Nothing -- TODO: ; merely for convenience, not necessary right now - _ -> return Nothing - + other -> do -- attempt to recover by trying other ids + whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all + apid <- runDB . runMaybeT $ do + let someIdent = stripCI otherId + uid <- MaybeT (getKeyBy $ UniqueEmail someIdent) + <|> MaybeT (getKeyBy $ UniqueAuthentication someIdent) + MaybeT $ view (_entityVal . _userAvsPersonId) <<$>> getBy (UniqueUserAvsUser uid) + ifMaybeM apid Nothing upsertAvsUserById + -- | Given CardNo or internal Number, retrieve UserId. Create non-existing users, if possible. Always update. -- Throws errors if the avsInterface in unavailable or the user is non-unique within external AVS DB. @@ -373,7 +379,7 @@ upsertAvsUserById api = do , 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 personal number is known + , aufAuth = 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 whenIsJust mbUid $ \uid -> runDB $ do diff --git a/src/Utils/Avs.hs b/src/Utils/Avs.hs index 1ce36fc89..78a1183b8 100644 --- a/src/Utils/Avs.hs +++ b/src/Utils/Avs.hs @@ -13,7 +13,10 @@ import qualified Data.Text as Text import Servant import Servant.Client +#ifdef DEVELOPMENT +#else import Servant.Client.Core (requestPath) +#endif import Model.Types.Avs @@ -59,6 +62,14 @@ avsQueryAllLicences = AvsQueryGetLicences $ AvsObjPersonId avsPersonIdZero mkAvsQuery :: BaseUrl -> BasicAuthData -> ClientEnv -> AvsQuery +#ifdef DEVELOPMENT +mkAvsQuery _ _ _ = AvsQuery + { avsQueryPerson = \_ -> return . Right $ AvsResponsePerson mempty + , avsQueryStatus = \_ -> return . Right $ AvsResponseStatus mempty + , avsQuerySetLicences = \_ -> return . Right $ AvsResponseSetLicences mempty + , avsQueryGetAllLicences = return . Right $ AvsResponseGetLicences mempty + } +#else mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery { avsQueryPerson = \q -> liftIO $ catch404toEmpty <$> runClientM (rawQueryPerson q) cliEnv , avsQueryStatus = \q -> liftIO $ runClientM (rawQueryStatus q) cliEnv @@ -72,7 +83,7 @@ mkAvsQuery baseUrl basicAuth cliEnv = AvsQuery catch404toEmpty (Left (FailureResponse (requestPath -> (base, _path)) (statusCode . responseStatusCode -> 404))) | baseUrl == base = Right $ AvsResponsePerson mempty -- WORKAROUND: AVS server erroneously returns 404 if no matching person could be found in its database! catch404toEmpty other = other - +#endif ----------------------- -- Utility Functions -- diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 5c630b4ce..c4e38bd5a 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -27,6 +27,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Data.Universe +import Data.List (nub, (!!)) import Data.Map.Lazy ((!)) import qualified Data.Map.Lazy as Map import qualified Data.Set as Set @@ -46,8 +47,6 @@ import Control.Monad.Catch (MonadCatch) import Control.Monad.Random.Class (uniform, uniformMay, getRandom, getRandomR, getRandomRs, weighted) -import Data.List (nub, (!!)) - import Web.PathPieces import Data.UUID hiding (toText) @@ -824,6 +823,9 @@ cfStrip = guardField (not . T.null . repack) . convertField (repack . T.strip . cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s) cfCI = convertField CI.mk CI.original +cfCommaSeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) +cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.splitOn ",") (T.intercalate ", " . Set.toList) + isoField :: Functor m => AnIso' a b -> Field m a -> Field m b isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso)