From 67f8ef754099ba578d466150456a085658d30c32 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Thu, 1 Jun 2023 09:44:13 +0000 Subject: [PATCH 1/7] chore(tutorial): sort nulls last for dates --- src/Handler/Tutorial/List.hs | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/src/Handler/Tutorial/List.hs b/src/Handler/Tutorial/List.hs index 24f2e87ee..3f0c6a48d 100644 --- a/src/Handler/Tutorial/List.hs +++ b/src/Handler/Tutorial/List.hs @@ -74,9 +74,9 @@ getCTutorialListR tid ssh csh = do linkButton mempty [whamlet|_{MsgTutorialDelete}|] [BCIsButton, BCDanger] . SomeRoute $ CTutorialR tid ssh csh tutorialName TDeleteR ] dbtSorting = Map.fromList - [ ("type" , SortColumn $ \tutorial -> tutorial E.^. TutorialType ) - , ("name" , SortColumn $ \tutorial -> tutorial E.^. TutorialName ) - , ("first-day", SortColumn $ \tutorial -> tutorial E.^. TutorialFirstDay ) + [ ("type" , SortColumn $ \tutorial -> tutorial E.^. TutorialType ) + , ("name" , SortColumn $ \tutorial -> tutorial E.^. TutorialName ) + , ("first-day", SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialFirstDay ) , ( "tutors" , SortColumn $ \tutorial -> E.subSelectMaybe . E.from $ \(tutor `E.InnerJoin` user) -> do E.on $ tutor E.^. TutorUser E.==. user E.^. UserId @@ -91,9 +91,9 @@ getCTutorialListR tid ssh csh = do , ("capacity", SortColumn $ \tutorial -> tutorial E.^. TutorialCapacity ) , ("room", SortColumn $ \tutorial -> tutorial E.^. TutorialRoom ) , ("register-group", SortColumn $ \tutorial -> tutorial E.^. TutorialRegGroup ) - , ("register-from", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) - , ("register-to", SortColumn $ \tutorial -> tutorial E.^. TutorialRegisterTo ) - , ("deregister-until", SortColumn $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) + , ("register-from" , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterFrom ) + , ("register-to" , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialRegisterTo ) + , ("deregister-until" , SortColumnNullsInv $ \tutorial -> tutorial E.^. TutorialDeregisterUntil ) ] dbtFilter = Map.empty dbtFilterUI = const mempty From a5dff16d3541a9093532063de1ad14e5e0e636bd Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 09:27:31 +0000 Subject: [PATCH 2/7] chore(fill): change tutorial template type --- test/Database/Fill.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 3fa808102..8b91824f0 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1027,7 +1027,7 @@ fillDb = do insert_ Tutorial { tutorialName = mkName "Vorlage" , tutorialCourse = c - , tutorialType = "Schulung" + , tutorialType = "Vorlage___Schulung" , tutorialCapacity = capacity , tutorialRoom = Just $ case weekDay of Monday -> "A380" From 798a4bdf0a3596049040d330637b8a7002ec370e Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 09:28:34 +0000 Subject: [PATCH 3/7] chore(lms): filter lms by qualification id --- src/Jobs/Handler/LMS.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 1795167c0..46dafb10a 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -93,16 +93,16 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act - where + where act :: YesodJobDB UniWorX () act = do identsInUseVs <- E.select $ do lui <- E.from $ - ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) + do { u <- E.from (E.table @LmsUserlist); E.where_ (u E.^. LmsUserlistQualification E.==. E.val qid); pure (u E.^. LmsUserlistIdent) } `E.union_` - ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult) ) + do { u <- E.from (E.table @LmsResult ); E.where_ (u E.^. LmsResultQualification E.==. E.val qid); pure (u E.^. LmsResultIdent) } `E.union_` - ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser) ) + do { u <- E.from (E.table @LmsUser ); E.where_ (u E.^. LmsUserQualification E.==. E.val qid); pure (u E.^. LmsUserIdent) } E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime From 88d43560ae8de1480502914d9c95d6376a3c68cc Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 09:57:02 +0000 Subject: [PATCH 4/7] fix(qualification): prevent qualification mixups --- src/Jobs/Handler/LMS.hs | 20 ++++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 46dafb10a..6e8a48f51 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -93,16 +93,16 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act - where + where act :: YesodJobDB UniWorX () act = do identsInUseVs <- E.select $ do lui <- E.from $ - do { u <- E.from (E.table @LmsUserlist); E.where_ (u E.^. LmsUserlistQualification E.==. E.val qid); pure (u E.^. LmsUserlistIdent) } + ( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all `E.union_` - do { u <- E.from (E.table @LmsResult ); E.where_ (u E.^. LmsResultQualification E.==. E.val qid); pure (u E.^. LmsResultIdent) } + ( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) ) `E.union_` - do { u <- E.from (E.table @LmsUser ); E.where_ (u E.^. LmsUserQualification E.==. E.val qid); pure (u E.^. LmsUserIdent) } + ( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) ) E.orderBy [E.asc lui] pure lui now <- liftIO getCurrentTime @@ -150,22 +150,26 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act `E.on` (\(quser :& luser) -> luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification) - E.where_ $ E.isNothing (luser E.^. LmsUserStatus) + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. luser E.^. LmsUserQualification E.==. E.val qid + E.&&. E.isNothing (luser E.^. LmsUserStatus) E.&&. E.isNothing (luser E.^. LmsUserEnded) E.&&. E.not_ (validQualification nowaday quser) pure (luser E.^. LmsUserId) nrExpired <- E.updateCount $ \luser -> do E.set luser [LmsUserStatus E.=. E.justVal (LmsExpired nowaday)] E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners) + E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort notifyInvalidDrivers <- E.select $ do quser <- E.from $ E.table @QualificationUser - E.where_ $ E.not_ (validQualification nowaday quser) - E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. E.not_ (validQualification nowaday quser) + E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) ) E.||. ( - E.isJust (quser E.^. QualificationUserBlockedDue) + E.isJust (quser E.^. QualificationUserBlockedDue) E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) )) pure (quser E.^. QualificationUserUser) From 79b45be5b67c96a00e35475cec8f8c2aea92d742 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 11:17:20 +0000 Subject: [PATCH 5/7] debug(occurrences): find error in occurrencesAddBusinessDays --- src/Handler/Utils/Occurrences.hs | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index f3412e29b..2d3aa97e2 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -51,8 +51,8 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday -occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences -occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions +occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> (Occurrences,_) +occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = (Occurrences newSchedule newExceptions,(dayDiff, offDays,loff,dgb)) where newSchedule = Set.map switchDayOfWeek occurrencesScheduled dayDiff = diffDays dayNew dayOld @@ -64,16 +64,16 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrenc switchDayOfWeek os | 0 == dayDiff `mod` 7 = os switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)} - newExceptions = snd $ Set.foldr advanceExceptions (dayDiff,mempty) occurrencesExceptions + (loff,newExceptions,dgb) = Set.foldl (flip advanceExceptions) (dayDiff,mempty,mempty) occurrencesExceptions -- we assume that instance Ord OccurrenceException is ordered chronologically - advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException) -> (Integer, Set OccurrenceException) - advanceExceptions ex (offset, acc) + advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException,_) -> (Integer, Set OccurrenceException,_) + advanceExceptions ex (offset, acc, dbg) | ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend , nd `Set.member` offDays - = advanceExceptions ex (succ offset, acc) + = advanceExceptions ex (succ offset, acc, ("skip"<>show offset) :dbg) | otherwise - = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) + = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc, show ex : dbg) where ed = dayOfOccurrenceException ex nd = addDays offset ed From b982e59b630fbdb3fe8f37c979de8e8726b78ea9 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 11:50:50 +0000 Subject: [PATCH 6/7] fix(tutorial): template moving works now --- src/Handler/Course/ParticipantInvite.hs | 3 ++- src/Handler/Utils/Occurrences.hs | 14 +++++++------- test/Database/Fill.hs | 9 +++++++-- 3 files changed, 16 insertions(+), 10 deletions(-) diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index d1b53069a..2c079fdbd 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -32,6 +32,7 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault) import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma import qualified Database.Esqueleto.Utils as E +import Utils.Occurrences type UserSearchKey = Text @@ -316,7 +317,7 @@ upsertNewTutorial cid newTutorialName newTutorialType newFirstDay = runDB $ do Course{..} <- get404 cid term <- get404 courseTerm let oldFirstDay = fromMaybe moveDay $ tutorialFirstDay <|> fst (occurrencesBounds term tutorialTime) - newTime = occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime + newTime = normalizeOccurrences $ occurrencesAddBusinessDays term (oldFirstDay, moveDay) tutorialTime dayDiff = maybe 0 (diffDays moveDay) tutorialFirstDay mvTime = fmap $ addLocalDays dayDiff newType0 = CI.mk . snd . Text.breakOnEnd tutorialTypeSeparator $ CI.original tutorialType diff --git a/src/Handler/Utils/Occurrences.hs b/src/Handler/Utils/Occurrences.hs index 2d3aa97e2..984a4b7a2 100644 --- a/src/Handler/Utils/Occurrences.hs +++ b/src/Handler/Utils/Occurrences.hs @@ -51,8 +51,8 @@ occurrencesBounds Term{..} Occurrences{..} = (Set.lookupMin occDays, Set.lookupM getOccDays :: OccurrenceSchedule -> Set Day -> Set Day getOccDays ScheduleWeekly{scheduleDayOfWeek=wday} = Set.union $ daysOfWeekBetween (termLectureStart,termLectureEnd) wday -occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> (Occurrences,_) -occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = (Occurrences newSchedule newExceptions,(dayDiff, offDays,loff,dgb)) +occurrencesAddBusinessDays :: Term -> (Day,Day) -> Occurrences -> Occurrences +occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = Occurrences newSchedule newExceptions where newSchedule = Set.map switchDayOfWeek occurrencesScheduled dayDiff = diffDays dayNew dayOld @@ -64,16 +64,16 @@ occurrencesAddBusinessDays Term{..} (dayOld, dayNew) Occurrences{..} = (Occurren switchDayOfWeek os | 0 == dayDiff `mod` 7 = os switchDayOfWeek os@ScheduleWeekly{scheduleDayOfWeek=wday} = os{scheduleDayOfWeek= toEnum (fromIntegral dayDiff + fromEnum wday)} - (loff,newExceptions,dgb) = Set.foldl (flip advanceExceptions) (dayDiff,mempty,mempty) occurrencesExceptions + newExceptions = snd $ Set.foldl' advanceExceptions (dayDiff,mempty) occurrencesExceptions -- we assume that instance Ord OccurrenceException is ordered chronologically - advanceExceptions :: OccurrenceException -> (Integer, Set OccurrenceException,_) -> (Integer, Set OccurrenceException,_) - advanceExceptions ex (offset, acc, dbg) + advanceExceptions :: (Integer, Set OccurrenceException) -> OccurrenceException -> (Integer, Set OccurrenceException) + advanceExceptions (offset, acc) ex | ed `Set.notMember` offDays -- skip term-holidays and weekends, unless the original day was a holiday or weekend , nd `Set.member` offDays - = advanceExceptions ex (succ offset, acc, ("skip"<>show offset) :dbg) + = advanceExceptions (succ offset, acc) ex | otherwise - = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc, show ex : dbg) + = (offset, Set.insert (setDayOfOccurrenceException nd ex) acc) where ed = dayOfOccurrenceException ex nd = addDays offset ed diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 8b91824f0..147edec6f 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -1027,7 +1027,7 @@ fillDb = do insert_ Tutorial { tutorialName = mkName "Vorlage" , tutorialCourse = c - , tutorialType = "Vorlage___Schulung" + , tutorialType = "Vorlage" , tutorialCapacity = capacity , tutorialRoom = Just $ case weekDay of Monday -> "A380" @@ -1045,10 +1045,15 @@ fillDb = do , exceptEnd = TimeOfDay 16 0 0 } , ExceptOccur - { exceptDay = secondDay + { exceptDay = succ firstDay , exceptStart = TimeOfDay 9 0 0 , exceptEnd = TimeOfDay 16 0 0 } + , ExceptOccur + { exceptDay = secondDay + , exceptStart = TimeOfDay 10 12 0 + , exceptEnd = TimeOfDay 12 13 0 + } ] } , tutorialRegGroup = Just "schulung" From b72ee99e3e6407c1148d1d9d8c3540215fd0d68c Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 2 Jun 2023 15:20:57 +0200 Subject: [PATCH 7/7] chore(qualification): add expiry option and diversify expiry letter --- .../categories/qualification/de-de-formal.msg | 2 + .../categories/qualification/en-eu.msg | 2 + models/lms.model | 5 +- src/Handler/Qualification.hs | 3 + src/Jobs/Handler/LMS.hs | 35 ++--- src/Utils/Print/ExpireQualification.hs | 16 +- templates/letter/fraport_generic_expiry.md | 139 ++++++++++++++++++ test/Database/Fill.hs | 6 +- 8 files changed, 182 insertions(+), 26 deletions(-) create mode 100644 templates/letter/fraport_generic_expiry.md diff --git a/messages/uniworx/categories/qualification/de-de-formal.msg b/messages/uniworx/categories/qualification/de-de-formal.msg index 77f754e62..66cc53f00 100644 --- a/messages/uniworx/categories/qualification/de-de-formal.msg +++ b/messages/uniworx/categories/qualification/de-de-formal.msg @@ -11,6 +11,8 @@ QualificationAuditDuration: Aufbewahrung Audit Log QualificationRefreshWithin: Erneurerungszeitraum QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E‑Learning QualificationElearningStart: Wird das E‑Learning automatisch gestartet? +QualificationExpiryNotification: Ungültigkeitsbenachrichtigung? +QualificationExpiryNotificationTooltip: Nutzer werden benachrichtigt, wenn die Qualifikation ungültig wird, sofern der jeweilige Nutzer in seinen Benutzereinstellungen diese Art Benachrichtigung aktiviert hat. TableQualificationCountActive: Aktive TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation TableQualificationCountTotal: Gesamt diff --git a/messages/uniworx/categories/qualification/en-eu.msg b/messages/uniworx/categories/qualification/en-eu.msg index 57dcf853b..6cbd6f95d 100644 --- a/messages/uniworx/categories/qualification/en-eu.msg +++ b/messages/uniworx/categories/qualification/en-eu.msg @@ -11,6 +11,8 @@ QualificationAuditDuration: Audit log keept QualificationRefreshWithin: Refresh within QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start e‑learning QualificationElearningStart: Is e‑learning automatically started? +QualificationExpiryNotification: Invalidity notification? +QualificationExpiryNotificationTooltip: Qualification holder are notfied upon invalidity, provided they have activated such notification in their user settings. TableQualificationCountActive: Active TableQualificationCountActiveTooltip: Number of currently valid qualification holders TableQualificationCountTotal: Total diff --git a/models/lms.model b/models/lms.model index 4f841f984..805bdc83c 100644 --- a/models/lms.model +++ b/models/lms.model @@ -12,9 +12,8 @@ Qualification auditDuration Int Maybe -- > 0, number of months to keep audit log and LmsUserIdents; or indefinitely (dangerous, since LmsIdents may run out) refreshWithin CalendarDiffDays Maybe -- notify users about renewal within this number of month/days before expiry; to be used with addGregorianDurationClip elearningStart Bool -- automatically schedule e-refresher - -- elearningOnly Bool -- successful E-learing automatically increases validity. NO! - -- refreshInvitation StoredMarkup -- hard-coded I18N-MSGs used instead, but displayed on qualification page NO! - -- expiryNotification StoredMarkup Maybe -- configurable user-profile-notifcations are used instead NO! + -- elearningOnly Bool -- successful E-learing automatically increases validity. NO! + expiryNotification Bool default=true -- should expiryNotification be generated for this qualification? avsLicence AvsLicence Maybe -- if set, valid QualificationUsers are synchronized to AVS as a driving licence sapId Text Maybe -- if set, valid QualificationUsers with userCompanyPersonalNumber are transmitted via SAP interface under this id SchoolQualificationShort school shorthand -- must be unique per school and shorthand diff --git a/src/Handler/Qualification.hs b/src/Handler/Qualification.hs index a1863add9..810ff57cf 100644 --- a/src/Handler/Qualification.hs +++ b/src/Handler/Qualification.hs @@ -101,6 +101,8 @@ mkQualificationAllTable isAdmin = do -- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between , sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart) $ tickmarkCell . view (resultAllQualification . _qualificationElearningStart) + , sortable (Just "noteexpiry") (i18nCell MsgQualificationExpiryNotification & cellTooltip MsgQualificationExpiryNotificationTooltip) + $ tickmarkCell . view (resultAllQualification . _qualificationExpiryNotification) , sortable Nothing (i18nCell MsgTableQualificationIsAvsLicence & cellTooltip MsgTableQualificationIsAvsLicenceTooltip) $ \(view (resultAllQualification . _qualificationAvsLicence) -> licence) -> maybeCell licence $ textCell . T.singleton . licence2char , sortable Nothing (i18nCell MsgTableQualificationSapExport & cellTooltip MsgTableQualificationSapExportTooltip) @@ -115,6 +117,7 @@ mkQualificationAllTable isAdmin = do , singletonMap "qshort" $ SortColumn (E.^. QualificationShorthand) , singletonMap "qname" $ SortColumn (E.^. QualificationName) , singletonMap "qelearning" $ SortColumn (E.^. QualificationElearningStart) + , singletonMap "noteexpiry" $ SortColumn (E.^. QualificationExpiryNotification) ] dbtFilter = mconcat [ diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 6e8a48f51..4da33143c 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -162,23 +162,24 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.&&. luser E.^. LmsUserQualification E.==. E.val qid $logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort - notifyInvalidDrivers <- E.select $ do - quser <- E.from $ E.table @QualificationUser - E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid - E.&&. E.not_ (validQualification nowaday quser) - E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) - E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) - ) E.||. ( - E.isJust (quser E.^. QualificationUserBlockedDue) - E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) - )) - pure (quser E.^. QualificationUserUser) - - forM_ notifyInvalidDrivers $ \(E.Value uid) -> - queueDBJob JobSendNotification - { jRecipient = uid - , jNotification = NotificationQualificationExpired { nQualification = qid } - } + when (quali ^. _qualificationExpiryNotification) $ do + notifyInvalidDrivers <- E.select $ do + quser <- E.from $ E.table @QualificationUser + E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid + E.&&. E.not_ (validQualification nowaday quser) + E.&&. (( E.isNothing (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil) + ) E.||. ( + E.isJust (quser E.^. QualificationUserBlockedDue) + E.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. E.day' ((quser E.^. QualificationUserBlockedDue) E.->>. "day")) + )) + pure (quser E.^. QualificationUserUser) + + forM_ notifyInvalidDrivers $ \(E.Value uid) -> + queueDBJob JobSendNotification + { jRecipient = uid + , jNotification = NotificationQualificationExpired { nQualification = qid } + } -- purge outdated LmsUsers case qualificationAuditDuration quali of diff --git a/src/Utils/Print/ExpireQualification.hs b/src/Utils/Print/ExpireQualification.hs index 1d73a3c6a..d261d0f8d 100644 --- a/src/Utils/Print/ExpireQualification.hs +++ b/src/Utils/Print/ExpireQualification.hs @@ -33,11 +33,11 @@ data LetterExpireQualificationF = LetterExpireQualificationF } deriving (Eq, Show) --- TODO: use markdown to generate the Letter +-- TODO: use markdown to generate the Letter -- this is no linger used, I believe instance MDMail LetterExpireQualificationF where attachPDFLetter _ = False getMailSubject l = SomeMessage $ MsgMailSubjectQualificationExpired $ leqfShort l - getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = return $ + getMailBody LetterExpireQualificationF{..} DateTimeFormatter{ format } = return $ -- TODO: can we use render Letter here? let expiryDate = format SelFormatDate <$> leqfExpiry userDisplayName = leqfHolderDN userSurname = leqfHolderSN @@ -59,7 +59,11 @@ instance MDLetter LetterExpireQualificationF where encryptPDFfor _ = NoPassword getLetterKind _ = Din5008 getLetterEnvelope _ = 'e' - getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_f_expiry.md") + + getTemplate LetterExpireQualificationF{leqfShort="F"} + = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_f_expiry.md") + getTemplate _ = decodeUtf8 $(Data.FileEmbed.embedFile "templates/letter/fraport_generic_expiry.md") + letterMeta LetterExpireQualificationF{..} DateTimeFormatter{ format } lang Entity{entityKey=rcvrId, entityVal=User{userDisplayName}} = let isSupervised = rcvrId /= leqfHolderID @@ -68,11 +72,17 @@ instance MDLetter LetterExpireQualificationF where [ toMeta "supervisor" userDisplayName ] <> [ toMeta "lang" lang + , toMeta "licencename" leqfName + , toMeta "licenceshort" leqfShort , toMeta "licenceholder" leqfHolderDN , mbMeta "expiry" (format SelFormatDate <$> leqfExpiry) , mbMeta "licence-url" leqfUrl , toMeta "de-opening" $ bool ("Guten Tag " <> leqfHolderDN <> ",") "Sehr geehrte Damen und Herren," isSupervised , toMeta "en-opening" $ bool ("Dear " <> leqfHolderDN <> ",") "Dear supervisor," isSupervised + , toMeta "de-subject" $ "Entzug \"" <> leqfShort <> "\" (" <> leqfName <> ")" + , toMeta "en-subject" $ case leqfShort of + "F" -> "Revocation of apron driving license" + _ -> "Revocation of licence \"" <> leqfShort <> "\" (" <> leqfName <> ")" ] getPJId LetterExpireQualificationF{..} = diff --git a/templates/letter/fraport_generic_expiry.md b/templates/letter/fraport_generic_expiry.md new file mode 100644 index 000000000..6b508e3a0 --- /dev/null +++ b/templates/letter/fraport_generic_expiry.md @@ -0,0 +1,139 @@ +--- +### Metadaten, welche hier eingestellt werden: +# Absender +de-subject: Qualifikationsentzug +en-subject: Qualification revocation +author: Fraport AG - Fahrerausbildung (AVN-AR) +phone: +49 69 690-30306 +email: fahrerausbildung@fraport.de +place: Frankfurt am Main +return-address: + - 60547 Frankfurt +de-opening: Liebe Fahrberechtigungsinhaber, +en-opening: Dear driver, +de-closing: | + Mit freundlichen Grüßen, + Ihre Fraport Fahrerausbildung +en-closing: | + With kind regards, + Your Fraport Driver Training +encludes: +hyperrefoptions: hidelinks + +### Metadaten, welche automatisch ersetzt werden: +date: 11.11.1111 +lang: de-de +is-de: true +# Emfpänger +licenceholder: P. Rüfling +address: + - E. M. Pfänger + - Musterfirma GmbH + - Musterstraße 11 + - 12345 Musterstadt +... +$if(titleblock)$ +$titleblock$ + +$endif$ +$for(header-includes)$ +$header-includes$ + +$endfor$ +$for(include-before)$ +$include-before$ + +$endfor$ + +$if(is-de)$ + + +leider ist die Fahrlizenz $licencename$ +$if(supervisor)$ + für **$licenceholder$** +$else$ + Ihre +$endif$ +ungültig geworden, z.B. weil die Ablauffrist erreicht wurde. + + +Die Qualifikation „$licencename$“ ist somit +$if(expiry)$ + seit $expiry$ +$endif$ +nicht mehr gültig. + + +$if(supervisor)$ +$if(licence-url)$ +[$licenceholder$]($licence-url$) +$else$ +$licenceholder$ +$endif$ +darf +$else$ + Sie dürfen +$endif$ +ab sofort diese Qualifikation nicht mehr am Frankfurter Flughafens nutzen. + +Wenden Sie sich zur Wiedererlangung der Qualifikation bitte +$if(supervisor)$ +an die Fahrerausbildung der Fraport AG unter: + +Telefon + + : [$phone$](tel:$phone$) + +Email + + : [$email$](mailto:$email$) + +$else$ +an Ihren Arbeitgeber. +$endif$ + +$else$ + +we regret to inform you that the driving licence $licencename$ has expired for +$if(supervisor)$ + **$licenceholder$**. +$else$ + you. +$endif$ + +The qualification „$licencename$“ is therefore invalid +$if(expiry)$ + since $expiry$. +$else$ + now. +$endif$ + +$if(supervisor)$ +$if(licence-url)$ +[$licenceholder$]($licence-url$) +$else$ +$licenceholder$ +$endif$ +$else$ + You +$endif$ +may no use this qualification at Frankfurt airport, effective immediately. + + +Please contact +$if(supervisor)$ +the Fraport driving school team, if you want to book a course to regain this licence: + +Phone + + : [$phone$](tel:$phone$) + +Email + + : [$email$](mailto:$email$) + +$else$ +your employer to book a course for you in order to regain this licence. +$endif$ + +$endif$ diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 147edec6f..67780ec37 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -695,9 +695,9 @@ fillDb = do let f_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|] let r_descr = Just $ htmlToStoredMarkup [shamlet|

Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|] let l_descr = Just $ htmlToStoredMarkup [shamlet|

für unhabilitierte|] - qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True (Just AvsLicenceVorfeld) $ Just "F4466" - qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False (Just AvsLicenceRollfeld) $ Just "R2801" - qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True Nothing Nothing + qid_f <- insert' $ Qualification avn "F" "Vorfeldführerschein" f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True True (Just AvsLicenceVorfeld) $ Just "F4466" + qid_r <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 12) (Just 6) (Just $ CalendarDiffDays 2 3) False False (Just AvsLicenceRollfeld) $ Just "R2801" + qid_l <- insert' $ Qualification ifi "L" "Lehrbefähigung" l_descr Nothing (Just 6) Nothing True False Nothing Nothing void . insert' $ QualificationUser jost qid_f (n_day 9) (n_day $ -1) (n_day $ -22) (Just $ QualificationBlocked (n_day $ -5) "LMS") True (n_day' $ -9) -- TODO: better dates! void . insert' $ QualificationUser jost qid_r (n_day 99) (n_day $ -11) (n_day $ -222) Nothing True (n_day' $ -9) -- TODO: better dates! void . insert' $ QualificationUser jost qid_l (n_day 999) (n_day $ -111) (n_day $ -2222) Nothing True (n_day' $ -9) -- TODO: better dates!