fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' into fradrive/api-avs

Browse Source
This commit is contained in:
Steffen Jost 2022-11-07 08:51:00 +01:00
commit 0cad77c32c
25 changed files with 242 additions and 130 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
CHANGELOG.md
View File

@ -2,6 +2,10 @@
All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
## [26.5.14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.13...v26.5.14) (2022-11-06)
## [26.5.13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.12...v26.5.13) (2022-11-03)
## [26.5.12](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.11...v26.5.12) (2022-10-31)
## [26.5.11](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.9...v26.5.11) (2022-10-31)

4
messages/uniworx/categories/print/de-de-formal.msg
View File

@ -8,13 +8,15 @@ PrintJobFilename: Dateiname
PrintJobId !ident-ok: Id
PrintJobCreated: Gesendet
PrintJobAcknowledged: Bestätigt
PrintJobUnacknowledged: Noch nicht gedruckt
PrintJobAcknowledge n@Int64: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} als gedruckt und versendet bestätigt
PrintJobAcknowledgeFailed: Keine Druckaufträge bestätigt aufgrund zwischenzeitlicher Änderungen. Bitte die Seite im Browser aktualisieren!
PrintJobAcknowledgeQuestion n@Int d@Text: #{n} #{pluralDE n "Druckauftrag" "Druckaufräge"} vom #{d} als gedruckt und versendet bestätigen?
PrintJobAcknowledgements: Versanddatum von Briefen an
PrintRecipient: Empfänger
PrintSender !ident-ok: Sender
PrintCourse: Kurse
PrintQualification: Qualifikation
PrintPDF !ident-ok: PDF
PrintManualRenewal: Vorfeldführerschein Renewal-Brief testweise versenden
PrintLmsUser: E-Lernen Benachrichtigung?
PrintLmsUser: E-Learning Benachrichtigung?

4
messages/uniworx/categories/print/en-eu.msg
View File

@ -8,13 +8,15 @@ PrintJobFilename: Filename
PrintJobId: Id
PrintJobCreated: Created
PrintJobAcknowledged: Acknowledged
PrintJobUnacknowledged: Not yet printed
PrintJobAcknowledge n: #{n} #{pluralENs n "print-job"} marked as printed and mailed
PrintJobAcknowledgeFailed: No print-jobs acknowledged, due to intermediate changes. Please reload this page!
PrintJobAcknowledgeQuestion n d: Mark #{n} #{pluralENs n "print-job"} issued on #{d} as printed and mailed already?
PrintJobAcknowledgements: Sent-dates for Letter to
PrintRecipient: Recipient
PrintSender: Sender
PrintCourse: Course
PrintQualification: Qualification
PrintPDF: PDF
PrintManualRenewal: Manual sending of an apron driving licence renewal letter
PrintManualRenewal: Manual sending of an apron driver's licence renewal letter
PrintLmsUser: E-learning notification?

36
messages/uniworx/categories/qualification/de-de-formal.msg
View File

@ -8,8 +8,8 @@ QualificationDescription: Beschreibung
QualificationValidDuration: Gültigkeitsdauer
QualificationAuditDuration: Aufbewahrung Audit Log
QualificationRefreshWithin: Erneurerungszeitraum
QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E-Lernens
QualificationElearningStart: E-Lernen automatisch starten
QualificationRefreshWithinTooltip: Zeitraum für Versand einer Benachrichtigung oder für automatischen Start des E-Learning
QualificationElearningStart: E-Learning automatisch starten
TableQualificationCountActive: Aktive
TableQualificationCountActiveTooltip: Anzahl Personen mit momentan gültiger Qualifikation
TableQualificationCountTotal: Gesamt
@ -21,8 +21,8 @@ TableQualificationBlockedTooltip: Wann wurde die Qualifikation vorübergehend au
LmsUser: Inhaber
TableLmsEmail: E-Mail
TableLmsIdent: Identifikation
TableLmsElearning: E-Lernen
TableLmsPin: E-Lernen Pin
TableLmsElearning: E-Learning
TableLmsPin: E-Learning Pin
TableLmsResetPin: Pin zurücksetzen?
TableLmsDatePin: Pin erstellt
TableLmsDelete: Löschen?
@ -31,16 +31,16 @@ TableLmsStarted: Begonnen
TableLmsReceived: Letzte Rückmeldung
TableLmsNotified: Versand Benachrichtigung
TableLmsEnded: Beended
TableLmsStatus: Status E-Lernen
TableLmsStatus: Status E-Learning
TableLmsSuccess: Bestanden
TableLmsFailed: Gesperrt
FilterLmsValid: Aktuell gültig
FilterLmsRenewal: Erneuerung anstehend
FilterLmsNotified: Benachrichtigt
CsvColumnLmsIdent: E-Lernen Identifikator, einzigartig pro Qualifikation und Teilnehmer
CsvColumnLmsPin: PIN des E-Lernen Zugangs
CsvColumnLmsIdent: E-Learning Identifikator, einzigartig pro Qualifikation und Teilnehmer
CsvColumnLmsPin: PIN des E-Learning Zugangs
CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?
CsvColumnLmsDelete: Wird der Identifikator in der E-Lernen Plattform bei der nächsten Synchronisation gelöscht?
CsvColumnLmsDelete: Wird der Identifikator in der E-Learning Plattform bei der nächsten Synchronisation gelöscht?
CsvColumnLmsStaff: Handelt es sich um einen internen Mitarbeiter? (Aus historischen Gründen, wird momentan ignoriert.)
CsvColumnLmsSuccess: Zeitstempel der erfolgreichen Teilnahme (UTC)
CsvColumnLmsFailed: User was blocked by LMS, usually due to too many attempts
@ -51,25 +51,25 @@ LmsResultUpdate: LMS Ergebnis aktualisierung
LmsResultCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
LmsUserlistCsvExceptionDuplicatedKey: CSV Import fand uneindeutigen Schlüssel
LmsDirectUpload: Direkter Upload für automatisierte Systeme
LmsErrorNoRefreshElearning: Fehler: E-Lernen wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
LmsErrorNoRefreshElearning: Fehler: E-Learning wird nicht automatisch gestartet, da die Zeitspanne für den Erneurerungszeitraum nicht festgelegt wurde.
MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnächst erneuert werden
MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
MailSubjectQualificationExpired qname@Text: Qualifikation #{qname} ist ab sofort ungültig
MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Learning Kurs erneuern.
MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
MailBodyQualificationExpired: Diese Qualifikaton is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Lernen.
MailBodyQualificationExpired: Diese Qualifikaton is nun abgelaufen. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen ab sofort nicht länger ausgeübt werden! Es ist möglich, dass die Qualifikation vorzeit ungültig wurde, z.B. wegen erfolgloser Teilnahme an einem verpflichtendem E-Learning.
LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PDF-Passwort verschlüsselt. Falls kein PDF-Passwort hinterlegt wurde, ist das PDF-Passwort Ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach.
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Lernen verlängert werden.
LmsActNotify: Benachrichtigung E-Lernen erneut per Post oder E-Mail versenden
LmsActRenewPin: Neue zufällige E-Lernen PIN zuweisen
LmsActRenewNotify: Neue zufällige E-Lernen PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden
LmsNotificationSend n@Int: E-Lernen Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet.
LmsPinRenewal n@Int: E-Lernen Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
LmsNoRenewal: Leider kann diese Qualifikation nicht alleine durch E-Learning verlängert werden.
LmsActNotify: Benachrichtigung E-Learning erneut per Post oder E-Mail versenden
LmsActRenewPin: Neue zufällige E-Learning PIN zuweisen
LmsActRenewNotify: Neue zufällige E-Learning PIN zuweisen und Benachrichtigung per Post oder E-Mail versenden
LmsNotificationSend n@Int: E-Learning Benachrichtigungen an #{n} #{pluralDE n "Prüfling" "Prüflinge"} werden per Post oder E-Mail versendet.
LmsPinRenewal n@Int: E-Learning Pin ausgetauscht für #{n} #{pluralDE n "Prüfling" "Prüflinge"}.
LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person" "Personen"}, da diese derzeit nicht an einer Prüfung teilnehmen.
MppOpening: Anrede
MppClosing: Grußformel
MppDate: Datum
MppURL: Link E-Lernen
MppURL: Link E-Learning
MppLogin !ident-ok: Login
MppPin !ident-ok: Pin
MppRecipient: Empfänger

10
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -128,11 +128,11 @@ MenuCourseEventEdit: Kurstermin bearbeiten
MenuLanguage: Sprache
MenuQualifications: Qualifikationen
MenuLms: E-Lernen
MenuLmsEdit: Bearbeiten E-Lernen
MenuLmsUsers: Export E-Lernen Benutzer
MenuLmsUserlist: Melden E-Lernen Benutzer
MenuLmsResult: Melden Ergebnisse E-Lernen
MenuLms !ident-ok: E-Learning
MenuLmsEdit: Bearbeiten E-Learning
MenuLmsUsers: Export E-Learning Benutzer
MenuLmsUserlist: Melden E-Learning Benutzer
MenuLmsResult: Melden Ergebnisse E-Learning
MenuLmsUpload: Hochladen
MenuLmsDirectUpload: Direkter Upload
MenuLmsDirectDownload: Direkter Download

2
nix/docker/demo-version.json
View File

@ -1,3 +1,3 @@
{
"version": "26.5.12"
"version": "26.5.14"
}

2
nix/docker/version.json
View File

@ -1,3 +1,3 @@
{
"version": "26.5.12"
"version": "26.5.14"
}

2
package-lock.json generated
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "26.5.12",
"version": "26.5.14",
"lockfileVersion": 1,
"requires": true,
"dependencies": {

2
package.json
View File

@ -1,6 +1,6 @@
{
"name": "uni2work",
"version": "26.5.12",
"version": "26.5.14",
"description": "",
"keywords": [],
"author": "",

2
package.yaml
View File

@ -1,5 +1,5 @@
name: uniworx
version: 26.5.12
version: 26.5.14
dependencies:
- base
- yesod

1
routes
View File

@ -72,7 +72,6 @@
/print PrintCenterR GET POST !system-printer
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
/print/acknowledge/direct PrintAckDirectR POST !system-printer
/print/acknowledge/free/direct PrintAckFreeR POST !development
/print/send PrintSendR GET POST
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer

1
src/Foundation/Navigation.hs
View File

@ -120,7 +120,6 @@ breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenter
breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
breadcrumb PrintAckFreeR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
breadcrumb (SchoolR ssh sRoute) = case sRoute of

107
src/Handler/LMS.hs
View File

@ -253,22 +253,18 @@ instance CsvColumnsExplained LmsTableCsv where
type LmsTableExpr = ( E.SqlExpr (Entity QualificationUser)
`E.InnerJoin` E.SqlExpr (Entity User)
) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity PrintJob))
queryQualUser :: LmsTableExpr -> E.SqlExpr (Entity QualificationUser)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 2 1)
queryUser :: LmsTableExpr -> E.SqlExpr (Entity User)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 2 1)
queryLmsUser :: LmsTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
queryLmsUser = $(sqlLOJproj 3 2)
queryLmsUser = $(sqlLOJproj 2 2)
queryPrintJob :: LmsTableExpr -> E.SqlExpr (Maybe (Entity PrintJob))
queryPrintJob = $(sqlLOJproj 3 3)
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity PrintJob), E.Value (Maybe [Maybe UTCTime]))
type LmsTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), E.Value (Maybe [Maybe UTCTime]))
resultQualUser :: Lens' LmsTableData (Entity QualificationUser)
resultQualUser = _dbrOutput . _1
@ -279,11 +275,8 @@ resultUser = _dbrOutput . _2
resultLmsUser :: Traversal' LmsTableData (Entity LmsUser)
resultLmsUser = _dbrOutput . _3 . _Just
resultPrintJob :: Traversal' LmsTableData (Entity PrintJob)
resultPrintJob = _dbrOutput . _4 . _Just
resultPrintAck :: Traversal' LmsTableData [Maybe UTCTime]
resultPrintAck = _dbrOutput . _5 . _unValue . _Just
resultPrintAck = _dbrOutput . _4 . _unValue . _Just
instance HasEntity LmsTableData User where
hasEntity = resultUser
@ -320,19 +313,13 @@ isRenewPinAct LmsActRenewPinData = True
lmsTableQuery :: QualificationId -> LmsTableExpr -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
, E.SqlExpr (Entity User)
, E.SqlExpr (Maybe (Entity LmsUser))
, E.SqlExpr (Maybe (Entity PrintJob))
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- Nutzbar zum sortieren und filtern!
, E.SqlExpr (E.Value (Maybe [Maybe UTCTime])) -- outer maybe indicates, whether a printJob exists, inner maybe indicates all acknowledged printJobs
)
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` printJob) = do
-- E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
-- instead we use notExits in printJob join condition; experiments with separate sub-query showed that we would need two subsqueries to learn wether the request was indeed the latest
E.on $ lmsUser E.?. LmsUserIdent E.=?. printJob E.?. PrintJobLmsUser
E.&&. -- is the latest created printJob for this LmsUser; note that notExists has in general a pretty good performance in postgresql
E.notExists (E.from $ \otherpj ->
E.where_ $ E.isJust (otherpj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (otherpj E.^. PrintJobLmsUser))
E.&&. ((printJob E.?. PrintJobCreated) E.<. E.just (otherpj E.^. PrintJobCreated))
)
lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser) = do
-- RECALL: another outer join on PrintJob did not work out well, since
-- - E.distinctOn [E.don $ printJob E.?. PrintJobLmsUser] $ do -- types, but destroys the ability to sort interactively, since distinctOn requires sorting;
-- - using noExsists on printJob join condition works, but only deliver single value;
-- experiments with separate sub-query showed that we would need two subsqueries to learn whether the request was indeed the latest
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
@ -342,8 +329,10 @@ lmsTableQuery qid (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.Left
let printAcknowledged = E.subSelectMaybe . E.from $ \pj -> do
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
E.&&. ((lmsUser E.?. LmsUserIdent) E.==. (pj E.^. PrintJobLmsUser))
pure $ E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) [E.asc $ pj E.^. PrintJobCreated]
return (qualUser, user, lmsUser, printJob, printAcknowledged)
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
return (qualUser, user, lmsUser, printAcknowledged)
newtype LmsTableFilterProj = LmsTableFilterProj { ltProjFilterMayAccess :: Maybe Bool }
@ -381,13 +370,12 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
dbtProj = (views _dbtProjRow . set _dbrOutput) =<< do
qusr <- view $ _dbtProjRow . resultQualUser
user <- view $ _dbtProjRow . resultUser
lusr <- preview $ _dbtProjRow . resultLmsUser
pjob <- preview $ _dbtProjRow . resultPrintJob
lusr <- preview $ _dbtProjRow . resultLmsUser
pjac <- preview $ _dbtProjRow . resultPrintAck
forMM_ (view $ _dbtProjFilter . _ltProjFilterMayAccess) $ \b -> do
euid <- encrypt $ user ^. _entityKey
guardM . lift . lift . fmap (== b) . hasReadAccessTo . urlRoute $ ForProfileDataR euid -- TODO create a page with proper rights; this is only for admins!
return (qusr,user,lusr,pjob,E.Value pjac)
return (qusr,user,lusr,E.Value pjac)
dbtColonnade = cols
dbtSorting = mconcat
@ -402,9 +390,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
, single ("lms-started" , SortColumn $ queryLmsUser >>> (E.?. LmsUserStarted))
, single ("lms-datepin" , SortColumn $ queryLmsUser >>> (E.?. LmsUserDatePin))
, single ("lms-received", SortColumn $ queryLmsUser >>> (E.?. LmsUserReceived))
--, single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified))
, single ("lms-notified", SortColumn $ \row -> E.coalesce [queryPrintJob row E.?. PrintJobAcknowledged, queryLmsUser row E.?. LmsUserNotified]) -- prefer printJob acknowledgement date, if it exists
-- , single ("lms-notified", SortColumn $ \row -> E.greatest (queryPrintJob row E.?. PrintJobAcknowledged, queryLmsUser row E.?. LmsUserNotified)) -- bad idea, since resending increase notifyDate but just schedules yet another print job
, single ("lms-notified", SortColumn $ queryLmsUser >>> (E.?. LmsUserNotified)) -- cannot include printJob acknowledge date
, single ("lms-ended" , SortColumn $ queryLmsUser >>> (E.?. LmsUserEnded))
]
dbtFilter = mconcat
@ -419,18 +405,7 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
| otherwise -> E.true
)
-- , single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
, single ("lms-notified", FilterColumn $ \row criterion ->
let luser = queryLmsUser row
pjob = queryPrintJob row
in
case getLast criterion of
Just True -> E.isJust (luser E.?. LmsUserNotified)
E.&&. (E.isNothing (pjob E.?. PrintJobId) E.||. E.isJust (pjob E.?. PrintJobAcknowledged))
Just False -> E.isNothing (luser E.?. LmsUserNotified)
E.||. (E.isJust (pjob E.?. PrintJobId) E.&&. E.isNothing (pjob E.?. PrintJobAcknowledged))
Nothing -> E.true
)
, single ("lms-notified", FilterColumn . E.mkExactFilterLast $ views (to queryLmsUser) (E.isJust . (E.?. LmsUserNotified)))
]
dbtFilterUI mPrev = mconcat
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
@ -533,19 +508,41 @@ postLmsR sid qsh = do
-- - Email sent : LmsUserNotified == Just _ && PrintJobId == Nothing
-- - Letter printed : LmsUserNotified == Just _ && PrintJobId == Just _
-- - Letter sent : LmsUserNotified == Just _ && PrintJobId == Just _ && PrintJobAcknowledged == Just _
let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified
letterDate = join $ row ^? resultPrintJob . _entityVal . _printJobAcknowledged
-- letterSent = isJust (row ^? resultPrintJob . _entityKey) && (isNothing letterDate || letterDate > notifyDate) -- bad idea, since a resending increase notifyDay but just reschedules a print job
letterSent = isJust (row ^? resultPrintJob . _entityKey) -- note the difference to letterDate!
notNotified = isNothing notifyDate
cIcon = iconFixedCell $ iconLetterOrEmail letterSent
cDate = if letterSent
then foldMap dateTimeCell letterDate
else foldMap dateTimeCell notifyDate
let notifyDate = join $ row ^? resultLmsUser . _entityVal . _lmsUserNotified
lmsident = row ^? resultLmsUser . _entityVal . _lmsUserIdent
recipient = row ^. hasUser
letterDates = row ^? resultPrintAck
lastLetterDate = headDef Nothing =<< letterDates
letterSent = isJust letterDates && (isNothing lastLetterDate || lastLetterDate >= notifyDate) -- was a letter attempted to send last (not 100% safe, if an email is sent after an unacknowledged letter)
notNotified = isNothing notifyDate
cIcon = iconFixedCell $ iconLetterOrEmail letterSent
cDate = if | not letterSent -> foldMap dateTimeCell notifyDate
| Just d <- lastLetterDate -> dateTimeCell d
| otherwise -> i18nCell MsgPrintJobUnacknowledged
cAckDates = case letterDates of
Just ackDates@(_:_:_) -> spacerCell <> modalCell [whamlet|
<h1>
_{MsgPrintJobAcknowledgements} ^{userWidget recipient}
<ul>
$forall mbackdate <- ackDates
<li>
#{iconLetter} #
$maybe ackdate <- mbackdate
^{formatTimeW SelFormatDateTime ackdate}
$nothing
_{MsgPrintJobUnacknowledged}
$maybe _lu <- lmsident
<p>
<a href=@{PrintCenterR}>
Link to PrintJob
|]
-- (PrintCenterR, [("pj-lmsid", toPathPiece lu)])
_ -> mempty
in if notNotified
then mempty
else cIcon <> spacerCell <> cDate
, sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
else cIcon <> spacerCell <> cDate <> cAckDates
-- , sortable (Just "lms-notified-alternative") (i18nLms MsgTableLmsNotified) $ \(preview resultPrintAck -> d) -> textCell (show d)
, sortable (Just "lms-ended") (i18nLms MsgTableLmsEnded) $ \(preview $ resultLmsUser . _entityVal . _lmsUserEnded -> d) -> foldMap dateTimeCell $ join d
]
where

2
src/Handler/LMS/Fake.hs
View File

@ -150,7 +150,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
]
someLangs = [ (Just $ Languages ["de-de"] , DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%a %d.%m.%Y", DateTimeFormat "%T")
, (Nothing , DateTimeFormat "%d.%m.%y %R" , DateTimeFormat "%d.%m.%y" , DateTimeFormat "%R")
, (Just $ Languages ["en-eu","de"], DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%b %d %y" , DateTimeFormat "%I:%M %p")
, (Just $ Languages ["en-eu","de"], DateTimeFormat "%a %d %b %Y %T", DateTimeFormat "%b/%d/%y" , DateTimeFormat "%I:%M %p")
, (Just $ Languages ["fr"] , DateTimeFormat "%d-%m-%Y %R" , DateTimeFormat "%d-%m-%Y" , DateTimeFormat "%R")
, (Just $ Languages ["fr","en"] , DateTimeFormat "%B %d %Y %R" , DateTimeFormat "%B %d %y" , DateTimeFormat "%I:%M:%S %p")
]

9
src/Handler/PrintCenter.hs
View File

@ -10,8 +10,7 @@ module Handler.PrintCenter
, getPrintCenterR, postPrintCenterR
, getPrintSendR , postPrintSendR
, getPrintAckR , postPrintAckR
, postPrintAckDirectR
, postPrintAckFreeR
, postPrintAckDirectR
) where
import Import
@ -230,6 +229,7 @@ mkPJTable = do
, single ("pj-sender" , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender) (E.?. UserDisplayName))
, single ("pj-course" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse) (E.?. CourseName))
, single ("pj-qualification", FilterColumn . E.mkContainsFilterWith Just $ views (to queryQualification) (E.?. QualificationName))
, single ("pj-lmsid" , FilterColumn . E.mkContainsFilterWith Just $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
]
dbtFilterUI mPrev = mconcat
@ -243,6 +243,7 @@ mkPJTable = do
, prismAForm (singletonFilter "pj-sender" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintSender)
, prismAForm (singletonFilter "pj-course" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintCourse)
, prismAForm (singletonFilter "pj-qualification". maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintQualification)
, prismAForm (singletonFilter "pj-lmsid" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgPrintLmsUser)
, prismAForm (singletonFilter "acknowledged" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgPrintJobAcknowledged)
]
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout}
@ -447,7 +448,3 @@ postPrintAckDirectR = do
$logErrorS "APC" msg
return (badRequest400, msg)
sendResponseStatus status msg -- must be outside of runDB; otherweise transaction is rolled back
-- synonym, used during development to test with and without access control simultaneously
postPrintAckFreeR :: Handler Html
postPrintAckFreeR = postPrintAckDirectR

43
src/Handler/Utils/Mail.hs
View File

@ -9,6 +9,7 @@ module Handler.Utils.Mail
, addFileDB
, addHtmlMarkdownAlternatives
, addHtmlMarkdownAlternatives'
, addHtmlMarkdownAlternatives''
) where
import Import
@ -169,26 +170,36 @@ addHtmlMarkdownAlternatives html' = do
{ P.writerReferenceLinks = True
}
{-
addHtmlMarkdownAlternatives' :: ( HandlerSite m ~ UniWorX
, MonadMail m
, ToMailPart (HandlerSite m) Html
-- | provide a name for the part
addHtmlMarkdownAlternatives' :: ( MonadMail m
, ToMailPart (HandlerSite m) (NamedMailPart Html)
, ToMailHtml (HandlerSite m) a
) => a -> m ()
addHtmlMarkdownAlternatives' = addHtmlMarkdownAlternatives
-}
-- For now failed attempt to use with i18nHaletFile or widgets:
addHtmlMarkdownAlternatives' :: ( HandlerSite m ~ UniWorX
, MonadMail m
, YesodMail (HandlerSite m)
) => Html -> m ()
addHtmlMarkdownAlternatives' html = do
) => Text -> a -> m ()
addHtmlMarkdownAlternatives' fn html' = do
html <- toMailHtml html'
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
addAlternatives $ do
providePreferredAlternative html
whenIsJust markdown provideAlternative
providePreferredAlternative $ NamedMailPart { namedPart = html, disposition = AttachmentDisposition fn }
whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
where
writerOptions = markdownWriterOptions
{ P.writerReferenceLinks = True
}
-- | provide a name for the part
addHtmlMarkdownAlternatives'' :: ( MonadMail m
, ToMailPart (HandlerSite m) (NamedMailPart Html)
, ToMailHtml (HandlerSite m) a
) => Text -> a -> m ()
addHtmlMarkdownAlternatives'' fn html' = do
html <- toMailHtml html'
markdown <- runMaybeT $ renderMarkdownWith htmlReaderOptions writerOptions html
addAlternatives $ do
providePreferredAlternative $ NamedMailPart { disposition = InlineDisposition fn, namedPart = html }
whenIsJust markdown $ provideAlternative . NamedMailPart (AttachmentDisposition (fn <> ".txt"))
where
writerOptions = markdownWriterOptions
{ P.writerReferenceLinks = True

3
src/Handler/Utils/Widgets.hs
View File

@ -56,6 +56,9 @@ nameWidget :: Text -- ^ userDisplayName
-> Widget
nameWidget displayName surname = toWidget $ nameHtml displayName surname
userWidget :: HasUser c => c -> Widget
userWidget x = nameWidget (x ^. _userDisplayName) (x ^._userSurname)
-- | toWidget-Version of @nameEmailHtml@, for convenience
nameEmailWidget :: UserEmail -- ^ userEmail
-> Text -- ^ userDisplayName

19
src/Jobs/Handler/SendTestEmail.hs
View File

@ -10,6 +10,7 @@ import Import
import Handler.Utils.Mail
import Handler.Utils.DateTime
-- import Handler.Utils.I18n
dispatchJobSendTestEmail :: Email -> MailContext -> JobHandler UniWorX
dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMailContext $ do
@ -38,7 +39,7 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
<li>#{nD}
<li>#{nT}
|]
addHtmlMarkdownAlternatives $ \(MsgRenderer mr) -> [shamlet|
addHtmlMarkdownAlternatives' "addOne" $ \(MsgRenderer mr) -> [shamlet|
<h2>Repetition just for Testing
<p>
#{mr MsgMailTestContent}
@ -50,3 +51,19 @@ dispatchJobSendTestEmail jEmail jMailContext = JobHandlerException . mailT jMail
<li>#{nD}
<li>#{nT}
|]
addHtmlMarkdownAlternatives'' "addTwo" $ \(MsgRenderer mr) -> [shamlet|
<h2>Repetition just for Testing
<p>
#{mr MsgMailTestContent}
<p>
#{mr MsgMailTestDateTime}
<ul>
<li>#{nDT}
<li>#{nD}
<li>#{nT}
|]
-- let test = $(i18nHamletFile "test")
-- addHtmlMarkdownAlternatives' "addTest" (test :: Html) -- Text.Blaze.Internal.MarkupM Text.Blaze.Internal.Markup

13
src/Mail.hs
View File

@ -23,6 +23,7 @@ module Mail
-- * Monadically constructing Mail
, PrioritisedAlternatives
, ToMailPart(..)
, NamedMailPart(..)
, addAlternatives, provideAlternative, providePreferredAlternative
, addPart, addPart', modifyPart, partIsAttachment
, MonadHeader(..)
@ -435,6 +436,16 @@ instance YesodMail site => ToMailPart site YamlValue where
_partContent .= PartContent (fromStrict $ Yaml.encode val)
data NamedMailPart a = NamedMailPart { disposition :: Disposition, namedPart :: a }
instance ToMailPart site a => ToMailPart site (NamedMailPart a) where
type MailPartReturn site (NamedMailPart a) = MailPartReturn site a
toMailPart nmp = do
r <- toMailPart $ namedPart nmp
_partDisposition .= disposition nmp
return r
addAlternatives :: (MonadMail m)
=> Writer (PrioritisedAlternatives m) ()
-> m ()
@ -447,7 +458,7 @@ provideAlternative, providePreferredAlternative
:: (MonadMail m, HandlerSite m ~ site, ToMailPart site a)
=> a
-> Writer (PrioritisedAlternatives m) ()
provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
provideAlternative part = tell $ mempty { otherAlternatives = Seq.singleton $ execStateT (toMailPart part) initialPart }
providePreferredAlternative part = tell $ mempty { preferredAlternative = Last . Just $ execStateT (toMailPart part) initialPart }
addPart :: ( MonadMail m

41
src/Utils.hs
View File

@ -23,6 +23,7 @@ import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CBS
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
@ -298,6 +299,46 @@ citext2lower = Text.toLower . CI.original
citext2string :: CI Text -> String
citext2string = Text.unpack . CI.original
-- | Convert or remove all non-ascii characters, e.g. for filenames
text2asciiAlphaNum :: Text -> Text
text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
. Text.replace "ä" "ae"
. Text.replace "Ä" "Ae"
. Text.replace "Æ" "ae"
. Text.replace "æ" "ae"
. Text.replace "Å" "Aa"
. Text.replace "å" "aa"
. Text.replace "â" "a"
. Text.replace "à" "a"
. Text.replace "á" "a"
. Text.replace "Ö" "Oe"
. Text.replace "ö" "oe"
. Text.replace "œ" "oe"
. Text.replace "Ø" "Oe"
. Text.replace "ø" "oe"
. Text.replace "ò" "o"
. Text.replace "ò" "o"
. Text.replace "ò" "o"
. Text.replace "ó" "o"
. Text.replace "Ü" "Ue"
. Text.replace "ü" "ue"
. Text.replace "ù" "u"
. Text.replace "ú" "u"
. Text.replace "û" "u"
. Text.replace "ë" "e"
. Text.replace "ê" "e"
. Text.replace "è" "e"
. Text.replace "é" "e"
. Text.replace "ï" "i"
. Text.replace "î" "i"
. Text.replace "ì" "i"
. Text.replace "í" "i"
. Text.replace "ß" "ss"
. Text.replace "ç" "c"
. Text.replace "ş" "s"
. Text.replace "ğ" "g"
. Text.replace "ñ" "n"
-- | Convert text as it is to Html, may prevent ambiguous types
-- This function definition is mainly for documentation purposes
text2Html :: Text -> Html

4
src/Utils/Icon.hs
View File

@ -110,6 +110,7 @@ data Icon
| IconReset
| IconBlocked
| IconPrintCenter
| IconLetter
| IconAt
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
deriving anyclass (Universe, Finite, NFData)
@ -200,6 +201,7 @@ iconText = \case
IconReset -> "undo" -- From fontawesome v6 onwards: "arrow-rotate-left"
IconBlocked -> "ban"
IconPrintCenter -> "mail-bulk" -- From fontawesome v6 onwards: "envelope-bulk"
IconLetter -> "mail-bulk" -- Problem "envelope" already used for email as well
IconAt -> "at"
nullaryPathPiece ''Icon $ camelToPathPiece' 1
@ -300,7 +302,7 @@ iconExamRegister True = icon IconExamRegisterTrue
iconExamRegister False = icon IconExamRegisterFalse
iconLetterOrEmail :: Bool -> Markup
iconLetterOrEmail True = icon IconPrintCenter
iconLetterOrEmail True = icon IconLetter
iconLetterOrEmail False = icon IconAt
----------------

3
src/Utils/Print.hs
View File

@ -278,7 +278,8 @@ sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse p
nameSender = abbrvName <$> sender
nameCourse = CI.original . courseShorthand <$> course
nameQuali = CI.original . qualificationShorthand <$> quali
let jobFullName = T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
let jobFullName = text2asciiAlphaNum $
T.replace " " "-" (T.intercalate "_" . catMaybes $ [Just printJobName, nameQuali, nameCourse, nameSender, nameRecipient])
printJobFilename = T.unpack $ jobFullName <> ".pdf"
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
printJobFile = LBS.toStrict pdf

13
templates/i18n/test/de-de-formal.hamlet Normal file
View File

@ -0,0 +1,13 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
Diese Datei ist nur zum testen von i18nHamlet gedacht.
<p>
Ein wesentliches Merkmale dieser Datei ist, #
dass es keine Abhängigkeiten gibt.

13
templates/i18n/test/en-eu.hamlet Normal file
View File

@ -0,0 +1,13 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
<section>
<h2>
This file is only for testing i18nHamlet
<p>
That the file has no external dependencies
is a central feature of this file.

32
templates/letter/fraport_renewal.md
View File

@ -1,22 +1,22 @@
---
### Metadaten, welche hier eingestellt werden:
# Absender
de-subject: Verlängerung Vorfeldführerschein
en-subject: Renewal of apron driving License
de-subject: 'Verlängerung Fahrberechtigung "F" (Vorfeldführerschein)'
en-subject: Renewal of apron driving license
author: Fraport AG - Fahrerausbildung (AVN-AR)
phone: +49 69 690-30306
phone: +49 69 690-28467
email: fahrerausbildung@fraport.de
place: Frankfurt/Main
place: Frankfurt am Main
return-address:
- 60547 Frankfurt
de-opening: Sehr geehrte Damen und Herren,
en-opening: Dear driver,
de-closing: |
Mit freundlichen Grüßen,
Ihre Fahrerausbildung.
Ihre Fahrerausbildung
en-closing: |
Best wishes,
Your fraport driving instructors from "Fahrerausbildung".
With kind regards,
Your Fraport Driver Training
encludes:
hyperrefoptions: hidelinks
@ -53,8 +53,8 @@ $endfor$
$if(is-de)$
<!-- deutsche Version des Briefes -->
die Gültigkeit Ihres Vorfeldführerscheines läuft demnächst ab, am $expiry$.
Durch die erfolgreiche Teilnahme an einem E-Lernen können Sie die Gültigkeit
die Gültigkeit Ihres Vorfeldführerscheins läuft demnächst ab, am $expiry$.
Durch die erfolgreiche Teilnahme an einem E-Learning können Sie die Gültigkeit
$if(validduration)$
um $validduration$ Monate
$endif$
@ -70,7 +70,7 @@ URL
: [$url-text$]($url$)
Sobald die Frist abgelaufen ist, muss zur Wiedererlangung des Vorfeldführerscheins
Sobald die Frist abgelaufen ist, muss zur Wiedererlangung der Fahrberechtigung "F"
erneut der Grundkurs bei der Fahrerausbildung absolviert werden.
@ -80,13 +80,13 @@ $else$
<!-- englische Version des Briefes -->
your apron diving licence is about to expire soon, on $expiry$.
You may renew your apron driving licence
your apron diving license is about to expire soon, on $expiry$.
You can extend the validity
$if(validduration)$
by $validduration$ month
by $validduration$ months
$endif$
through successfully
completing an e-learning course. Please use the login data from the protected area below.
by successfully participating in
an e-learning. Please use the login data from the protected area below.
Examinee
@ -97,7 +97,7 @@ URL
:[$url-text$]($url$)
Should your apron driving licence expire before completing this
Should your apron driving license expire before completing this
e-learning course, then a renewal requires your full participation
of the basic training course again.