From e9eeaca22933b9483a4bd1348292f9c298ad696a Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Wed, 1 Feb 2023 18:00:53 +0100 Subject: [PATCH] chore(avs): set qu-renewal flag; tutorial add space separated --- .../uniworx/categories/avs/de-de-formal.msg | 2 +- messages/uniworx/categories/avs/en-eu.msg | 2 +- .../courses/courses/de-de-formal.msg | 2 +- .../categories/courses/courses/en-eu.msg | 2 +- .../categories/qualification/de-de-formal.msg | 3 ++- .../categories/qualification/en-eu.msg | 1 + src/Audit/Types.hs | 9 ++++---- src/Handler/Admin/Avs.hs | 10 +++++---- src/Handler/Course/ParticipantInvite.hs | 2 +- src/Handler/SAP.hs | 2 +- src/Handler/Tutorial/Users.hs | 2 +- src/Handler/Users.hs | 4 ++-- src/Handler/Utils/Qualification.hs | 22 +++++++++++-------- src/Utils/Form.hs | 12 ++++++++++ 14 files changed, 48 insertions(+), 27 deletions(-) diff --git a/messages/uniworx/categories/avs/de-de-formal.msg b/messages/uniworx/categories/avs/de-de-formal.msg index e1c14dd4f..7a63ec25d 100644 --- a/messages/uniworx/categories/avs/de-de-formal.msg +++ b/messages/uniworx/categories/avs/de-de-formal.msg @@ -28,4 +28,4 @@ RevokeUnknownLicencesFail: Nicht alle AVS Fahrberechtigungen unbekannter Fahrer AvsCommunicationError: AVS Schnittstelle lieferte einen unerwarteten Fehler. LicenceTableChangeAvs: Im AVS ändern LicenceTableGrantFDrive: In FRADrive erteilen -LicenceTableRevokeFDrive: In FRADrive entziehen \ No newline at end of file +LicenceTableRevokeFDrive: In FRADrive zum Vortag entziehen \ No newline at end of file diff --git a/messages/uniworx/categories/avs/en-eu.msg b/messages/uniworx/categories/avs/en-eu.msg index 7499244f6..91efb95f9 100644 --- a/messages/uniworx/categories/avs/en-eu.msg +++ b/messages/uniworx/categories/avs/en-eu.msg @@ -28,4 +28,4 @@ RevokeUnknownLicencesFail: Not all AVS driving licences of unknown drivers could AvsCommunicationError: AVS interface returned an unexpected error. LicenceTableChangeAvs: Change in AVS LicenceTableGrantFDrive: Grant in FRADrive -LicenceTableRevokeFDrive: Revoke in FRADrive +LicenceTableRevokeFDrive: Revoke yesterday in FRADrive diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index d18a54779..6d349743c 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 Ausweiskartennummer inklusive Punkt, Fraport Personalnummer oder Email angeben. Mehrere Personen bitte mit Komma getrennt angeben. +CourseParticipantsRegisterUsersFieldTip: Bitte Ausweiskartennummer inklusive Punkt, Fraport Personalnummer oder Email angeben. Mehrere Personen bitte mit Komma oder Leerzeichen trennen. 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 2bde12186..b2d0a823d 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 id card no (including dot), Fraport personnel number or email. Please separate multiple entries with commas. +CourseParticipantsRegisterUsersFieldTip: Please enter id card no (including dot), Fraport personnel number or email. Please separate multiple entries with comma or space. 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/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 4c3310606..c0e62cfcb 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -23,7 +23,8 @@ TableQualificationFirstHeld: Erstmalig TableQualificationBlockedDue: Suspendiert TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend außer Kraft gesetzt und warum wurde dies veranlasst? TableQualificationNoRenewal: Storniert -TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versand, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. +TableQualificationNoRenewalTooltip: Es wird keine Benachrichtigung mehr versendet, wenn diese Qualifikation ablaufen sollte. Die Qualifikation kann noch gültig sein. +QualificationUserNoRenewal: Läuft ohne Benachrichtigung aus LmsUser: Inhaber TableLmsEmail: E-Mail TableLmsIdent: LMS Identifikation diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 00a6115d3..3eaae500d 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -24,6 +24,7 @@ TableQualificationBlockedDue: Suspended TableQualificationBlockedTooltip: Why and when was this qualification temporarily suspended? TableQualificationNoRenewal: Canceled TableQualificationNoRenewalTooltip: No renewal notifications will be send for this qualification upon expiry. The qualification may still be valid. +QualificationUserNoRenewal: Expires without further notification LmsUser: Licensee TableLmsEmail: Email TableLmsIdent: LMS Identifier diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index d01835b7b..fcc6a1f8f 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -199,10 +199,11 @@ data Transaction } | TransactionQualificationUserEdit - { transactionQualificationUser :: QualificationUserId - , transactionQualification :: QualificationId - , transactionUser :: UserId - , transactionQualificationValidUntil :: Day + { transactionQualificationUser :: QualificationUserId + , transactionQualification :: QualificationId + , transactionUser :: UserId + , transactionQualificationValidUntil :: Day + , transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration) } | TransactionQualificationUserDelete { transactionQualificationUser :: QualificationUserId diff --git a/src/Handler/Admin/Avs.hs b/src/Handler/Admin/Avs.hs index 8c0f53cd9..3ab112505 100644 --- a/src/Handler/Admin/Avs.hs +++ b/src/Handler/Admin/Avs.hs @@ -333,8 +333,9 @@ embedRenderMessage ''UniWorX ''LicenceTableAction id data LicenceTableActionData = LicenceTableChangeAvsData | LicenceTableRevokeFDriveData --TODO: add { licenceTableChangeFDriveQId :: QualificationId to avoid lookup later - | LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId - , licenceTableChangeFDriveEnd :: Day + | LicenceTableGrantFDriveData { licenceTableChangeFDriveQId :: QualificationId + , licenceTableChangeFDriveEnd :: Day + , licenceTableChangeFDriveRenew :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) @@ -423,7 +424,7 @@ getProblemAvsSynchR = do nups <- runDB $ do qId <- getKeyBy404 $ UniqueQualificationAvsLicence $ Just alic selectedUsers <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] [] - forM_ selectedUsers $ upsertQualificationUser qId nowaday $ pred nowaday + forM_ selectedUsers $ upsertQualificationUser qId nowaday (pred nowaday) Nothing return $ length selectedUsers addMessageI Success $ MsgRevokeFraDriveLicences alic nups redirect ProblemAvsSynchR -- must be outside runDB @@ -433,7 +434,7 @@ getProblemAvsSynchR = do uas <- selectList [UserAvsPersonId <-. Set.toList apids] [] let uids = view _userAvsUser <$> uas -- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG - forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd + forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew (length uids,) <$> get404 licenceTableChangeFDriveQId addMessageI Success $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n redirect ProblemAvsSynchR -- must be outside runDB @@ -577,6 +578,7 @@ mkLicenceTable PaginationParameters{..} dbtIdent aLic apids = do else singletonMap LicenceTableGrantFDrive $ LicenceTableGrantFDriveData <$> apreq (selectField . fmap mkOptionList $ mapM qualOpt avsQualifications) (fslI MsgQualificationName) aLicQid <*> apreq dayField (fslI MsgLmsQualificationValidUntil) Nothing -- apreq?! + <*> aopt (convertField not not (boolField . Just $ SomeMessage MsgBoolIrrelevant)) (fslI MsgQualificationUserNoRenewal) Nothing ] dbtParams = DBParamsForm { dbParamsFormMethod = POST diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 0e079ec23..de3941e78 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -143,7 +143,7 @@ postCAddUserR tid ssh csh = do ((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime - auReqUsers <- wreq (textField & cfCommaSeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty + auReqUsers <- wreq (textField & cfAnySeparatedSet) (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 ( fslI MsgCourseParticipantsRegisterTutorialOption ) diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 4e8b98ebc..7fd0bd7b0 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -57,7 +57,7 @@ instance ToNamedRecord SapUserTableCsv where -- 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 - , readMay persNo > Just 0 -- filter E-accounts for SAP export + , readMay persNo > Just (0::Int) -- filter E-accounts for SAP export , let res = SapUserTableCsv { csvSUTpersonalNummer = persNo , csvSUTqualifikation = sapId diff --git a/src/Handler/Tutorial/Users.hs b/src/Handler/Tutorial/Users.hs index 325a075a1..912d0c886 100644 --- a/src/Handler/Tutorial/Users.hs +++ b/src/Handler/Tutorial/Users.hs @@ -100,7 +100,7 @@ postTUsersR tid ssh csh tutn = do (TutorialUserGrantQualificationData{..}, selectedUsers) -> do -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime today <- utctDay <$> liftIO getCurrentTime - runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil + runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing addMessageI Success . MsgTutorialUserGrantedQualification $ Set.size selectedUsers redirect $ CTutorialR tid ssh csh tutn TUsersR (TutorialUserSendMailData{}, selectedUsers) -> do diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index fa83c8ce6..1ee201656 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -188,10 +188,10 @@ postUsersR = do acts = mconcat [ singletonMap UserLdapSync $ pure UserLdapSyncData , singletonMap UserAddSupervisor $ UserAddSupervisorData - <$> apopt (textField & cfCommaSeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <$> apopt (textField & cfAnySeparatedSet) (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 (textField & cfAnySeparatedSet) (fslI MsgMppSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just True) , singletonMap UserRemoveSupervisor $ pure UserRemoveSupervisorData ] diff --git a/src/Handler/Utils/Qualification.hs b/src/Handler/Utils/Qualification.hs index 408ed063f..cb9700ad1 100644 --- a/src/Handler/Utils/Qualification.hs +++ b/src/Handler/Utils/Qualification.hs @@ -11,23 +11,27 @@ module Handler.Utils.Qualification import Import -upsertQualificationUser :: QualificationId -> Day -> Day -> UserId -> DB () -upsertQualificationUser qualificationUserQualification today qualificationUserValidUntil qualificationUserUser = do +upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () +upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do Entity quid _ <- upsert QualificationUser - { qualificationUserLastRefresh = today - , qualificationUserFirstHeld = today + { qualificationUserFirstHeld = qualificationUserLastRefresh , qualificationUserBlockedDue = Nothing - , qualificationUserScheduleRenewal = True + , qualificationUserScheduleRenewal = fromMaybe True mbScheduleRenewal , .. } - [ QualificationUserValidUntil =. qualificationUserValidUntil - , QualificationUserLastRefresh =. today - , QualificationUserBlockedDue =. Nothing - ] + ( + [ QualificationUserScheduleRenewal =. scheduleRenewal | Just scheduleRenewal <- [mbScheduleRenewal] + ] ++ + [ QualificationUserValidUntil =. qualificationUserValidUntil + , QualificationUserLastRefresh =. qualificationUserLastRefresh + , QualificationUserBlockedDue =. Nothing + ] + ) audit TransactionQualificationUserEdit { transactionQualificationUser = quid , transactionQualification = qualificationUserQualification , transactionUser = qualificationUserUser , transactionQualificationValidUntil = qualificationUserValidUntil + , transactionQualificationScheduleRenewal = mbScheduleRenewal } \ No newline at end of file diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index e9c7203c9..f5d8af0f3 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -22,6 +22,7 @@ import Utils.Lens import Text.Blaze (Markup) import qualified Text.Blaze.Internal as Blaze (null) import qualified Data.Text as T +import qualified Data.Char as C import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI @@ -849,6 +850,17 @@ 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) +cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text) +cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList) + where anySeparator :: Char -> Bool + anySeparator c = C.isSeparator c || c == ',' || c == ';' + +-- -- TODO: consider using package ordered-containers? +-- cfAnySeparatedList :: (Functor m) => Field m Text -> Field m [Text] +-- cfAnySeparatedList = guardField (not . null) . convertField (mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", ") +-- where anySeparator :: Char -> Bool +-- anySeparator c = C.isSeparator c || c == ',' || c == ';' + isoField :: Functor m => AnIso' a b -> Field m a -> Field m b isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso)