Merge branch 'master' of gitlab.uniworx.de:fradrive/fradrive

This commit is contained in:
Steffen Jost 2023-06-02 21:02:08 +00:00
commit a7668d0767
11 changed files with 207 additions and 41 deletions

View File

@ -11,6 +11,8 @@ QualificationAuditDuration: Aufbewahrung Audit Log
QualificationRefreshWithin: Erneurerungszeitraum
QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des ELearning
QualificationElearningStart: Wird das ELearning 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

View File

@ -11,6 +11,8 @@ QualificationAuditDuration: Audit log keept
QualificationRefreshWithin: Refresh within
QualificationRefreshWithinTooltip: Period before expiry to send a notification or to start elearning
QualificationElearningStart: Is elearning 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

View File

@ -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

View File

@ -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

View File

@ -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
[

View File

@ -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

View File

@ -64,14 +64,14 @@ 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
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)
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)
= advanceExceptions (succ offset, acc) ex
| otherwise
= (offset, Set.insert (setDayOfOccurrenceException nd ex) acc)
where

View File

@ -98,11 +98,11 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
act = do
identsInUseVs <- E.select $ do
lui <- E.from $
( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) )
( (E.^. LmsUserlistIdent) <$> E.from (E.table @LmsUserlist) ) -- no filter by Qid, since LmsIdents must be unique across all
`E.union_`
( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult) )
( (E.^. LmsResultIdent) <$> E.from (E.table @LmsResult ) )
`E.union_`
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser) )
( (E.^. LmsUserIdent) <$> E.from (E.table @LmsUser ) )
E.orderBy [E.asc lui]
pure lui
now <- liftIO getCurrentTime
@ -150,31 +150,36 @@ 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.&&. (E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil)
) E.||. (
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 }
}
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

View File

@ -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{..} =

View File

@ -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)$
<!-- deutsche Version des Briefes -->
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$
<!-- englische Version des Briefes -->
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$

View File

@ -695,9 +695,9 @@ fillDb = do
let f_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes.|]
let r_descr = Just $ htmlToStoredMarkup [shamlet|<p>Berechtigung zum Führen eines Fahrzeuges auf dem gesamten Rollfeld.|]
let l_descr = Just $ htmlToStoredMarkup [shamlet|<p>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!
@ -1027,7 +1027,7 @@ fillDb = do
insert_ Tutorial
{ tutorialName = mkName "Vorlage"
, tutorialCourse = c
, tutorialType = "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"