Merge branch 'master' into fradrive/api-avs

CHANGELOG.md

@@ -2,6 +2,40 @@
 
 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.4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.3...v26.5.4) (2022-09-21)
+
+
+### Bug Fixes
+
+* **notifications:** qualification renewals are more robust and not sent multiple times at once ([1cdd52e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1cdd52e96c727139d6cd630da5117fd3b4aa5a7f))
+
+## [26.5.3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.2...v26.5.3) (2022-09-16)
+
+## [26.5.2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.1...v26.5.2) (2022-09-14)
+
+
+### Bug Fixes
+
+* **lms:** trigger userlist job after upload ([cceb600](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cceb60074fbb26d7ed2d10a1c37297fa6e52292a))
+
+## [26.5.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.5.0...v26.5.1) (2022-09-14)
+
+## [26.5.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.4.0...v26.5.0) (2022-09-09)
+
+
+### Features
+
+* **lpr:** print center allows filtering by day now ([cac4870](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cac4870c95f5367536ee48644fea8a526a0da5a3))
+
+## [26.4.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.3.1...v26.4.0) (2022-09-08)
+
+
+### Features
+
+* **avs:** add SetRampDrivingLicence and InfoRampDrivingLicence to AVS interface ([a1272e3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a1272e38b72d146b881492341a86e1fc544ab0ff))
+* **lms:** configurable csv settings for lms direct import and export routes ([6159403](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6159403b27dab30178645dc37c99d41b4aaf610c))
+* **users:** allow users to set postal address and email encryption password ([655fcf7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/655fcf756471a2dfc6380e4b63236ca8d5229e11))
+
 ## [26.3.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v26.3.0...v26.3.1) (2022-09-03)
 
 

config/settings.yml

@@ -125,6 +125,13 @@ ldap:
 
 ldap-re-test-failover: 60
 
+lms-direct:
+  upload-header:        "_env:LMSUPLOADHEADER:true"
+  upload-delimiter:     "_env:LMSUPLOADDELIMITER:"
+  download-header:      "_env:LMSDOWNLOADHEADER:true"
+  download-delimiter:   "_env:LMSDOWNLOADDELIMITER:,"
+  download-cr-lf:       "_env:LMSDOWNLOADCRLF:true"
+
 avs:
   host:    "_env:AVSHOST:skytest.fra.fraport.de"
   port:    "_env:AVSPORT:443"

lpr

@@ -0,0 +1,5 @@
+#!/usr/bin/env bash
+
+printf "lpr dummy called, arguments ignored.\n"
+printf "Nothing is printed."
+exit 0

messages/uniworx/categories/authorization/de-de-formal.msg

@@ -106,7 +106,7 @@ PWHashLoginTitle: FRADrive Login
 PWHashLoginNote: Verwenden Sie dieses Formular für zugesandte FRADrive Logindaten. Angestellte der Fraport AG sollten stattdessen den Büko-Login verwenden!
 DummyLoginTitle: Development-Login
 InternalLdapError: Interner Fehler beim Fraport Büko-Login
-CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation
+CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
 CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
 CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
 CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln

messages/uniworx/categories/jobs_handler/de-de-formal.msg

@@ -17,4 +17,4 @@ InvitationAcceptDecline: Einladung annehmen/ablehnen
 InvitationFromTip displayName@Text: Sie erhalten diese Einladung, weil #{displayName} ihren Versand in FRADrive ausgelöst hat.
 InvitationFromTipAnonymous: Sie erhalten diese Einladung, weil ein nicht eingeloggter Benutzer/eine nichteingeloggte Benutzerin ihren Versand in FRADrive ausgelöst hat.
 InvitationUniWorXTip: FRADrive ist ein webbasiertes Schulungsverwaltungssystem der Fraport AG.
-LinkActiveUntil time@Text: Der Link ist nur bis #{time} aktiv!
+LinkActiveUntil time@Text: Dieser Link ist nur bis #{time} aktiv!

messages/uniworx/categories/jobs_handler/en-eu.msg

@@ -17,4 +17,4 @@ InvitationAcceptDecline: Accept/Decline invitation
 InvitationFromTip displayName: You are receiving this invitation because #{displayName} has caused it to be sent from within FRADrive.
 InvitationFromTipAnonymous: You are receiving this invitiation because an user who didn't log in has caused it to be send from within FRADrive.
 InvitationUniWorXTip: FRADrive is a web based training management system at Fraport AG.
-LinkActiveUntil time@Text: The link is only active until #{time}!
+LinkActiveUntil time@Text: This link is only active until #{time}!

messages/uniworx/categories/qualification/de-de-formal.msg

@@ -12,6 +12,7 @@ TableQualificationCountTotal: Gesamt
 LmsQualificationValidUntil: Gültig bis
 TableQualificationLastRefresh: Zuletzt erneuert
 TableQualificationFirstHeld: Erstmalig
+TableQualificationBlockedDue: Suspendiert
 LmsUser: Inhaber
 TableLmsEmail: E-Mail
 TableLmsIdent: Identifikation
@@ -23,12 +24,14 @@ TableLmsDelete: Löschen?
 TableLmsStaff: Interner Mitarbeiter?
 TableLmsStarted: Begonnen
 TableLmsReceived: Letzte Rückmeldung
+TableLmsNotified: Versand Benachrichtigung
 TableLmsEnded: Beended
 TableLmsStatus: Status E-Lernen
 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
 CsvColumnLmsResetPin: Wird die PIN bei der nächsten Synchronisation zurückgesetzt?
@@ -48,7 +51,7 @@ MailSubjectQualificationRenewal qname@Text: Qualifikation #{qname} muss demnäch
 MailSubjectQualificationExpiry qname@Text: Qualifikation #{qname} läuft demnächst ab
 MailBodyQualificationRenewal: Sie müssen diese Qualifikaton demnächst durch einen E-Lernen Kurs erneuern.
 MailBodyQualificationExpiry: Diese Qualifikaton läuft bald ab. Tätigkeiten, welche diese Qualifikation voraussetzen dürfen dann nicht länger ausgeübt werden!
-LmsRenewalInstructions: Anweisungen zur Verlängerung finden Sie im angehängten PDF. Um Missbrauch zu verhindern wurde das PDF dem von Ihnen in FRADrive hinterlegten PIN-Passwort verschlüsselt. Falls kein PIN-Passwort hinterlegt wurde, ist das Passwort ihre Fraport Ausweisnummer, inklusive Punkt und der Ziffer danach.
+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
@@ -59,7 +62,7 @@ LmsActionFailed n@Int: Aktion nicht durchgeführt für #{n} #{pluralDE n "Person
 MppOpening: Anrede
 MppClosing: Grußformel
 MppDate: Datum
-MppURL: Link Prüfung
+MppURL: Link E-Lernen
 MppLogin !ident-ok: Login
 MppPin !ident-ok: Pin
 MppRecipient: Empfänger

messages/uniworx/categories/qualification/en-eu.msg

@@ -12,6 +12,7 @@ TableQualificationCountTotal: Total
 LmsQualificationValidUntil: Valid until
 TableQualificationLastRefresh: Last renewed
 TableQualificationFirstHeld: First held
+TableQualificationBlockedDue: Suspended
 LmsUser: Licensee
 TableLmsEmail: Email
 TableLmsIdent: Identifier
@@ -23,12 +24,14 @@ TableLmsDelete: Delete?
 TableLmsStaff: Staff?
 TableLmsStarted: Started
 TableLmsReceived: Last update
+TableLmsNotified: Notification sent
 TableLmsEnded: Ended
 TableLmsStatus: Status e-learning
 TableLmsSuccess: Completed
 TableLmsFailed: Blocked
 FilterLmsValid: Currently valid
 FilterLmsRenewal: Renewal due
+FilterLmsNotified: Notified
 CsvColumnLmsIdent: E-learning identifier, unique for each qualification and user
 CsvColumnLmsPin: PIN for e-learning access
 CsvColumnLmsResetPin: Will the e-learning PIN be reset upon next synchronisation?
@@ -48,7 +51,7 @@ MailSubjectQualificationRenewal qname@Text: Qualification #{qname} must be renew
 MailSubjectQualificationExpiry qname@Text: Qualification #{qname} expires soon
 MailBodyQualificationRenewal: You will soon need to renew this qualficiation by completing an e-learning course.
 MailBodyQualificationExpiry: This qualificaton expires soon. You may then no longer execute any duties that require this qualification as a precondition!
-LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PIN-Password. If you have not yet chosen a PIN-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter.
+LmsRenewalInstructions: Instruction on how to accomplish the renewal are enclosed in the attached PDF. In order to avoid misuse, the PDF is encrypted with your chosen FRADrive PDF-Password. If you have not yet chosen a PDF-Password yet, then the password is your Fraport id card number, inkluding the punctuation mark and the Digit thereafter.
 LmsNoRenewal: Unfortunately, this particular qualification cannot be renewed through E-learning only. 
 LmsActNotify: Resend e-learning notification by post or email
 LmsActRenewPin: Randomly replace e-learning PIN
@@ -59,7 +62,7 @@ LmsActionFailed n@Int: No action for #{n} #{pluralENs n "person"}, since there w
 MppOpening: Opening
 MppClosing: Closing
 MppDate: Date
-MppURL: Link Examination
+MppURL: Link e-learning
 MppLogin: Login
 MppPin: Pin
 MppRecipient: Recipient

messages/uniworx/categories/send/send_notifications/de-de-formal.msg

@@ -130,6 +130,8 @@ UserAuthModePWHashChangedToLDAP: Sie können sich nun mit Ihrer Fraport AG Kennu
 UserAuthModeLDAPChangedToPWHash: Sie können sich nun mit einer FRADrive-internen Kennung einloggen
 AuthPWHashTip: Sie müssen nun das mit "FRADrive-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden.
 PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail.
+MailFradrive !ident-ok: FRADrive
+MailBodyFradrive: ist die Führerscheinverwaltungsapp der Fraport AG.
 
 #userRightsUpdate.hs + templates
 MailSubjectUserRightsUpdate name@Text: Berechtigungen für #{name} aktualisiert

messages/uniworx/categories/send/send_notifications/en-eu.msg

@@ -130,6 +130,8 @@ UserAuthModePWHashChangedToLDAP: You can now log in to FRADrive using your Frapo
 UserAuthModeLDAPChangedToPWHash: You can now log in using your FRADrive-internal account
 AuthPWHashTip: You now need to use the login form labeled "FRADrive login". Please ensure that you have already set a password when you try to log in.
 PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email.
+MailFradrive: FRADrive
+MailBodyFradrive: is the apron driving licence management app of Fraport AG.
 
 #userRightsUpdate.hs + templates
 MailSubjectUserRightsUpdate name: Permissions for #{name} changed

messages/uniworx/categories/settings/de-de-formal.msg

@@ -27,9 +27,10 @@ WarningDaysTip: Wie viele Tage im Voraus sollen Fristen von Prüfungen etc. auf
 ShowSex: Geschlechter anderer Nutzer:innen anzeigen
 ShowSexTip: Sollen in Kursteilnehmer:innen-Tabellen u.Ä. die Geschlechter der Nutzer:innen angezeigt werden?
 
-PDFPassword: Passwort zur Verschlüsselung von PDF Anhängen an Email Benachrichtigungen
+PDFPassword: Passwort zur Verschlüsselung von PDF Anhängen an Email Benachrichtigungens
 PDFPasswordTip: Achtung, dieses Passwort ist für FRADrive Administratoren einsehbar und wird unverschlüsselt gespeichert!
-PDFPasswordInvalid: Bitte ein nicht-triviales Passwort ohne Leerzeichen für PDF Email Anhänge eintragen!
+PDFPasswordInvalid c@Char: Bitte ein nicht-triviales Passwort für PDF Email Anhänge eintragen! Ungültiges Zeichen: #{char2Text c}
+PDFPasswordTooShort n@Int: Bitte ein PDF Passwort mit mindestens #{show n} Zeichen wählen.
 PrefersPostal: Sollen Benachrichtigung möglichst per Post versendet werden anstatt per Email?
 PostalTip: Postversand kann in Rechnung gestellt werden und ist derzeit nur für Benachrichtigungen über Erneuerung und Ablauf von Qualifikation, wie z.B. Führerscheine, verfügbar.
 PostAddress: Postalische Adresse

messages/uniworx/categories/settings/en-eu.msg

@@ -29,7 +29,8 @@ ShowSexTip: Should users' sex be displayed in (among others) lists of course par
 
 PDFPassword: Password to lock PDF email attachments
 PDFPasswordTip: Please note that this password is displayed to FRADrive admins and is saved unencrypted
-PDFPasswordInvalid: Please supply a sensible password for encrypting PDF email attachments!
+PDFPasswordInvalid c: Please supply a sensible password for encrypting PDF email attachments! Invalid character #{char2Text c}
+PDFPasswordTooShort n: Please provide a password with at least #{show n} characters.
 PrefersPostal: Should notifications preferably send by post instead of email?
 PostalTip: Mailing may incur a fee and is currently only avaulable for qualification expiry notifications, such as driving lincence renewal.
 PostAddress: Postal address

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -130,10 +130,12 @@ MenuLmsUsers: Export E-Lernen Benutzer
 MenuLmsUserlist: Melden E-Lernen Benutzer
 MenuLmsResult: Melden Ergebnisse E-Lernen
 MenuLmsUpload: Hochladen
-MenuLmsDirect: Direkter Upload
+MenuLmsDirectUpload: Direkter Upload
+MenuLmsDirectDownload: Direkter Download
 MenuLmsFake: Testnutzer generieren
 
 MenuAvs: Schnittstelle AVS
+MenuLdap: Schnittstelle LDAP
 MenuApc: Druckerei
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -131,10 +131,12 @@ MenuLmsUsers: Download E-Learning Users
 MenuLmsUserlist: Upload E-Learning Users
 MenuLmsResult: Upload E-Learning Results
 MenuLmsUpload: Upload
-MenuLmsDirect: Direct Upload
+MenuLmsDirectUpload: Direct Upload
+MenuLmsDirectDownload: Direct Download
 MenuLmsFake: Generate test users
 
 MenuAvs: AVS Interface
+MenuLdap: LDAP Interface
 MenuApc: Printing
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter

models/lms.model

@@ -4,8 +4,8 @@ Qualification
   shorthand           (CI Text)
   name                (CI Text)
   description         StoredMarkup Maybe        -- user-defined large Html, ought to contain full description
-  validDuration       Word Maybe                -- qualification is valid indefinitely or for a specified number of months
+  validDuration       Word Maybe                -- qualification is valid indefinitely or for a specified number of months, use with addMonthsDay
-  auditDuration       Word Maybe                -- number of month to keep audit log; or indefinitely
+  auditDuration       Word Maybe                -- 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!
@@ -49,8 +49,9 @@ QualificationUser
   user              UserId OnDeleteCascade OnUpdateCascade
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   validUntil        Day
-  lastRefresh       Day                     -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
+  lastRefresh       Day                           -- lastRefresh > validUntil possible, if Qualification^elearningOnly == False
-  firstHeld         Day                     -- first time the qualification was earned, should never change
+  firstHeld         Day                           -- first time the qualification was earned, should never change
+  blockedDue        QualificationBlocked Maybe    -- isJust means that the qualification is currently revoked
   -- temporärer Entzug vorsehen
   -- Begründungsfeld vorsehen
   UniqueQualificationUser qualification user
@@ -76,34 +77,35 @@ QualificationUser
   --     - For all LmsUser:
   --         + if contained:
   --              set LmsUserReceived to Just now()
-  --              if LmsUserlistFailed: set LmsUserStatus to Just Day  
+  --              if LmsUserlistFailed: set LmsUserStatus to Just LmsBlocked now
   --         + not contained, by LmsUserReceived is set: set LmsUserEnded to Just now()
   --     - move row to LmsAudit
   --
   -- 6. When received: Daily Job LmsResult:
-  --     - set LmsUserReceived to Just now()
+  --     - set LmsUserReceived to Just now()             -- always
-  --     - set LmsUserStatus  to Just Day    -- always
+  --     - set LmsUserStatus   to Just LmsSuccess now    -- conditional
+  --     -   and renew QualificationValidTo
   --     - move row to LmsAudit
   --
   -- 7. Daily Job: dequeue LMS Users
-  --     - renew qualification, if passed
   --     - remove from LmsUser after audit Period has passed
 
 LmsUser
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
-  user              UserId OnDeleteCascade OnUpdateCascade
+  user              UserId          OnDeleteCascade OnUpdateCascade
-  ident             LmsIdent                    -- must be unique accross all LMS courses!
+  ident             LmsIdent                      -- must be unique accross all LMS courses!
   pin               Text
-  resetPin          Bool          default=false -- should pin be reset?
+  resetPin          Bool            default=false -- should pin be reset?
-  datePin           UTCTime       default=now() -- time pin was created
+  datePin           UTCTime         default=now() -- time pin was created
-  status            LmsStatus Maybe             -- open, success or failure; isJust indicates user will be deleted from LMS 
+  status            LmsStatus Maybe               -- open, success or failure; status should never change unless isNothing; isJust indicates lms is finished and user shall be deleted from LMS
   --toDelete encoded by Handler.Utils.LMS.lmsUserToDelete
-  started           UTCTime       default=now()
+  started           UTCTime         default=now()
-  received          UTCTime Maybe               -- last acknowledgement by LMS 
+  received          UTCTime Maybe                 -- last acknowledgement by LMS
-  ended             UTCTime Maybe               -- ident was deleted from LMS 
+  notified          UTCTime Maybe                 -- last notified by FRADrive
+  ended             UTCTime Maybe                 -- ident was deleted from LMS
   -- Primary ident -- newtype Key LmsUserId = LmsUserKey { unLmsUser :: Text } -- change LmsIdent -> Text. Do we want this?
-  UniqueLmsIdent ident                           -- idents must be unique accross all qualifications, since idents are global within LMS!
+  UniqueLmsIdent ident                            -- idents must be unique accross all qualifications, since idents are global within LMS!
-  UniqueLmsQualificationUser qualification user  -- each user may be enrolled at most once per course
+  UniqueLmsQualificationUser qualification user   -- each user may be enrolled at most once per course
   deriving Generic
 
 -- LmsUserlist stores LMS upload for later processing only
@@ -111,7 +113,7 @@ LmsUserlist
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   ident             LmsIdent        
   failed            Bool
-  timestamp         UTCTime default=now()
+  timestamp         UTCTime         default=now()
   UniqueLmsUserlist qualification ident
   deriving Generic
 
@@ -120,7 +122,7 @@ LmsResult
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   ident             LmsIdent        
   success           Day
-  timestamp         UTCTime default=now()
+  timestamp         UTCTime         default=now()
   UniqueLmsResult qualification ident -- required by DBTable
   deriving Generic
 
@@ -129,6 +131,7 @@ LmsAudit
   qualification     QualificationId OnDeleteCascade OnUpdateCascade
   ident             LmsIdent
   notificationType  LmsStatus               -- LmsBlocked Day | LmsSuccess Day
+  note              Text Maybe
   received          UTCTime                 -- timestamp from LmsUserlist/LmsResult
-  processed         UTCTime default=now()
+  processed         UTCTime         default=now()
   deriving Generic

models/mail.model

@@ -3,7 +3,7 @@ SentMail
     sentBy       InstanceId
     objectId     MailObjectId Maybe
     bounceSecret BounceSecret Maybe
-    recipient    UserId Maybe
+    recipient    UserId Maybe OnDeleteCascade
     headers      MailHeaders
     contentRef   SentMailContentId
     deriving Generic

nix/docker/default.nix

@@ -38,6 +38,7 @@ let
       # just for manual testing within the pod, may be removef for production?
       curl wget netcat openldap 
       unixtools.netstat htop gnugrep
+      locale
     ] ++ optionals isDemo [ postgresql_12 memcached uniworx.uniworx.components.exes.uniworxdb ];
 
     runAsRoot = ''

nix/docker/demo-version.json

@@ -1,3 +1,3 @@
 {
-  "version": "26.3.1"
+  "version": "26.5.4"
 }

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "26.3.1"
+  "version": "26.5.4"
 }

package-lock.json

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

package.json

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

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 26.3.1
+version: 26.5.4
 dependencies:
   - base
   - yesod

routes

@@ -62,6 +62,7 @@
 /admin/tokens                 AdminTokensR     GET POST
 /admin/crontab                AdminCrontabR    GET
 /admin/avs                    AdminAvsR        GET POST
+/admin/ldap                   AdminLdapR       GET POST 
 
 /print                        PrintCenterR     GET POST        !system-printer
 /print/send                   PrintSendR       GET POST

src/Auth/LDAP.hs

@@ -5,7 +5,7 @@ module Auth.LDAP
   , ADError(..), ADInvalidCredentials(..)
   , campusLogin
   , CampusUserException(..)
-  , campusUser, campusUser'
+  , campusUser, campusUser', campusUser''
   , campusUserReTest, campusUserReTest'
   , campusUserMatr, campusUserMatr'
   , CampusMessage(..)
@@ -145,8 +145,11 @@ campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool
 
 campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
 campusUser' pool mode User{userIdent}
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap (CI.original userIdent) [])
+  = campusUser'' pool mode $ CI.original userIdent
 
+campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList []))
+campusUser'' pool mode ident
+  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident [])
 
 campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
 campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do

src/Database/Esqueleto/Utils.hs

@@ -14,6 +14,7 @@ module Database.Esqueleto.Utils
   , mkExactFilter, mkExactFilterWith
   , mkExactFilterLast, mkExactFilterLastWith
   , mkContainsFilter, mkContainsFilterWith
+  , mkDayFilter, mkDayFilterFrom, mkDayFilterTo
   , mkExistsFilter
   , anyFilter, allFilter
   , orderByList
@@ -222,7 +223,7 @@ mkExactFilterWith cast lenslike row criterias
 mkExactFilterLast :: (PersistField a)
                   => (t -> E.SqlExpr (E.Value a))  -- ^ getter from query to searched element
                   -> t                             -- ^ query row
-                  -> Last a                     -- ^ needle collection
+                  -> Last a                        -- ^ needle
                   -> E.SqlExpr (E.Value Bool)
 mkExactFilterLast = mkExactFilterLastWith id
 
@@ -231,7 +232,7 @@ mkExactFilterLastWith :: (PersistField b)
                       => (a -> b)                      -- ^ type conversion
                       -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
                       -> t                             -- ^ query row
-                      -> Last a                     -- ^ needle collection
+                      -> Last a                        -- ^ needle
                       -> E.SqlExpr (E.Value Bool)
 mkExactFilterLastWith cast lenslike row criterias
   | Last (Just crit) <- criterias = lenslike row E.==. E.val (cast crit)
@@ -258,6 +259,33 @@ mkContainsFilterWith cast lenslike row criterias
   | Set.null criterias = true
   | otherwise = any (hasInfix $ lenslike row) (E.val . cast <$> Set.toList criterias)
 
+
+mkDayFilter :: (t -> E.SqlExpr (E.Value UTCTime))  -- ^ getter from query to searched element
+            -> t                                   -- ^ query row
+            -> Last Day                            -- ^ a day to filter for 
+            -> E.SqlExpr (E.Value Bool)
+mkDayFilter lenslike row criterias 
+  | Last (Just crit) <- criterias = day (lenslike row) E.==. E.val crit
+  | otherwise = true
+
+
+mkDayFilterFrom :: (t -> E.SqlExpr (E.Value UTCTime))  -- ^ getter from query to searched element
+            -> t                                   -- ^ query row
+            -> Last Day                            -- ^ a day range to filter for 
+            -> E.SqlExpr (E.Value Bool)
+mkDayFilterFrom lenslike row criterias 
+  | Last (Just crit) <- criterias = day (lenslike row) E.>=. E.val crit
+  | otherwise = true
+
+mkDayFilterTo :: (t -> E.SqlExpr (E.Value UTCTime))  -- ^ getter from query to searched element
+            -> t                                   -- ^ query row
+            -> Last Day                            -- ^ a day range to filter for 
+            -> E.SqlExpr (E.Value Bool)
+mkDayFilterTo lenslike row criterias 
+  | Last (Just crit) <- criterias = day (lenslike row) E.<=. E.val crit
+  | otherwise = true
+
+
 mkExistsFilter :: PathPiece a
                => (t -> a -> E.SqlQuery ())
                -> t

src/Foundation/Navigation.hs

@@ -105,6 +105,7 @@ breadcrumb AdminErrMsgR     = i18nCrumb MsgMenuAdminErrMsg      $ Just AdminR
 breadcrumb AdminTokensR     = i18nCrumb MsgMenuAdminTokens      $ Just AdminR
 breadcrumb AdminCrontabR    = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR
 breadcrumb AdminAvsR        = i18nCrumb MsgMenuAvs              $ Just AdminR
+breadcrumb AdminLdapR       = i18nCrumb MsgMenuLdap             $ Just AdminR
 
 breadcrumb PrintCenterR       = i18nCrumb MsgMenuApc                Nothing
 breadcrumb PrintSendR         = i18nCrumb MsgMenuPrintSend        $ Just PrintCenterR
@@ -819,6 +820,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               , navQuick'      = mempty
               , navForceActive = False
               }
+          , NavLink
+              { navLabel       = MsgMenuLdap
+              , navRoute       = AdminLdapR
+              , navAccess'     = NavAccessTrue
+              , navType        = NavTypeLink { navModal = False }
+              , navQuick'      = mempty
+              , navForceActive = False
+              }    
           ]
       }
   , return NavHeaderContainer
@@ -2464,21 +2473,21 @@ pageActions (LmsR sid qsh) = return
   [ NavPageActionPrimary 
     { navLink = defNavLink MsgMenuLmsUsers $ LmsUsersR sid qsh
     , navChildren = 
-        [ defNavLink MsgMenuLmsDirect $ LmsUsersDirectR sid qsh 
+        [ defNavLink MsgMenuLmsDirectDownload $ LmsUsersDirectR sid qsh 
         ]
     }
   , NavPageActionPrimary 
     { navLink = defNavLink MsgMenuLmsUserlist $ LmsUserlistR sid qsh
     , navChildren = 
-        [ defNavLink MsgMenuLmsUpload $ LmsUserlistUploadR sid qsh        
+        [ defNavLink MsgMenuLmsUpload       $ LmsUserlistUploadR sid qsh        
-        , defNavLink MsgMenuLmsDirect $ LmsUserlistDirectR sid qsh        
+        , defNavLink MsgMenuLmsDirectUpload $ LmsUserlistDirectR sid qsh        
         ]
     }
   , NavPageActionPrimary 
     { navLink = defNavLink MsgMenuLmsResult $ LmsResultR sid qsh
     , navChildren = 
-        [ defNavLink MsgMenuLmsUpload $ LmsResultUploadR sid qsh        
+        [ defNavLink MsgMenuLmsUpload       $ LmsResultUploadR sid qsh        
-        , defNavLink MsgMenuLmsDirect $ LmsResultDirectR sid qsh        
+        , defNavLink MsgMenuLmsDirectUpload $ LmsResultDirectR sid qsh        
         ]
     }
   , NavPageActionSecondary { 

src/Foundation/Yesod/Auth.hs

@@ -1,6 +1,7 @@
 module Foundation.Yesod.Auth
   ( authenticate
   , upsertCampusUser
+  , decodeUserTest
   , CampusUserConversionException(..)
   , campusUserFailoverMode, updateUserLanguage
   ) where
@@ -154,124 +155,20 @@ upsertCampusUser :: forall m.
                  => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
 upsertCampusUser upsertMode ldapData = do
   now <- liftIO getCurrentTime
-  UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
+  userDefaultConf <- getsYesod $ view _appUserDefaults
 
-  let
+  (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
-    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
-    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
   
-    -- only accept a single result, throw error otherwise
+  oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
-    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-    decodeLdap1 attr err 
-      | [bs] <- ldapMap !!! attr 
-      , Right t <- Text.decodeUtf8' bs
-        = return t
-      | otherwise = throwM err
-    
-    -- accept any successful decoding or empty; only throw an error if all decodings fail
-    -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m Text
-    decodeLdap' attr err
-        | []    <-        vs = return   Nothing
-        | (h:_) <- rights vs = return $ Just h
-        | otherwise          = throwM err        
-      where 
-        vs = Text.decodeUtf8' <$> ldapMap !!! attr
-
-    -- just returns Nothing on error, pure
-    decodeLdap :: Ldap.Attr -> Maybe Text
-    decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
-
-    userTelephone             = decodeLdap ldapUserTelephone
-    userMobile                = decodeLdap ldapUserMobile
-    userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
-    userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
-
-    userAuthentication
-      | is _UpsertCampusUserLoginOther upsertMode
-      = error "Non-LDAP logins should only work for users that are already known"
-      | otherwise = AuthLDAP
-    userLastAuthentication = guardOn isLogin now
-    isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
-
-  userIdent <- if
-    | [bs] <- ldapMap !!! ldapUserPrincipalName
-    , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
-    , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
-      -> return userIdent'
-    | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
-      -> return userIdent'
-    | otherwise
-      -> throwM CampusUserInvalidIdent
-
-  userEmail <- if
-    | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-      -> return $ CI.mk userEmail
-    | otherwise
-      -> throwM CampusUserInvalidEmail
-  userFirstName <- decodeLdap1 ldapUserFirstName CampusUserInvalidGivenName
-  userSurname   <- decodeLdap1 ldapUserSurname   CampusUserInvalidSurname
-  userTitle     <- decodeLdap' ldapUserTitle     CampusUserInvalidTitle
-
-  userDisplayName' <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>= 
-    (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
-
-  userLdapPrimaryKey <- if
-    | [bs] <- ldapMap !!! ldapPrimaryKey
-    , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
-    , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-      -> return $ Just userLdapPrimaryKey'''
-    | otherwise
-      -> return Nothing
-
-  let
-    newUser = User
-      { userMaxFavourites           = userDefaultMaxFavourites
-      , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
-      , userTheme                   = userDefaultTheme
-      , userDateTimeFormat          = userDefaultDateTimeFormat
-      , userDateFormat              = userDefaultDateFormat
-      , userTimeFormat              = userDefaultTimeFormat
-      , userDownloadFiles           = userDefaultDownloadFiles
-      , userWarningDays             = userDefaultWarningDays
-      , userShowSex                 = userDefaultShowSex
-      , userSex                     = Nothing
-      , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
-      , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
-      , userNotificationSettings    = def
-      , userLanguages               = Nothing
-      , userCsvOptions              = def
-      , userTokensIssuedAfter       = Nothing
-      , userCreated                 = now
-      , userLastLdapSynchronisation = Just now      
-      , userDisplayName             = userDisplayName'
-      , userDisplayEmail            = userEmail
-      , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO      
-      , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
-      , userPinPassword             = Nothing -- must be derived via AVS
-      , userPrefersPostal           = False
-      , ..
-      }
-    userUpdate =  [
-                  -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
-                    UserFirstName               =. userFirstName
-                  , UserSurname                 =. userSurname
-                  , UserEmail                   =. userEmail
-                  , UserLastLdapSynchronisation =. Just now
-                  , UserLdapPrimaryKey          =. userLdapPrimaryKey
-                  , UserMobile                  =. userMobile
-                  , UserTelephone               =. userTelephone
-                  , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
-                  , UserCompanyDepartment       =. userCompanyDepartment
-                  ] ++
-                  [ UserLastAuthentication =. Just now | isLogin ]
-
-  oldUsers <- for userLdapPrimaryKey $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
 
   user@(Entity userId userRec) <- case oldUsers of
     Just [oldUserId] -> updateGetEntity oldUserId userUpdate
-    _other           -> upsertBy (UniqueAuthentication userIdent) newUser userUpdate
+    _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
-  unless (validDisplayName userTitle userFirstName userSurname $ userDisplayName userRec) $
+  unless (validDisplayName (newUser ^. _userTitle) 
-    update userId [ UserDisplayName =. userDisplayName' ]
+                           (newUser ^. _userFirstName)
+                           (newUser ^. _userSurname) 
+                           (userRec ^. _userDisplayName)) $
+    update userId [ UserDisplayName =. (newUser ^. _userDisplayName) ]
 
   let
     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
@@ -289,6 +186,141 @@ upsertCampusUser upsertMode ldapData = do
 
   return user
 
+decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
+        => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
+decodeUserTest mbIdent ldapData = do
+    now <- liftIO getCurrentTime
+    userDefaultConf <- getsYesod $ view _appUserDefaults
+    let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
+    try $ decodeUser now userDefaultConf mode ldapData
+
+
+decodeUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
+decodeUser now UserDefaultConf{..} upsertMode ldapData = do
+    let
+      userTelephone             = decodeLdap ldapUserTelephone
+      userMobile                = decodeLdap ldapUserMobile
+      userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
+      userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
+
+      userAuthentication
+        | is _UpsertCampusUserLoginOther upsertMode
+                    = AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
+        | otherwise = AuthLDAP
+      userLastAuthentication = guardOn isLogin now
+      isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
+
+      userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
+      userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
+      userSurname     = decodeLdap' ldapUserSurname   -- CampusUserInvalidSurname
+    userDisplayName <- decodeLdap1  ldapUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
+
+    --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
+    -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
+
+    userIdent <- if
+      | [bs] <- ldapMap !!! ldapUserPrincipalName
+      , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
+      , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
+        -> return userIdent'
+      | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
+        -> return userIdent'
+      | otherwise
+        -> throwM CampusUserInvalidIdent
+
+    userEmail <- if
+      | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
+        -> return $ CI.mk userEmail
+      | otherwise
+        -> throwM CampusUserInvalidEmail
+        
+    userLdapPrimaryKey <- if
+      | [bs] <- ldapMap !!! ldapPrimaryKey
+      , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
+      , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
+        -> return $ Just userLdapPrimaryKey'''
+      | otherwise
+        -> return Nothing
+
+    let
+      newUser = User
+        { userMaxFavourites           = userDefaultMaxFavourites
+        , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
+        , userTheme                   = userDefaultTheme
+        , userDateTimeFormat          = userDefaultDateTimeFormat
+        , userDateFormat              = userDefaultDateFormat
+        , userTimeFormat              = userDefaultTimeFormat
+        , userDownloadFiles           = userDefaultDownloadFiles
+        , userWarningDays             = userDefaultWarningDays
+        , userShowSex                 = userDefaultShowSex
+        , userSex                     = Nothing
+        , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
+        , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
+        , userNotificationSettings    = def
+        , userLanguages               = Nothing
+        , userCsvOptions              = def
+        , userTokensIssuedAfter       = Nothing
+        , userCreated                 = now
+        , userLastLdapSynchronisation = Just now
+        , userDisplayName             = userDisplayName
+        , userDisplayEmail            = userEmail
+        , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+        , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+        , userPinPassword             = Nothing -- must be derived via AVS
+        , userPrefersPostal           = False
+        , ..
+        }
+      userUpdate =  [
+                    -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+                      UserFirstName               =. userFirstName
+                    , UserSurname                 =. userSurname
+                    , UserEmail                   =. userEmail
+                    , UserLastLdapSynchronisation =. Just now
+                    , UserLdapPrimaryKey          =. userLdapPrimaryKey
+                    , UserMobile                  =. userMobile
+                    , UserTelephone               =. userTelephone
+                    , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
+                    , UserCompanyDepartment       =. userCompanyDepartment
+                    ] ++
+                    [ UserLastAuthentication =. Just now | isLogin ]
+    return (newUser, userUpdate)
+
+  where
+    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
+    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
+
+    -- just returns Nothing on error, pure
+    decodeLdap :: Ldap.Attr -> Maybe Text
+    decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
+
+    decodeLdap' :: Ldap.Attr -> Text
+    decodeLdap' = fromMaybe "" . decodeLdap
+    -- accept the first successful decoding or empty; only throw an error if all decodings fail
+    -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
+    -- decodeLdap' attr err
+    --     | []    <-        vs = return   Nothing
+    --     | (h:_) <- rights vs = return $ Just h
+    --     | otherwise          = throwM err
+    --   where
+    --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+
+    -- only accepts the first successful decoding, ignoring all others, but failing if there is none
+    -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
+    decodeLdap1 attr err
+        | (h:_) <- rights vs  = return h
+        | otherwise           = throwM err
+      where
+        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+
+    -- accept and merge one or more successful decodings, ignoring all others
+    -- decodeLdapN attr err
+    --     | t@(_:_) <- rights vs
+    --       = return $ Text.unwords t
+    --     | otherwise = throwM err
+    --   where
+    --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+
+
 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
 associateUserSchoolsByTerms uid = do
   sfs <- selectList [StudyFeaturesUser ==. uid] []

src/Handler/Admin.hs

@@ -9,6 +9,7 @@ import Handler.Admin.ErrorMessage as Handler.Admin
 import Handler.Admin.Tokens as Handler.Admin
 import Handler.Admin.Crontab as Handler.Admin
 import Handler.Admin.Avs as Handler.Admin
+import Handler.Admin.Ldap as Handler.Admin
 
 getAdminR :: Handler Html
 getAdminR =

src/Handler/Admin/Avs.hs

@@ -51,7 +51,7 @@ validateAvsQueryStatus = do
   AvsQueryStatus ids <- State.get
   guardValidation (MsgAvsQueryStatusInvalid $ tshow ids) $ not (null ids)
 
-getAdminAvsR, postAdminAvsR :: Handler Html
+getAdminAvsR,  postAdminAvsR :: Handler Html
 getAdminAvsR = postAdminAvsR
 postAdminAvsR = do
   mAvsQuery <- getsYesod $ view _appAvsQuery

src/Handler/Admin/Ldap.hs

@@ -0,0 +1,81 @@
+
+
+module Handler.Admin.Ldap
+  ( getAdminLdapR
+  , postAdminLdapR
+  ) where
+
+import Import
+-- import qualified Control.Monad.State.Class as State
+-- import Data.Aeson (encode)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+-- import qualified Data.Set  as Set
+import Foundation.Yesod.Auth (decodeUserTest)
+
+import Handler.Utils
+
+import qualified Ldap.Client as Ldap
+import Auth.LDAP
+
+newtype LdapQueryPerson = LdapQueryPerson
+      { ldapQueryIdent :: Text
+      -- , ldapQueryName  :: Maybe Text
+      -- , ldapQueryPNum  :: Maybe Text
+      }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable)
+
+makeLdapPersonForm :: Maybe LdapQueryPerson -> Form LdapQueryPerson
+makeLdapPersonForm tmpl = validateForm validateLdapQueryPerson $ \html ->
+  flip (renderAForm FormStandard) html $ LdapQueryPerson
+    <$> areq textField (fslI MsgAdminUserIdent)           (ldapQueryIdent  <$> tmpl)
+    -- <*> aopt textField (fslI MsgAdminUserSurname)         (ldapQueryName   <$> tmpl)
+    -- <*> aopt textField (fslI MsgAdminUserFPersonalNumber) (ldapQueryPNum   <$> tmpl)
+
+validateLdapQueryPerson :: FormValidator LdapQueryPerson Handler ()
+validateLdapQueryPerson = return () -- currently no tests needed
+  --LdapQueryPerson{..} <- State.get
+  --guardValidation MsgAvsQueryEmpty 
+    --is _Just ldapQueryIdent         ||
+    --is _Just ldapQueryName          ||
+    --is _Just ldapQueryPNum
+
+
+
+getAdminLdapR,  postAdminLdapR :: Handler Html
+getAdminLdapR = postAdminLdapR 
+postAdminLdapR = do
+  ((presult, pwidget), penctype) <- runFormPost $ makeLdapPersonForm Nothing
+
+  let procFormPerson :: LdapQueryPerson -> Handler (Maybe (Ldap.AttrList []))
+      procFormPerson LdapQueryPerson{..} = do     
+        ldapPool'       <- getsYesod $ view _appLdapPool
+
+        if isNothing ldapPool'
+          then addMessage Warning $ text2Html "LDAP Configuration missing."
+          else addMessage Info    $ text2Html "Input for LDAP test received."
+        fmap join . for ldapPool' $ \ldapPool -> do 
+          ldapData <- campusUser'' ldapPool FailoverUnlimited ldapQueryIdent
+          decodedErr <- decodeUserTest (Just $ CI.mk ldapQueryIdent) $ concat ldapData
+          whenIsLeft decodedErr $ addMessageI Error 
+          return ldapData
+
+          
+  mbLdapData <- formResultMaybe presult procFormPerson
+
+
+  actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
+  siteLayoutMsg MsgMenuLdap $ do
+    setTitleI MsgMenuLdap
+    let personForm = wrapForm pwidget def
+                      { formAction = Just $ SomeRoute actionUrl
+                      , formEncoding = penctype
+                      }
+
+        presentUtf8   lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)      
+        presentLatin1 lv = Text.intercalate ", " (                 Text.decodeLatin1 <$> lv)
+
+    -- TODO: use i18nWidgetFile instead if this is to become permanent
+    $(widgetFile "ldap")
+

src/Handler/LMS.hs

@@ -178,11 +178,13 @@ data LmsTableCsv = LmsTableCsv   -- L..T..C.. -> ltc..
   , ltcValidUntil  :: Day
   , ltcLastRefresh :: Day
   , ltcFirstHeld   :: Day
+  , ltcBlockedDue  :: Maybe QualificationBlocked
   , ltcLmsIdent    :: Maybe LmsIdent
   , ltcLmsStatus   :: Maybe LmsStatus
   , ltcLmsStarted  :: Maybe UTCTime
   , ltcLmsDatePin  :: Maybe UTCTime
   , ltcLmsReceived :: Maybe UTCTime
+  , ltcLmsNotified :: Maybe UTCTime
   , ltcLmsEnded    :: Maybe UTCTime
   }
   deriving Generic
@@ -192,19 +194,23 @@ ltcExample :: LmsTableCsv
 ltcExample = LmsTableCsv 
     { ltcDisplayName = "Max Mustermann"
     , ltcEmail       = "m.mustermann@does.not.exist"
-    , ltcValidUntil  = compday
+    , ltcValidUntil  = compDay
-    , ltcLastRefresh = compday
+    , ltcLastRefresh = compDay
-    , ltcFirstHeld   = compday
+    , ltcFirstHeld   = compDay
+    , ltcBlockedDue  = Nothing
     , ltcLmsIdent    = Nothing
     , ltcLmsStatus   = Nothing
-    , ltcLmsStarted  = Nothing
+    , ltcLmsStarted  = Just compTime
     , ltcLmsDatePin  = Nothing
     , ltcLmsReceived = Nothing
+    , ltcLmsNotified = Nothing
     , ltcLmsEnded    = Nothing
     }
   where 
-    compday :: Day 
+    compTime :: UTCTime
-    compday = utctDay $compileTime
+    compTime = $compileTime
+    compDay :: Day 
+    compDay = utctDay compTime
 
 ltcOptions :: Csv.Options
 ltcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
@@ -338,11 +344,13 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
       , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
       , single ("last-refresh", SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
       , single ("first-held"  , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
+      , single ("blocked-due" , SortColumn $ queryQualUser >>> (E.^. QualificationUserBlockedDue))
       , single ("lms-ident"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserIdent))
       , single ("lms-status"  , SortColumn $ views (to queryLmsUser) (E.?. LmsUserStatus))
       , 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-ended"   , SortColumn $ queryLmsUser  >>> (E.?. LmsUserEnded))
       ]
     dbtFilter = mconcat
@@ -356,12 +364,20 @@ 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 $ \(view (to queryLmsUser) -> luser) criterion ->
+      --    case getLast criterion of
+      --      Just True  -> E.isJust    $ luser E.?. LmsUserNotified
+      --      Just False -> E.isNothing $ luser E.?. LmsUserNotified
+      --      Nothing    -> E.true
+      --  )
       ]
     dbtFilterUI mPrev = mconcat
       [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
-      , prismAForm (singletonFilter "lms-ident"   . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
+      , prismAForm (singletonFilter "lms-ident"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableLmsIdent)
       -- , prismAForm (singletonFilter "lms-status"  . maybePrism _PathPiece) mPrev $ aopt (selectField' (Just $ SomeMessage MsgTableNoFilter) $ return (optionsPairs [(MsgTableLmsSuccess,"success"::Text),(MsgTableLmsFailed,"blocked")])) (fslI MsgTableLmsStatus)
-      , prismAForm (singletonFilter "validity"    . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+      , prismAForm (singletonFilter "validity"     . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
+      , prismAForm (singletonFilter "lms-notified" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsNotified)
       , if isNothing mbRenewal then mempty
         else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
       ]
@@ -383,11 +399,13 @@ mkLmsTable (Entity qid quali) acts restrict cols psValidator = do
           <*>  view    (resultQualUser . _entityVal . _qualificationUserValidUntil)
           <*>  view    (resultQualUser . _entityVal . _qualificationUserLastRefresh)
           <*>  view    (resultQualUser . _entityVal . _qualificationUserFirstHeld)
+          <*>  view    (resultQualUser . _entityVal . _qualificationUserBlockedDue)
           <*>  preview (resultLmsUser  . _entityVal . _lmsUserIdent)
           <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserStatus))
           <*>  preview (resultLmsUser  . _entityVal . _lmsUserStarted)
           <*>  preview (resultLmsUser  . _entityVal . _lmsUserDatePin)
           <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserReceived))
+          <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserNotified))
           <*> (join . preview (resultLmsUser  . _entityVal . _lmsUserEnded))
     dbtCsvDecode = Nothing
     dbtExtraReps = []
@@ -438,14 +456,16 @@ postLmsR sid qsh = do
           [ dbSelectIf (applying _2) id (return . view (resultUser . _entityKey)) (\r -> isJust $ r ^? resultLmsUser) -- TODO: refactor using  function "is"
           , colUserNameLinkHdr MsgLmsUser AdminUserR
           , colUserEmail
-          , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil) $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
+          , sortable (Just "valid-until")   (i18nCell MsgLmsQualificationValidUntil)   $ \(   view $ resultQualUser . _entityVal . _qualificationUserValidUntil  -> d)  -> dayCell d
           , sortable (Just "last-refresh")  (i18nCell MsgTableQualificationLastRefresh)$ \(   view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d)  -> dayCell d
           , sortable (Just "first-held")    (i18nCell MsgTableQualificationFirstHeld)  $ \(   view $ resultQualUser . _entityVal . _qualificationUserFirstHeld   -> d)  -> dayCell d
+          , sortable (Just "blocked-due")   (i18nCell MsgTableQualificationBlockedDue) $ \(   view $ resultQualUser . _entityVal . _qualificationUserBlockedDue  -> b)  -> qualificationBlockedCell b
           , sortable (Just "lms-ident")     (i18nLms MsgTableLmsIdent)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserIdent . _getLmsIdent -> lid) -> foldMap textCell lid
           , sortable (Just "lms-status")    (i18nLms MsgTableLmsStatus)   $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStatus -> status)            -> foldMap lmsStatusCell $ join status
           , sortable (Just "lms-started")   (i18nLms MsgTableLmsStarted)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserStarted  -> d) -> foldMap dateTimeCell        d
           , sortable (Just "lms-datepin")   (i18nLms MsgTableLmsDatePin)  $ \(preview $ resultLmsUser  . _entityVal . _lmsUserDatePin  -> d) -> foldMap dateTimeCell        d
           , sortable (Just "lms-received")  (i18nLms MsgTableLmsReceived) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserReceived -> d) -> foldMap dateTimeCell $ join d
+          , sortable (Just "lms-notified")  (i18nLms MsgTableLmsNotified) $ \(preview $ resultLmsUser  . _entityVal . _lmsUserNotified -> d) -> foldMap dateTimeCell $ join d
           , sortable (Just "lms-ended")     (i18nLms MsgTableLmsEnded)    $ \(preview $ resultLmsUser  . _entityVal . _lmsUserEnded    -> d) -> foldMap dateTimeCell $ join d
           ]
           where

src/Handler/LMS/Fake.hs

@@ -113,6 +113,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
                   qualificationUserValidUntil    = addDays expOffset expiryNotifyDay
                   qualificationUserFirstHeld     = addGregorianMonthsClip (-24) qualificationUserValidUntil
                   qualificationUserLastRefresh   = qualificationUserFirstHeld
+                  qualificationUserBlockedDue    = Nothing
               _ <- upsert QualificationUser{..} 
                           [ QualificationUserValidUntil  =. qualificationUserValidUntil
                           , QualificationUserLastRefresh =. qualificationUserLastRefresh

src/Handler/LMS/Result.hs

@@ -29,9 +29,9 @@ data LmsResultTableCsv = LmsResultTableCsv
   deriving Generic
 makeLenses_ ''LmsResultTableCsv
 
--- csv without headers -- TODO not yet supported
+-- csv without headers
---instance Csv.ToRecord   LmsResultTableCsv -- default suffices
+instance Csv.ToRecord   LmsResultTableCsv -- default suffices
---instance Csv.FromRecord LmsResultTableCsv -- default suffices
+instance Csv.FromRecord LmsResultTableCsv -- default suffices
 
 -- csv with headers
 lmsResultTableCsvHeader :: Csv.Header
@@ -262,10 +262,11 @@ postLmsResultDirectR sid qsh = do
   (_params, files) <- runRequestBody
   (status, msg) <- case files of
     [(fhead,file)] -> do
+      lmsDecoder <- getLmsCsvDecoder
       runDBJobs $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
         enr <- try $ runConduit $ fileSource file
-                .| decodeCsv
+                .| lmsDecoder
                 .| foldMC (saveResultCsv qid) 0
         case enr of
           Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
@@ -273,8 +274,8 @@ postLmsResultDirectR sid qsh = do
             return (badRequest400, "Exception: " <> tshow e)
           Right nr -> do
             let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
-            $logWarnS "LMS" msg -- TODO: change to Info Level in the future
+            $logInfoS "LMS" msg
-            queueDBJob $ JobLmsResults qid
+            when (nr > 0) $ queueDBJob $ JobLmsResults qid
             return (ok200, msg)
     []     -> do
       let msg = "Result upload file missing."

src/Handler/LMS/Userlist.hs

@@ -28,9 +28,9 @@ data LmsUserlistTableCsv = LmsUserlistTableCsv
   deriving Generic
 makeLenses_ ''LmsUserlistTableCsv
 
--- csv without headers -- TODO not yet supported
+-- csv without headers
---instance Csv.ToRecord   LmsUserlistTableCsv
+instance Csv.ToRecord   LmsUserlistTableCsv
---instance Csv.FromRecord LmsUserlistTableCsv
+instance Csv.FromRecord LmsUserlistTableCsv
 
 -- csv with headers
 instance DefaultOrdered LmsUserlistTableCsv where
@@ -258,10 +258,11 @@ postLmsUserlistDirectR sid qsh = do
   (_params, files) <- runRequestBody
   (status, msg) <- case files of
     [(fhead,file)] -> do
+      lmsDecoder <- getLmsCsvDecoder
       runDBJobs $ do
         qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
         enr <- try $ runConduit $ fileSource file
-                .| decodeCsv
+                .| lmsDecoder
                 .| foldMC (saveUserlistCsv qid) 0
         case enr of
           Left (e :: SomeException) -> do
@@ -269,8 +270,8 @@ postLmsUserlistDirectR sid qsh = do
             return (badRequest400, "Exception: " <> tshow e)
           Right nr -> do
             let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for header " <> fhead
-            $logWarnS "LMS" msg -- TODO: change to Info Level in the future
+            $logInfoS "LMS" msg 
-            queueDBJob $ JobLmsResults qid
+            when (nr > 0) $ queueDBJob $ JobLmsUserlist qid
             return (ok200, msg)
     []     -> do
       let msg = "Userlist upload file missing."
@@ -281,4 +282,3 @@ postLmsUserlistDirectR sid qsh = do
       $logWarnS "LMS" msg
       return (badRequest400, msg)
   sendResponseStatus status msg
-  

src/Handler/LMS/Users.hs

@@ -39,9 +39,9 @@ lmsUser2csv lu@LmsUser{..} = LmsUserTableCsv
   , csvLUTstaff     = False              & LmsBool
   }
 
--- csv without headers -- TODO not yet supported
+-- csv without headers
--- instance Csv.ToRecord   LmsUserTableCsv
+instance Csv.ToRecord   LmsUserTableCsv
--- instance Csv.FromRecord LmsUserTableCsv
+instance Csv.FromRecord LmsUserTableCsv
 
 -- csv with headers
 lmsUserTableCsvHeader :: Csv.Header
@@ -165,11 +165,19 @@ getLmsUsersDirectR sid qsh = do
           , csvLUTstaff    = LmsBool False
           }
       -}
-  let csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users      
+  LmsConf{..} <- getsYesod $ view _appLmsConf
-      csvRenderedHeader = lmsUserTableCsvHeader      
+  let --csvRenderedData = toNamedRecord . lmsUser2csv . entityVal <$> lms_users
+      --csvRenderedHeader = lmsUserTableCsvHeader
+      --cvsRendered = CsvRendered {..}
+      csvRendered = toCsvRendered lmsUserTableCsvHeader $ lmsUser2csv . entityVal <$> lms_users
+      fmtOpts = def { csvIncludeHeader  = lmsDownloadHeader
+                    , csvDelimiter      = lmsDownloadDelimiter
+                    , csvUseCrLf        = lmsDownloadCrLf
+                    }
+      csvOpts = def { csvFormat = fmtOpts }
   csvSheetName <- csvFilenameLmsUser qsh
   addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
-  csvRenderedToTypedContent csvSheetName CsvRendered{..}  
+  csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
 
 -- direct Download see:
 -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod

src/Handler/PrintCenter.hs

@@ -183,12 +183,6 @@ mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
 mkPJTable = do
   currentRoute <- fromMaybe (error "mkPJTable called from 404-handler") <$> liftHandler getCurrentRoute -- albeit we do know the route here
   let
-    showId :: PrintJobId -> Widget
-    showId k = do
-      c <- encrypt k
-      let f :: CryptoUUIDPrintJob -> Text
-          f x = toPathPiece x
-      [whamlet|#{f c}|]
     dbtSQLQuery = pjTableQuery
     dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
     dbtProj = dbtProjFilteredPostId
@@ -196,10 +190,9 @@ mkPJTable = do
       [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged)
       , sortable (Just "pj-created")      (i18nCell MsgPrintJobCreated)       $ \(   view $ resultPrintJob . _entityVal . _printJobCreated      -> t) ->      dateTimeCell t
       , sortable (Just "pj-acknowledged") (i18nCell MsgPrintJobAcknowledged)  $ \(   view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t
-      , sortable (Just "pj-filename")     (i18nCell MsgPrintJobFilename)      $ \(   view $ resultPrintJob . _entityVal . _printJobFilename     -> t) -> textCell t 
+      , sortable (Just "pj-filename")     (i18nCell MsgPrintPDF)  $ \r -> let k = r ^. resultPrintJob . _entityKey
-      , sortable (toNothingS "pdf")       (i18nCell MsgPrintPDF)              $ \(   view $ resultPrintJob . _entityKey -> k) -> anchorCellM (PrintDownloadR <$> encrypt k)  (showId k)
+                                                                              t = r ^. resultPrintJob . _entityVal . _printJobFilename
-      -- , sortable (Just "pj-id")           (i18nCell MsgPrintJobId)            $ \(   view $ resultPrintJob . _entityKey                         -> k) -> textCell (tshow . E.unSqlBackendKey $ unPrintJobKey k)
+                                                                          in anchorCellM (PrintDownloadR <$> encrypt k) (toWgt t)
-      -- , sortable (Just "pj-id")           (i18nCell MsgPrintJobId)            $ \(   view $ resultPrintJob . _entityKey                         -> k) -> cell (showId k)      
       , sortable (Just "pj-name")         (i18nCell MsgPrintJobName)          $ \(   view $ resultPrintJob . _entityVal . _printJobName         -> n) -> textCell n
       , sortable (Just "pj-recipient")    (i18nCell MsgPrintRecipient)        $ \(preview resultRecipient -> u) -> maybeCell u $ cellHasUserLink AdminUserR
       , sortable (Just "pj-sender")       (i18nCell MsgPrintSender)           $ \(preview resultSender    -> u) -> maybeCell u $ cellHasUserLink AdminUserR
@@ -209,7 +202,6 @@ mkPJTable = do
     dbtSorting = mconcat
       [ single ("pj-name"         , SortColumn $ queryPrintJob      >>> (E.^. PrintJobName))
       , single ("pj-filename"     , SortColumn $ queryPrintJob      >>> (E.^. PrintJobFilename))
-      -- , single ("pj-id"           , SortColumn $ queryPrintJob      >>> (E.^. PrintJobId))
       , single ("pj-created"      , SortColumn $ queryPrintJob      >>> (E.^. PrintJobCreated))
       , single ("pj-acknowledged" , SortColumn $ queryPrintJob      >>> (E.^. PrintJobAcknowledged))
       , single ("pj-recipient"    , sortUserNameBareM queryRecipient)
@@ -220,6 +212,8 @@ mkPJTable = do
     dbtFilter = mconcat
       [ single ("pj-name"         , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobName))
       , single ("pj-filename"     , FilterColumn . E.mkContainsFilter          $ views (to queryPrintJob)      (E.^. PrintJobFilename))
+      , single ("pj-created"      , FilterColumn . E.mkDayFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
+      --, single ("pj-created"      , FilterColumn . E.mkDayBetweenFilter               $ views (to queryPrintJob)      (E.^. PrintJobCreated))
       , single ("pj-recipient"    , FilterColumn . E.mkContainsFilterWith Just $ views (to queryRecipient)     (E.?. UserDisplayName))
       , single ("pj-sender"       , FilterColumn . E.mkContainsFilterWith Just $ views (to querySender)        (E.?. UserDisplayName))
       , single ("pj-course"       , FilterColumn . E.mkContainsFilterWith Just $ views (to queryCourse)        (E.?. CourseName))
@@ -227,8 +221,12 @@ mkPJTable = do
       , single ("acknowledged"    , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
       ]
     dbtFilterUI mPrev = mconcat
-      [ prismAForm (singletonFilter "pj-filename"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobFilename)
+      [ prismAForm (singletonFilter "pj-name"         . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobName)
-      , prismAForm (singletonFilter "pj-name"         . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobName)
+      , prismAForm (singletonFilter "pj-filename"     . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintJobFilename)
+      , prismAForm (singletonFilter "pj-created"      . maybePrism _PathPiece) mPrev $ aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
+      --, prismAForm (singletonFilter "pj-created"      . maybePrism _PathPiece) mPrev ((,) <$> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
+      --                                                                                  <*> aopt (hoistField lift  dayField)                        (fslI MsgPrintJobCreated)
+      --                                                                          )
       , prismAForm (singletonFilter "pj-recipient"    . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField)                        (fslI MsgPrintRecipient)
       , 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)
@@ -307,7 +305,7 @@ postPrintSendR = do
             -- liftIO $ LBS.writeFile "/tmp/generated.pdf" bs -- DEBUGGING ONLY
             -- addMessage Warning "PDF momentan nur gespeicher unter /tmp/generated.pdf"
             uID <- maybeAuthId
-            runDB (sendLetter "Test-Brief" bs mbRecipient uID Nothing Nothing) >>= \case -- calls lpr 
+            runDB (sendLetter "Test-Brief" bs (mbRecipient, uID) Nothing Nothing) >>= \case -- calls lpr
               Left err -> do
                 let msg = "PDF printing failed with error: " <> err
                 $logErrorS "LPR" msg

src/Handler/Profile.hs

@@ -439,11 +439,14 @@ validateSettings :: User -> FormValidator SettingsForm Handler ()
 validateSettings User{..} = do
   userDisplayName' <- use _stgDisplayName
   guardValidation MsgUserDisplayNameInvalid $
+    userDisplayName == userDisplayName' ||  -- unchanged or valid (invalid displayNames delivered by LDAP are preserved)
     validDisplayName userTitle userFirstName userSurname userDisplayName'    
 
   userPinPassword'  <- use _stgPinPassword
-  guardValidation MsgPDFPasswordInvalid $
+  let pinBad = validCmdArgument userPinPassword' 
-    validCmdArgument userPinPassword' -- used as CMD argument for pdftk
+      pinMinChar = 5
+  whenIsJust pinBad (tellValidationError . MsgPDFPasswordInvalid) -- used as CMD argument for pdftk
+  guardValidation (MsgPDFPasswordTooShort pinMinChar) $ pinMinChar <= length userPinPassword'
 
   userPostAddress'  <- use _stgPostAddress
   let postalNotSet  = isNothing userPostAddress'

src/Handler/Utils/Csv.hs

@@ -1,7 +1,7 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Handler.Utils.Csv
-  ( decodeCsv, decodeCsvPositional
+  ( decodeCsv, decodeCsvPositional, decodeCsvWith
   , encodeCsv, encodeCsvWith, encodeCsvRendered, encodeCsvRenderedWith
   , csvRenderedToTypedContent, csvRenderedToTypedContentWith
   , expectedCsvFormat, expectedCsvContentType
@@ -87,6 +87,15 @@ decodeCsv = decodeCsv' $ \opts -> fromNamedCsvStreamError opts (review _haltingC
 decodeCsvPositional :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromRecord csv) => HasHeader -> ConduitT ByteString csv m ()
 decodeCsvPositional hdr = decodeCsv' $ \opts -> fromCsvStreamError opts hdr (review _haltingCsvParseError) .| throwIncrementalErrors
 
+decodeCsvWith :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => CsvOptions -> ConduitT ByteString csv m ()
+decodeCsvWith opts 
+  | csvIncludeHeader fmtOpts
+    = decodeCsv' $ \_ -> fromNamedCsvStreamError decOpts (review _haltingCsvParseError) .| throwIncrementalErrors
+  | otherwise
+    = decodeCsv' $ \_ -> fromCsvStreamError decOpts NoHeader (review _haltingCsvParseError) .| throwIncrementalErrors
+  where 
+    fmtOpts = csvFormat opts
+    decOpts = DecodeOptions { decDelimiter = fromIntegral $ Char.ord $ csvDelimiter fmtOpts }
 
 decodeCsv' :: forall csv m.
               ( MonadHandler m, HandlerSite m ~ UniWorX

src/Handler/Utils/DateTime.hs

@@ -4,7 +4,7 @@ module Handler.Utils.DateTime
   ( utcToLocalTime, utcToZonedTime
   , localTimeToUTC, TZ.LocalToUTCResult(..), localTimeToUTCSimple
   , toTimeOfDay
-  , toMidnight, beforeMidnight, toMidday, toMorning
+  , toMidnight, beforeMidnight, toMidday, toMorning, addHours
   , formatDiffDays, formatCalendarDiffDays
   , formatTime'
   , formatTime, formatTimeUser, formatTimeW, formatTimeMail
@@ -12,9 +12,10 @@ module Handler.Utils.DateTime
   , getTimeLocale, getDateTimeFormat
   , getDateTimeFormatter
   , validDateTimeFormats, dateTimeFormatOptions
-  , addLocalDays, addDiffDays, addMonths
+  , addLocalDays
+  , addDiffDaysClip, addDiffDaysRollOver
   , addOneWeek, addWeeks
-  , fromMonths
+  , fromDays, fromMonths
   , weeksToAdd
   , setYear, getYear
   , firstDayOfWeekOnAfter
@@ -73,6 +74,9 @@ toMorning = toTimeOfDay 6 0 0
 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
 toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
 
+addHours :: Integer -> UTCTime -> UTCTime
+addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600)
+
 instance HasLocalTime UTCTime where
   toLocalTime = utcToLocalTime
 
@@ -261,15 +265,17 @@ addLocalDays n utct = localTimeToUTCTZ appTZ newLocal
 -- CalendarDiffDays --
 ----------------------
 
-fromMonths :: Word -> CalendarDiffDays 
+fromMonths :: Integral a => a -> CalendarDiffDays 
-fromMonths m = scaleCalendarDiffDays (toInteger m) calendarMonth
+fromMonths (toInteger -> m) = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
--- fromMonths m = CalendarDiffDays { cdMonths = m, cdDays = 0 } -- above is equivalent
 
-addDiffDays :: CalendarDiffDays -> UTCTime -> UTCTime
+fromDays :: Integral a => a -> CalendarDiffDays 
-addDiffDays = over _utctDay . addGregorianDurationClip
+fromDays (toInteger -> d) = CalendarDiffDays { cdMonths = 0, cdDays = d }
 
-addMonths :: Word -> UTCTime -> UTCTime
+addDiffDaysClip :: CalendarDiffDays -> UTCTime -> UTCTime
-addMonths = addDiffDays . fromMonths
+addDiffDaysClip = over _utctDay . addGregorianDurationClip
+
+addDiffDaysRollOver :: CalendarDiffDays -> UTCTime -> UTCTime
+addDiffDaysRollOver = over _utctDay . addGregorianDurationRollOver
 
 weeksToAdd :: UTCTime -> UTCTime -> Integer
 -- ^ Number of weeks needed to add so that first

src/Handler/Utils/Form.hs

@@ -2067,6 +2067,7 @@ csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs
              <*> apreq (selectField lineEndOpts)   (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev)
              <*> apreq (selectField quoteOpts)     (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev)
              <*> apreq (selectField encodingOpts)  (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev)
+             <*> pure True
       FormatXlsx -> pure CsvXlsxFormatOptions
 
     delimiterOpts :: Handler (OptionList Char)

src/Handler/Utils/LMS.hs

@@ -1,7 +1,8 @@
 {-# OPTIONS -Wno-redundant-constraints #-} -- needed for Getter
 
 module Handler.Utils.LMS
-  ( csvLmsIdent
+  ( getLmsCsvDecoder
+  , csvLmsIdent
   , csvLmsTimestamp
   , csvLmsBlocked
   , csvLmsSuccess
@@ -21,11 +22,27 @@ module Handler.Utils.LMS
 
 import Import
 import Handler.Utils
+import Handler.Utils.Csv
+import Data.Csv (HasHeader(..), FromRecord)
+
 import qualified Database.Esqueleto.Legacy as E
 
 import Control.Monad.Random.Class (uniform)
 import Control.Monad.Trans.Random (evalRandTIO)
 
+
+getLmsCsvDecoder :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadThrow m, FromNamedRecord csv, FromRecord csv) => Handler (ConduitT ByteString csv m ())
+getLmsCsvDecoder = do
+  LmsConf{..} <- getsYesod $ view _appLmsConf
+  if  | Just upDelim <- lmsUploadDelimiter -> do
+        let fmtOpts = def { csvDelimiter     = upDelim
+                          , csvIncludeHeader = lmsUploadHeader
+                          }
+            csvOpts = def { csvFormat = fmtOpts }
+        return $ decodeCsvWith csvOpts
+      | lmsUploadHeader -> return   decodeCsv
+      | otherwise       -> return $ decodeCsvPositional NoHeader
+
 -- generic Column names
 csvLmsIdent   :: IsString a => a
 csvLmsIdent = fromString "user" -- "Benutzerkennung"
@@ -120,5 +137,4 @@ randomLMSIdent = LmsIdent <$> randomText [] lengthIdent
 randomLMSpw :: MonadIO m => m Text
 randomLMSpw = randomText extra lengthPassword
   where
-    extra = "_-+*.:;=!?#"
+    extra = "-+*.:;=!?#$"
-  

src/Handler/Utils/Profile.hs

@@ -14,12 +14,16 @@ import qualified Data.Text.Lazy as LT
 import qualified Data.MultiSet as MultiSet
 import qualified Data.Set as Set
 
+-- | Instead of CI.mk, this still allows use of Text.isInfixOf, etc.
+stripFold :: Text -> Text 
+stripFold = Text.toCaseFold . Text.strip
+
 -- | remove last comma and swap order of the two parts, ie. transforming "surname, givennames" into "givennames surname".
 --   Input "givennames surname" is left unchanged, except for removing excess whitespace
 fixDisplayName :: UserDisplayName -> UserDisplayName 
 fixDisplayName udn = 
   let (Text.strip . Text.dropEnd 1 -> surname, Text.strip -> firstnames) = Text.breakOnEnd "," udn 
-  in Text.strip $ firstnames <> Text.cons ' ' surname
+  in Text.toTitle $ Text.strip $ firstnames <> Text.cons ' ' surname
 
 -- | Like `validDisplayName` but may return an automatically corrected name
 checkDisplayName :: Maybe UserTitle -> UserFirstName -> UserSurname -> UserDisplayName -> Maybe UserDisplayName
@@ -32,7 +36,7 @@ validDisplayName :: Maybe UserTitle
                  -> UserSurname
                  -> UserDisplayName
                  -> Bool
-validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -> sName) (Text.strip -> dName)
+validDisplayName (fmap stripFold -> mTitle) (stripFold -> fName) (stripFold -> sName) (stripFold -> dName)
   = and [ dNameFrags `MultiSet.isSubsetOf` MultiSet.unions [titleFrags, fNameFrags, sNameFrags]
         , sName `Text.isInfixOf` dName
         , all ((<= 1) . Text.length) . filter (Text.any isAdd) $ Text.group dName
@@ -54,6 +58,7 @@ validDisplayName (fmap Text.strip -> mTitle) (Text.strip -> fName) (Text.strip -
     splitAdd = Text.split isAdd
     makeMultiSet = MultiSet.fromList . filter (not . Text.null) . splitAdd
     
+
 -- | Primitive postal address requires at least one alphabetic character, one digit and a line break
 validPostAddress :: Maybe StoredMarkup -> Bool
 validPostAddress (Just StoredMarkup {markupInput = addr})

src/Handler/Utils/Table/Cells.hs

@@ -316,3 +316,7 @@ lmsStatusCell ls = iconCell ic <> spacerCell <> dayCell (lmsStatusDay ls)
   where 
     ic | isLmsSuccess ls = IconOK
        | otherwise       = IconNotOK
+
+qualificationBlockedCell :: IsDBTable m a => Maybe QualificationBlocked -> DBCell m a
+qualificationBlockedCell Nothing   = mempty 
+qualificationBlockedCell (Just qb) = iconCell IconBlocked <> msgCell qb <> dayCell (qualificationBlockedDay qb)

src/Jobs/Handler/LMS.hs

@@ -18,22 +18,27 @@ import qualified Database.Esqueleto.Experimental as E
 -- import qualified Database.Esqueleto.PostgreSQL as E -- for insertSelect variant
 import qualified Database.Esqueleto.Utils as E
 
-import Handler.Utils.DateTime (fromMonths, addMonths)
+import Handler.Utils.DateTime 
 import Handler.Utils.LMS (randomLMSIdent, randomLMSpw, maxLmsUserIdentRetries)
 
+import qualified Data.CaseInsensitive as CI
+
 
 dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
-dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic act
+dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
-  where
+
-    act :: YesodJobDB UniWorX ()
+dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
-    act = do 
+dispatchJobLmsQualificationsDequeue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsDequeue
-      qids <- E.select $ do 
+
-                q <- E.from $ E.table @Qualification
+-- execute given job for all qualifications that allow refreshs
-                E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
+fetchRefreshQualifications :: (QualificationId -> Job) -> YesodJobDB UniWorX ()
-                    -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
+fetchRefreshQualifications qidJob = do
-                pure $ q E.^. QualificationId
+  qids <- E.select $ do
-      forM_ qids $ \(E.unValue -> qid) ->
+            q <- E.from $ E.table @Qualification
-        queueDBJob $ JobLmsEnqueue qid 
+            E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
+            pure $ q E.^. QualificationId
+  forM_ qids $ \(E.unValue -> qid) ->
+    queueDBJob $ qidJob qid
 
 
 -- | enlist expiring qualification holders to e-learning
@@ -43,8 +48,9 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
     act = do    
-      $logInfoS "lms" $ "Start e-learning users for qualification " <> tshow qid <> "."        
       quali <- getJust qid -- may throw an error, aborting the job
+      let qshort = CI.original $ qualificationShorthand quali
+      $logInfoS "lms" $ "Notifying about exipiring qualification " <> qshort
       now <- liftIO getCurrentTime
       case qualificationRefreshWithin quali of
         Nothing -> return () -- no automatic scheduling for this qid
@@ -72,11 +78,6 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
                               NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
                          }
           forM_ renewalUsers (queueDBJob . usr_job)
-      case qualificationAuditDuration quali of 
-        Nothing -> return () -- no automatic removal
-        (Just auditDuration) -> 
-          let deleteDate = addMonths auditDuration now
-          in  deleteWhere [LmsUserQualification ==. qid, LmsUserEnded !=. Nothing, LmsUserEnded >. Just deleteDate]
 
 dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
 dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
@@ -94,109 +95,114 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
             , lmsUserStatus        = Nothing
             , lmsUserStarted       = now
             , lmsUserReceived      = Nothing
+            , lmsUserNotified      = Nothing
             , lmsUserEnded         = Nothing
             }
           -- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
           startLmsUser = E.insertUniqueEntity =<< (mkLmsUser <$> randomLMSIdent <*> randomLMSpw)
       inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
       case inserted of
-        Nothing  -> $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uid " <> tshow uid <> " and qid " <> tshow qid <> "!"
+        Nothing  -> do
-        (Just _) -> queueDBJob JobSendNotification { jRecipient = uid, jNotification = 
+          uuid :: CryptoUUIDUser <- encrypt uid
-                        NotificationQualificationRenewal { nQualification = qid }
+          $logErrorS "LMS" $ "Generating and inserting fresh LmsIdent failed for uuid " <> tshow uuid <> " and qid " <> tshow qid <> "!"
-                      }
+        (Just _) -> return () -- lmsUser started, but not yet notified
 
 
-dispatchJobLmsQualificationsDequeue :: JobHandler UniWorX
+-- purge LmsIdent adter QualificationAuditDuration expired
-dispatchJobLmsQualificationsDequeue = JobHandlerAtomic act
-  where
-    act :: YesodJobDB UniWorX ()
-    act = do 
-      qids <- E.select $ do 
-                q <- E.from $ E.table @Qualification
-                E.where_ $  E.isJust (q E.^. QualificationRefreshWithin)
-                    -- E.&&. q E.^. QualificationElearningStart -- checked later, since we need to send out notifications regardless
-                pure $ q E.^. QualificationId
-      forM_ qids $ \(E.unValue -> qid) ->        
-        queueDBJob $ JobLmsEnqueue qid 
-
 dispatchJobLmsDequeue :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsDequeue qid = JobHandlerAtomic act  
-  -- wenn bestanden: qualification verlängern 
-  -- wenn Aufbewahrungszeit abgelaufen: LmsIdent löschen (verhindert verfrühten neustart)
   where
     act = do      
-      $logInfoS "lms" $ "Process e-learning results for qualification " <> tshow qid <> "."        
       quali <- getJust qid -- may throw an error, aborting the job
-      case qualificationRefreshWithin quali of 
+      let qshort = CI.original $ qualificationShorthand quali
-        Nothing -> return () -- no automatic scheduling for this qid 
+      $logInfoS "lms" $ "Processing e-learning results for qualification " <> qshort
-        (Just renewalPeriod) -> do
+      now <- liftIO getCurrentTime
-          now_day <- utctDay <$> liftIO getCurrentTime
+      -- purge LmsUsers 
-          let renewalDate = addGregorianDurationClip renewalPeriod now_day
+      case qualificationAuditDuration quali of
-          
+        Nothing -> return () -- no automatic removal
-          -- CONTINUE HERE:
+        (Just auditDuration) -> do
-          --   select users that need renewal due to success
+          let auditCutoff = addDiffDaysRollOver (fromMonths $ negate auditDuration) now
-          --   delete users after audit period has expired            
+          delusersVals <- E.select $ do
-
+            luser <- E.from $ E.table @LmsUser
-          renewalUsers <- E.select $ do
+            E.where_ $  luser E.^. LmsUserQualification E.==. E.val qid
-            (quser E.:& luser) <- E.from $ E.table @QualificationUser `E.innerJoin` E.table @LmsUser
+                  E.&&. luser E.^. LmsUserEnded         E.<.  E.just (E.val auditCutoff)
-                    `E.on` (\(quser E.:& luser) -> quser E.^. QualificationUserUser          E.==. luser E.^. LmsUserUser
+                  E.&&. E.isJust (luser E.^. LmsUserEnded)
-                                            E.&&.  quser E.^. QualificationUserQualification E.==. luser E.^. LmsUserQualification
+                  E.&&. E.notExists (do
-                            )
+                          laudit <- E.from $ E.table @LmsAudit
-            E.where_ $  E.val qid E.==. quser E.^. QualificationUserQualification 
+                          E.where_ $  laudit E.^. LmsAuditQualification E.==. E.val qid
-                  E.&&. E.val qid E.==. luser E.^. LmsUserQualification             
+                              E.&&.   laudit E.^. LmsAuditIdent         E.==. luser E.^. LmsUserIdent
-                  E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val now_day              -- still valid
+                              E.&&.   laudit E.^. LmsAuditProcessed     E.>=. E.val auditCutoff
-                  E.&&. quser E.^. QualificationUserValidUntil E.<=. E.val renewalDate          -- due to renewal
+                        )
-                  E.&&. E.isJust (luser E.^. LmsUserStatus) -- TODO: should check for success   -- result already known                                 
+            pure (luser E.^. LmsUserIdent)
-            pure (quser, luser)
+          let numdel = length delusers
-          let usr_job (quser, luser) = 
+              delusers = E.unValue <$> delusersVals          
-                let vold   = quser ^. _entityVal . _qualificationUserValidUntil
+          deleteWhere [LmsUserQualification     ==. qid, LmsUserIdent     <-. delusers]
-                    pmonth = fromMonths $ fromMaybe 0 $ qualificationValidDuration quali -- TODO: decide how to deal with qualification that have infinite validity?!
+          deleteWhere [LmsUserlistQualification ==. qid, LmsUserlistIdent <-. delusers]
-                    vnew   = addGregorianDurationClip pmonth vold
+          deleteWhere [LmsResultQualification   ==. qid, LmsResultIdent   <-. delusers]
-                    lmsstatus = luser ^. _entityVal . _lmsUserStatus
+          deleteWhere [LmsAuditQualification    ==. qid, LmsAuditIdent    <-. delusers]
-                in case lmsstatus of 
+          when (numdel > 0) $ $logInfoS "lms" $ "Deleting " <> tshow numdel <> " LmsIdents due to audit duration expiry for qualification " <> qshort
-                  Just (LmsSuccess refreshDay) -> update (quser ^. _entityKey) [QualificationUserValidUntil =. vnew, QualificationUserLastRefresh =. refreshDay] 
-                  _ -> return ()
-          forM_ renewalUsers usr_job
 
 
+-- processes received results and lengthen qualifications, if applicable
 dispatchJobLmsResults :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsResults qid = JobHandlerAtomic act
   where
     -- act :: YesodJobDB UniWorX ()
     act = hoist lift $ do
+      quali <- getJust qid
       now <- liftIO getCurrentTime
-      -- result :: [(Entity LmsUser, Entity LmsResult)]
+      let nowadayP1 = succ $ utctDay now -- add one day to account for time synch problems
+          renewalMonths :: Word = fromMaybe (error ("Cannot renew qualification " <> citext2string (qualificationShorthand quali) <> " without specified validDuration!"))
+                                            (qualificationValidDuration quali)
+      -- result :: [(Entity QualificationUser, Entity LmsUser, Entity LmsResult)]
       results <- E.select $ do
-        (luser E.:& lresult) <- E.from $ 
+        (quser E.:& luser E.:& lresult) <- E.from $
-            E.table @LmsUser `E.innerJoin` E.table @LmsResult 
+            E.table @QualificationUser  -- table not needed if renewal from lms completion day is used TODO: decide!
-            `E.on` (\(luser E.:& lresult) -> luser E.^. LmsUserIdent         E.==. lresult E.^. LmsResultIdent 
+            `E.innerJoin` E.table @LmsUser 
-                                       E.&&. luser E.^. LmsUserQualification E.==. lresult E.^. LmsResultQualification)
+            `E.on` (\(quser E.:& luser) -> 
-        E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
+                            luser E.^. LmsUserUser           E.==. quser   E.^. QualificationUserUser 
-          E.&&. E.isNothing (luser E.^. LmsUserEnded) -- do not process closed learners
+                      E.&&. luser E.^. LmsUserQualification  E.==. quser   E.^. QualificationUserQualification)
-        return (luser, lresult)
+            `E.innerJoin` E.table @LmsResult 
-      forM_ results $ \(Entity luid luser, Entity lrid lresult) -> do 
+            `E.on` (\(_ E.:& luser E.:& lresult) -> 
+                            luser E.^. LmsUserIdent          E.==. lresult E.^. LmsResultIdent
+                      E.&&. luser E.^. LmsUserQualification  E.==. lresult E.^. LmsResultQualification)
+        E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
+          E.&&.    luser E.^. LmsUserQualification           E.==. E.val qid
+          E.&&. E.isNothing (luser E.^. LmsUserStatus)  -- do not process learners already having a result
+          E.&&. E.isNothing (luser E.^. LmsUserEnded)   -- do not process closed learners
+        return (quser, luser, lresult)
+      forM_ results $ \(Entity quid QualificationUser{..}, Entity luid LmsUser{..}, Entity lrid LmsResult{..}) -> do
         -- three separate DB operations per result is not so nice. All within one transaction though.
-        let lreceived = lmsResultTimestamp lresult 
+        let lmsUserStartedDay = utctDay lmsUserStarted
-            newStatus = lmsResultSuccess   lresult & LmsSuccess 
+            saneDate    = lmsResultSuccess `inBetween` (lmsUserStartedDay, min qualificationUserValidUntil nowadayP1)
-            oldStatus = lmsUserStatus luser
+                          && qualificationUserLastRefresh <= lmsUserStartedDay
-            saneDate  = lmsResultSuccess   lresult `inBetween` (utctDay $ lmsUserStarted luser, utctDay now)
+            newStatus   = LmsSuccess lmsResultSuccess
-        -- always log success, since this is only transmitted once
+            newValidTo  = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil -- renew from old validUntil onwards
-        if saneDate 
+        note <- if saneDate && isLmsSuccess newStatus
-          then  
+          then do
-            update luid [ LmsUserStatus   =. (oldStatus <> Just newStatus)
+            update quid [ QualificationUserValidUntil  =. newValidTo
-                        , LmsUserReceived =. Just lreceived 
+                        , QualificationUserLastRefresh =. lmsResultSuccess
                         ]
-          else 
+            update luid [ LmsUserStatus   =. Just newStatus
-            $logErrorS "LmsResult" [st|LMS success with insane date #{tshow (lmsResultSuccess lresult)} received|]
+                        , LmsUserReceived =. Just lmsResultTimestamp
-        insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lreceived now
+                        ]            
+            return Nothing
+          else do
+            let errmsg = [st|LMS success with insane date #{tshow lmsResultSuccess} received for #{tshow lmsUserIdent}|]
+            $logErrorS "LmsResult" errmsg
+            return $ Just errmsg
+
+        insert_ $ LmsAudit qid lmsUserIdent newStatus note lmsResultTimestamp now -- always log success, since this is only transmitted once
         delete lrid      
       $logInfoS "LmsResult" [st|Processed #{tshow (length results)} LMS results|] 
 
+
+-- processes received input and block qualifications, if applicable
 dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX
 dispatchJobLmsUserlist  qid = JobHandlerAtomic act
   where
-    -- act :: YesodJobDB UniWorX ()
+    act :: YesodJobDB UniWorX ()
-    act = hoist lift $ do
+    act = do
       now <- liftIO getCurrentTime      
       -- result :: [(Entity LmsUser, Entity LmsUserlist)]
       results <- E.select $ do
@@ -209,19 +215,26 @@ dispatchJobLmsUserlist  qid = JobHandlerAtomic act
         return (luser, lulist)
       forM_ results $ \case
         (Entity luid luser, Nothing)
-          | isJust    $ lmsUserReceived luser
+          | isJust    $ lmsUserReceived luser          -- mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
           , isNothing $ lmsUserEnded    luser ->
               update luid [LmsUserEnded =. Just now]
-          | otherwise -> return () -- likely not yet started
+          | otherwise -> return ()                     -- users likely not yet started
 
         (Entity luid luser, Just (Entity lulid lulist)) -> do
+          when (isNothing $ lmsUserNotified luser) $ do -- notify users that lms is available
+            queueDBJob JobSendNotification
+              { jRecipient    = lmsUserUser luser
+              , jNotification = NotificationQualificationRenewal { nQualification = qid }
+              }
+            -- update luid [ LmsUserNotified =. Just now ] -- wird erst beim tatsächlichen senden gesetzt!
           let lReceived = lmsUserlistTimestamp lulist
               isBlocked = lmsUserlistFailed lulist
-              newStatus = LmsBlocked $ utctDay lReceived
+          update luid [LmsUserReceived =. Just lReceived]
-              oldStatus = lmsUserStatus luser
+          when isBlocked $ do 
-          update luid   [ LmsUserStatus   =. (oldStatus <> toMaybe isBlocked newStatus)
+            let newStatus = LmsBlocked $ utctDay lReceived
-                        , LmsUserReceived =. Just lReceived ]
+                oldStatus = lmsUserStatus luser
-          when isBlocked . insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus lReceived now -- always log blocked
+            insert_ $ LmsAudit qid (lmsUserIdent luser) newStatus (Just $ "Old Status was " <> tshow oldStatus) lReceived now
+            update luid [LmsUserStatus =. (oldStatus <> Just newStatus)]          
+            updateBy (UniqueQualificationUser qid (lmsUserUser luser)) [QualificationUserBlockedDue =. Just (QualificationBlockedLms (utctDay lReceived))]
           delete lulid 
-
       $logInfoS "LmsUserlist" [st|Processed LMS Userlist with ${tshow (length results)} entries|]

src/Jobs/Handler/SendNotification/Qualification.hs

@@ -49,7 +49,7 @@ dispatchNotificationQualificationExpiry nQualification _nExpiry jRecipient = use
 -- NOTE: qualificationRenewal expects that LmsUser already exists for recipient
 dispatchNotificationQualificationRenewal :: QualificationId -> UserId -> Handler ()
 dispatchNotificationQualificationRenewal nQualification jRecipient = do
-  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity _ LmsUser{..}) <- runDB $ (,,,)
+  (recipient@User{..}, Qualification{..}, Entity _ QualificationUser{..}, Entity luid LmsUser{..}) <- runDB $ (,,,)
     <$> getJust jRecipient
     <*> getJust nQualification
     <*> getJustBy (UniqueQualificationUser    nQualification jRecipient)
@@ -59,62 +59,74 @@ dispatchNotificationQualificationRenewal nQualification jRecipient = do
   let entRecipient = Entity jRecipient recipient
       qname = CI.original qualificationName
 
-  $logDebugS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
+  $logInfoS "LMS" $ "Notify " <> tshow encRecipient <> " for renewal of qualification " <> qname
 
   now <- liftIO getCurrentTime
   letterDate <- formatTimeUser SelFormatDate now                         $ Just entRecipient
   expiryDate <- formatTimeUser SelFormatDate qualificationUserValidUntil $ Just entRecipient
 
   let printJobName = "RenewalPin"
+      fileName  = printJobName <> "_" <> abbrvName recipient <> ".pdf"
+      lmsIdent  = lmsUserIdent & getLmsIdent
+      lmsUrl    = "https://drive.fraport.de"
+      lmsLogin  = lmsUrl <> "/?login=" <> lmsIdent
       prepAddress upa = userDisplayName : (upa & html2textlines) -- TODO: use supervisor's address 
-      pdfMeta = mkMeta
+      pdfMeta   = mkMeta
                   [ toMeta "date"           letterDate
                   , toMeta "lang"          (selectDeEn userLanguages)    -- select either German or English only, see Utils.Lang
-                  , toMeta "login"         (lmsUserIdent & getLmsIdent)
+                  , toMeta "login"          lmsIdent
                   , toMeta "pin"            lmsUserPin
                   , toMeta "recipient"      userDisplayName
                   , mbMeta "address"       (prepAddress <$> userPostAddress)
                   , toMeta "expiry"         expiryDate
                   , mbMeta "validduration" (show <$> qualificationValidDuration)
+                  , toMeta "url-text"       lmsUrl
+                  , toMeta "url"            lmsLogin
                   ]
-  pdfRenewal pdfMeta >>= \case
+      emailRenewal attachment = do         
-    Left err -> do
+        when (Text.null (CI.original userEmail)) $ do 
-      let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> err
+          let msg = "Notify " <> tshow encRecipient <> " failed: no email nor address for user known!"
-      $logErrorS "LMS" msg
+          $logErrorS "LMS" msg 
-      error $ unpack msg
+          error $ unpack msg                            -- if neither email nor postal address is known, we must abort! 
-
+        userMailT jRecipient $ do 
-    Right pdf | userPrefersLetter recipient -> do
+          replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-        let printSender  = Nothing 
+          setSubjectI $ MsgMailSubjectQualificationRenewal qname
-        runDB (sendLetter printJobName pdf printSender (Just jRecipient) Nothing (Just nQualification)) >>= \case        
+          whenIsJust attachment $ \afile -> 
-          Left err -> do
-            let msg = "Notify " <> tshow encRecipient <> "  PDF printing to send letter failed with error: " <> err
-            $logErrorS "LMS" msg
-            error $ unpack msg
-          Right (msg,_) 
-            | null msg  -> return ()
-            | otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
-
-    Right pdf -> userMailT jRecipient $ do 
-        -- userPrefersLetter is false if both userEmail and userPostAddress are null
-        when (Text.null (CI.original userEmail)) $ $logErrorS "LMS" ("Notify " <> tshow encRecipient <> " failed: no email nor address for user known!")
-
-        replaceMailHeader "Auto-Submitted" $ Just "auto-generated"
-        setSubjectI $ MsgMailSubjectQualificationRenewal qname
-              
-        let fileName = printJobName <> "_" <> abbrvName recipient <> ".pdf"
-
-        encryptPDF (fromMaybe "tomatenmarmelade" userPinPassword) pdf >>= \case -- TODO
-          Left err -> do
-            let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> err
-            $logErrorS "LMS" msg
-            
-          Right pdffile -> do
             addPart (File { fileTitle = Text.unpack fileName
                           , fileModified = now
-                          , fileContent = Just $ yield $ LBS.toStrict pdffile
+                          , fileContent = Just $ yield $ LBS.toStrict afile
                           } :: PureFile)
+          editNotifications <- mkEditNotifications jRecipient
+          addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
 
-        editNotifications <- mkEditNotifications jRecipient
+  pdfRenewal pdfMeta >>= \case
-        addHtmlMarkdownAlternatives $(ihamletFile "templates/mail/qualificationRenewal.hamlet")
+    Right pdf | userPrefersLetter recipient ->          -- userPrefersLetter is false if both userEmail and userPostAddress are null
+      let printSender  = Nothing 
+      in runDB (sendLetter printJobName pdf (Just jRecipient, printSender) Nothing (Just nQualification)) >>= \case        
+        Left err -> do
+          let msg = "Notify " <> tshow encRecipient <> ": PDF printing to send letter failed with error " <> cropText err 
+          $logErrorS "LMS" msg
+          error $ unpack msg
+        Right (msg,_) 
+          | null msg  -> return ()
+          | otherwise -> $logWarnS "LMS" $ "PDF printing to send letter with lpr returned ExitSucces and the following message: " <> msg
 
+    Right pdf -> do
+      attch <- case userPinPassword of 
+        Nothing   -> return $ Just pdf                  -- attach unencrypted, since there is no password set
+        Just passwd -> encryptPDF passwd pdf >>= \case 
+          Right encPdf -> return $ Just encPdf          -- attach encrypted
+          Left err -> do                                -- send email without attachment, so that the user is at least notified about the expiry
+            let msg = "Notify " <> tshow encRecipient <> " PDF encryption failed with error: " <> cropText err
+            $logErrorS "LMS" msg
+            return Nothing
+      emailRenewal attch
+
+    Left err -> do
+      let msg = "Notify " <> tshow encRecipient <> " PDF generation failed with error: " <> cropText err
+      $logErrorS "LMS" msg
+      emailRenewal Nothing
+        
+  -- if we reach the end, mark the user as notified.  TODO: Maybe defer this until the print job is marked as sent?
+  runDB $ update luid [ LmsUserNotified =. Just now]
     

src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs

@@ -9,6 +9,7 @@ import Import
 import Auth.PWHash (PWHashMessage(..))
 
 import Handler.Utils.Mail
+-- import Handler.Utils.Widgets (simpleLink, simpleLinkI)
 import Jobs.Handler.SendNotification.Utils
 
 import Text.Hamlet
@@ -21,6 +22,6 @@ dispatchNotificationUserAuthModeUpdate  nUser _nOriginalAuthMode jRecipient = us
     setSubjectI MsgMailSubjectUserAuthModeUpdate
 
     editNotifications <- ihamletSomeMessage <$> mkEditNotifications jRecipient
-
+    -- let linkRoot :: Widget = simpleLink (text2widget "FRADrive")  NewsR -- TODO: use MsgMailFradrive instead
     addHtmlMarkdownAlternatives ($(ihamletFile "templates/mail/userAuthModeUpdate.hamlet") :: HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX))
 

src/Jobs/Types.hs

@@ -322,19 +322,32 @@ data JobNoQueueSame = JobNoQueueSame | JobNoQueueSameTag
   
 jobNoQueueSame :: Job -> Maybe JobNoQueueSame
 jobNoQueueSame = \case
-  JobSendPasswordReset{}       -> Just JobNoQueueSame
+  JobSendNotification{jNotification}  -> notifyNoQueueSame jNotification
-  JobTruncateTransactionLog{}  -> Just JobNoQueueSame
+  JobSendPasswordReset{}              -> Just JobNoQueueSame
-  JobPruneInvitations{}        -> Just JobNoQueueSame
+  JobTruncateTransactionLog{}         -> Just JobNoQueueSame
-  JobDeleteTransactionLogIPs{} -> Just JobNoQueueSame
+  JobPruneInvitations{}               -> Just JobNoQueueSame
-  JobSynchroniseLdapUser{}     -> Just JobNoQueueSame
+  JobDeleteTransactionLogIPs{}        -> Just JobNoQueueSame
-  JobChangeUserDisplayEmail{}  -> Just JobNoQueueSame
+  JobSynchroniseLdapUser{}            -> Just JobNoQueueSame
-  JobPruneSessionFiles{}       -> Just JobNoQueueSameTag
+  JobChangeUserDisplayEmail{}         -> Just JobNoQueueSame
-  JobPruneUnreferencedFiles{}  -> Just JobNoQueueSameTag
+  JobPruneSessionFiles{}              -> Just JobNoQueueSameTag
-  JobInjectFiles{}             -> Just JobNoQueueSameTag
+  JobPruneUnreferencedFiles{}         -> Just JobNoQueueSameTag
+  JobInjectFiles{}                    -> Just JobNoQueueSameTag
   JobPruneFallbackPersonalisedSheetFilesKeys{} -> Just JobNoQueueSameTag
-  JobRechunkFiles{}            -> Just JobNoQueueSameTag
+  JobRechunkFiles{}                   -> Just JobNoQueueSameTag
-  JobDetectMissingFiles{}      -> Just JobNoQueueSameTag
+  JobDetectMissingFiles{}             -> Just JobNoQueueSameTag  
-  _                            -> Nothing
+  JobLmsQualificationsEnqueue         -> Just JobNoQueueSame
+  JobLmsEnqueue     {}                -> Just JobNoQueueSame
+  JobLmsEnqueueUser {}                -> Just JobNoQueueSame
+  JobLmsQualificationsDequeue         -> Just JobNoQueueSame
+  JobLmsDequeue     {}                -> Just JobNoQueueSame
+  JobLmsUserlist    {}                -> Just JobNoQueueSame
+  JobLmsResults     {}                -> Just JobNoQueueSame  
+  _                                   -> Nothing
+
+notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
+notifyNoQueueSame = \case 
+  NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged
+  _                                  -> Nothing
 
 jobMovable :: JobCtl -> Bool
 jobMovable = isn't _JobCtlTest

src/Model/Migration/Definitions.hs

@@ -432,7 +432,7 @@ customMigrations = mapF $ \case
 
     whenM ((&&) <$> tableExists "allocation_course_file" <*> (not <$> tableExists "course_app_instruction_file")) $ do
       [executeQQ|
-        CREATe TABLE "course_app_instruction_file"("id" SERIAL8  PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL);
+        CREATE TABLE "course_app_instruction_file"("id" SERIAL8  PRIMARY KEY UNIQUE,"course" INT8 NOT NULL,"file" INT8 NOT NULL);
         ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "unique_course_app_instruction_file" UNIQUE("course","file");               
         ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_course_fkey" FOREIGN KEY("course") REFERENCES "course"("id");                               
         ALTER TABLE "course_app_instruction_file" ADD CONSTRAINT "course_app_instruction_file_file_fkey" FOREIGN KEY("file") REFERENCES "file"("id");
@@ -463,7 +463,7 @@ customMigrations = mapF $ \case
 
   Migration20190828UserFunction -> do
     [executeQQ|
-      CREATe TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text );
+      CREATE TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text );
     |]
 
     whenM (tableExists "user_admin") $ do
@@ -1002,7 +1002,7 @@ customMigrations = mapF $ \case
 
     whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do
       [executeQQ|
-        CREATe TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL)
+        CREATE TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL)
       |]
 
       let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|]

src/Model/Types/Avs.hs

@@ -79,7 +79,7 @@ licence2char AvsLicenceVorfeld  = 'F'
 licence2char AvsLicenceRollfeld = 'R'
 
 
-data AvsDataCardColor = AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb | AvsCardColorMisc Text
+data AvsDataCardColor = AvsCardColorMisc Text | AvsCardColorGrün | AvsCardColorBlau | AvsCardColorRot | AvsCardColorGelb
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
   deriving anyclass (NFData)
 
@@ -104,12 +104,12 @@ data AvsDataPersonCard = AvsDataPersonCard
       { avsDataValid     :: Bool  -- card currently valid? Note that AVS encodes booleans as JSON String "true" and "false" and not as JSON booleans
       , avsDataValidTo   :: Maybe Day   -- always Nothing if returned with AvsResponseStatus
       , avsDataIssueDate :: Maybe Day   -- always Nothing if returned with AvsResponseStatus
+      , avsDataCardColor :: AvsDataCardColor
       , avsDataCardAreas :: Set Char -- logically a set of upper-case letters
       , avsDataStreet    :: Maybe Text  -- always Nothing if returned with AvsResponseStatus
       , avsDataPostalCode:: Maybe Text  -- always Nothing if returned with AvsResponseStatus
       , avsDataCity      :: Maybe Text  -- always Nothing if returned with AvsResponseStatus
       , avsDataFirm      :: Maybe Text  -- always Nothing if returned with AvsResponseStatus       
-      , avsDataCardColor :: AvsDataCardColor
       , avsDataCardNo    :: Text  -- always 8 digits
       , avsDataVersionNo :: Text
       }
@@ -134,12 +134,12 @@ instance FromJSON AvsDataPersonCard where
     <$> ((v .: "Valid") <&> sloppyBool)
     <*> v .:? "ValidTo"
     <*> v .:? "IssueDate"
+    <*> v .: "CardColor"
     <*> ((v .: "CardAreas") <&> charSet)
     <*> v .:? "Street"
     <*> v .:? "PostalCode"
     <*> v .:? "City"
     <*> v .:? "Firm"    
-    <*> v .: "CardColor"
     <*> v .: "CardNo"
     <*> v .: "VersionNo"
 
@@ -230,6 +230,8 @@ deriveJSON defaultOptions
   , rejectUnknownFields = False
   } ''AvsResponsePerson
 
+
+
 -------------
 -- Queries --
 -------------
@@ -296,6 +298,8 @@ pickLicenceAddress a b
     | Just r <- pickBetter' avsDataValid                                    = r   -- prefer valid cards
     | Just r <- pickBetter' (Set.member licenceRollfeld . avsDataCardAreas) = r   -- prefer 'R' cards
     | Just r <- pickBetter' (Set.member licenceVorfeld  . avsDataCardAreas) = r   -- prefer 'F' cards
+    | avsDataCardColor a > avsDataCardColor b                               = a   -- prefer Yellow over Green, etc.
+    | avsDataCardColor a < avsDataCardColor b                               = b   
     | avsDataIssueDate a > avsDataIssueDate b                               = a   -- prefer later issue date
     | avsDataIssueDate a < avsDataIssueDate b                               = b                  
     | avsDataValidTo   a > avsDataValidTo   b                               = a   -- prefer later validto date

src/Model/Types/Csv.hs

@@ -60,10 +60,11 @@ data CsvOptions
 
 data CsvFormatOptions
   = CsvFormatOptions
-    { csvDelimiter :: Char
+    { csvDelimiter     :: Char
-    , csvUseCrLf   :: Bool
+    , csvUseCrLf       :: Bool
-    , csvQuoting   :: Csv.Quoting
+    , csvQuoting       :: Csv.Quoting
-    , csvEncoding  :: DynEncoding
+    , csvEncoding      :: DynEncoding
+    , csvIncludeHeader :: Bool
     }
   | CsvXlsxFormatOptions
   deriving (Eq, Ord, Read, Show, Generic, Typeable)
@@ -94,16 +95,18 @@ csvPreset = prism' fromPreset toPreset
   where
     fromPreset :: CsvPreset -> CsvFormatOptions
     fromPreset CsvPresetRFC   = CsvFormatOptions
-      { csvDelimiter = ','
+      { csvDelimiter     = ','
-      , csvUseCrLf   = True
+      , csvUseCrLf       = True
-      , csvQuoting   = QuoteMinimal
+      , csvIncludeHeader = True
-      , csvEncoding  = "UTF8"
+      , csvQuoting       = QuoteMinimal
+      , csvEncoding      = "UTF8"
       }
     fromPreset CsvPresetExcel = CsvFormatOptions
-      { csvDelimiter = ';'
+      { csvDelimiter     = ';'
-      , csvUseCrLf   = True
+      , csvUseCrLf       = True
-      , csvQuoting   = QuoteAll
+      , csvIncludeHeader = True
-      , csvEncoding  = "CP1252"
+      , csvQuoting       = QuoteAll
+      , csvEncoding      = "CP1252"
       }
     fromPreset CsvPresetXlsx = CsvXlsxFormatOptions
 
@@ -119,7 +122,7 @@ _CsvEncodeOptions = prism' fromEncode toEncode
       { Csv.encDelimiter     = fromIntegral $ fromEnum csvDelimiter
       , Csv.encUseCrLf       = csvUseCrLf
       , Csv.encQuoting       = csvQuoting
-      , Csv.encIncludeHeader = True
+      , Csv.encIncludeHeader = csvIncludeHeader
       }
     toEncode CsvXlsxFormatOptions{} = Nothing
     fromEncode encOpts = def
@@ -184,9 +187,10 @@ instance FromJSON CsvFormatOptions where
     case formatTag of
       FormatCsv -> do
         csvDelimiter <- fmap (fmap toEnum) (o JSON..:? "delimiter") JSON..!= csvDelimiter def
-        csvUseCrLf   <- o JSON..:? "use-cr-lf" JSON..!= csvUseCrLf  def
+        csvUseCrLf       <- o JSON..:? "use-cr-lf"       JSON..!= csvUseCrLf       def
-        csvQuoting   <- o JSON..:? "quoting"   JSON..!= csvQuoting  def
+        csvQuoting       <- o JSON..:? "quoting"         JSON..!= csvQuoting       def
-        csvEncoding  <- o JSON..:? "encoding"  JSON..!= csvEncoding def
+        csvEncoding      <- o JSON..:? "encoding"        JSON..!= csvEncoding      def
+        csvIncludeHeader <- o JSON..:? "include-header"  JSON..!= csvIncludeHeader def
         return CsvFormatOptions{..}
       FormatXlsx -> return CsvXlsxFormatOptions
 

src/Model/Types/Lms.hs

@@ -28,18 +28,26 @@ deriveJSON defaultOptions
   } ''LmsIdent 
 
 -- TODO: Is this a good idea? An ordinary Enum and a separate Day column in the DB would be better, e.g. allowing use of insertSelect in Jobs.Handler.LMS?
+-- ...also see similar type QualificationBlocked
 data LmsStatus = LmsBlocked { lmsStatusDay :: Day } 
                | LmsSuccess { lmsStatusDay :: Day }
-  deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
+  deriving (Eq, Read, Show, Generic, Typeable, NFData)
+
+instance Ord LmsStatus where 
+  compare a b
+    | daycmp <- compare (lmsStatusDay a) (lmsStatusDay b)
+    , daycmp /= EQ = daycmp    
+  compare LmsSuccess{} LmsBlocked{} = GT
+  compare LmsBlocked{} LmsSuccess{} = LT 
+  compare _            _            = EQ 
 
 isLmsSuccess :: LmsStatus -> Bool 
 isLmsSuccess LmsSuccess{} = True 
 isLmsSuccess _other       = False 
 
--- Entscheidung 08.04.22: LmsSuccess gewinnt immer über LmsBlocked oder umgekehrt; siehe Model.TypesSpec
+-- Entscheidung 16.09.22: Es gewinnt was zuerst gemeldet wurde. Das verhindert, dass eine Qualifikation doppelt verlängert wird! Siehe Model.TypesSpec
 instance Semigroup LmsStatus where 
-  a <> b | a >= b    = a  
+  a <> b = min a b -- earliest date, otherwise LmsBlocked before LmsSuccess         
-         | otherwise = b
 
 deriveJSON  defaultOptions
   { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor, since the object is tagged with lms already
@@ -54,6 +62,28 @@ instance Csv.ToField LmsStatus where
   toField (LmsSuccess d) = "Success: " <> Csv.toField d
 
 
+data QualificationBlocked 
+      = QualificationBlockedLms { qualificationBlockedDay :: Day } 
+      | QualificationBlockedAvs { qualificationBlockedDay :: Day }
+  deriving (Eq, Ord, Read, Show, Generic, Typeable, NFData)
+
+deriveJSON  defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1      -- remove lms from constructor, since the object is tagged with lms already
+  , fieldLabelModifier     = camelToPathPiece' 2      -- just day suffices for the day field
+  , omitNothingFields = True
+  , sumEncoding = TaggedObject "lms-status" "lms-result"
+  } ''QualificationBlocked 
+derivePersistFieldJSON ''QualificationBlocked 
+
+instance Csv.ToField QualificationBlocked  where
+  toField (QualificationBlockedLms d) = "Blocked by LMS: " <> Csv.toField d
+  toField (QualificationBlockedAvs d) = "Blocked by AVS: " <> Csv.toField d
+
+-- | ToMessage instance ignores contained timestamp
+instance ToMessage QualificationBlocked where 
+  toMessage (QualificationBlockedLms _) = "LMS"
+  toMessage (QualificationBlockedAvs _) = "AVS"
+
 -- | LMS interface requires Bool to be encoded by 0 or 1 only
 newtype LmsBool = LmsBool { lms2bool :: Bool }
   deriving (Eq, Ord, Read, Show, Generic, Typeable)

src/Settings.hs

@@ -93,6 +93,8 @@ data AppSettings = AppSettings
     -- ^ Configuration settings for accessing the database.
     , appAutoDbMigrate          :: Bool
     , appLdapConf               :: Maybe (PointedList LdapConf)
+    -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
+    , appLmsConf                :: LmsConf
     -- ^ Configuration settings for accessing the LDAP-directory
     , appAvsConf                :: Maybe AvsConf
     -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System)
@@ -301,6 +303,14 @@ data LdapConf = LdapConf
   , ldapPool :: ResourcePoolConf
   } deriving (Show)
 
+data LmsConf = LmsConf
+  { lmsUploadHeader       :: Bool
+  , lmsUploadDelimiter    :: Maybe Char
+  , lmsDownloadHeader     :: Bool
+  , lmsDownloadDelimiter  :: Char
+  , lmsDownloadCrLf       :: Bool
+  } deriving (Show)
+
 data AvsConf = AvsConf
   { avsHost :: String
   , avsPort :: Int
@@ -480,6 +490,17 @@ deriveFromJSON
     }
   ''HaskellNet.AuthType
 
+instance FromJSON LmsConf where
+  parseJSON = withObject "LmsConf" $ \o -> do
+    lmsUploadHeader       <- o .:  "upload-header"
+    lmsUploadDelimiter    <- o .:? "upload-delimiter"
+    lmsDownloadHeader     <- o .:  "download-header"
+    lmsDownloadDelimiter  <- o .:  "download-delimiter"    
+    lmsDownloadCrLf       <- o .:  "download-cr-lf"
+    return LmsConf{..}
+
+makeLenses_ ''LmsConf
+
 instance FromJSON AvsConf where
   parseJSON = withObject "AvsConf" $ \o -> do
     avsHost <- o .: "host"
@@ -576,6 +597,7 @@ instance FromJSON AppSettings where
               Ldap.Tls host _ -> not $ null host
               Ldap.Plain host -> not $ null host
         appLdapConf               <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
+        appLmsConf                <- o .: "lms-direct"
         appAvsConf                <- assertM (not . null . avsPass)  <$> o .:? "avs"
         appLprConf                <- o .: "lpr"
         appSmtpConf               <- assertM (not . null . smtpHost) <$> o .:? "smtp"

src/Settings/Log.hs

@@ -15,9 +15,10 @@ import Utils.PathPiece
 
 
 data LogSettings = LogSettings
-  { logAll, logDetailed :: Bool
+  { logDetailed :: Bool               -- More details for incoming HTTP Requests?
-  , logMinimumLevel :: LogLevel
+  , logAll :: Bool                    -- Show all LogLevels?
-  , logDestination :: LogDestination
+  , logMinimumLevel :: LogLevel       -- logAll => logMiniumLevel == Info
+  , logDestination :: LogDestination  -- stderr, stdout (must both be lowercase) or a filename!
   , logSerializableTransactionRetryLimit :: Maybe Natural
   } deriving (Show, Read, Generic, Eq, Ord)
 

src/Utils.hs

@@ -275,14 +275,33 @@ addAttrsClass cl attrs = ("class", cl') : noClAttrs
 stripAll :: Text -> Text
 stripAll = Text.filter (not . isSpace)
 
+-- | take first line, only 
+cropText :: Text -> Text
+cropText (Text.lines -> l:_) = Text.take 80 l
+cropText t = Text.take 80 t
+
+-- | strip leading and trailing whitespace and make case insensitive
+-- also helps to avoid the need to import just for CI.mk
+stripCI :: Text -> CI Text 
+stripCI = CI.mk . Text.strip
+
 citext2lower :: CI Text -> Text 
 citext2lower = Text.toLower . CI.original
 
+-- avoids unnecessary imports
+citext2string :: CI Text -> String 
+citext2string = Text.unpack . CI.original
+
 -- | Convert text as it is to Html, may prevent ambiguous types
 -- This function definition is mainly for documentation purposes
 text2Html :: Text -> Html
 text2Html = toHtml
 
+char2Text :: Char -> Text
+char2Text c 
+  | isSpace c = "<Space>"
+  | otherwise = Text.singleton c
+
 -- | Convert text as it is to Message, may prevent ambiguous types
 -- This function definition is mainly for documentation purposes
 text2message :: Text -> SomeMessage site
@@ -318,6 +337,18 @@ withFragment form html = flip fmap form $ over _2 (toWidget html >>)
 charSet :: Text -> Set Char 
 charSet = Text.foldl (flip Set.insert) mempty 
   
+-- | Returns Nothing iff both texts are identical,
+--   otherwise a differing character is returned, preferable from the first argument
+textDiff :: Text -> Text -> Maybe Char
+textDiff (Text.uncons -> xs) (Text.uncons -> ys)
+  | Just (x,xt) <- xs 
+  , Just (y,yt) <- ys 
+    = if x == y 
+        then textDiff xt yt
+        else Just x
+  | otherwise
+    = fst <$> (xs <|> ys)
+
 -- | Convert `part` and `whole` into percentage including symbol
 --   showing trailing zeroes and to decimal digits
 textPercent :: Real a => a -> a -> Text

src/Utils/Print.hs

@@ -14,9 +14,10 @@ module Utils.Print
   ) where
 
 -- import Import.NoModel
-import qualified Data.Foldable as Fold
+import           Data.Char (isSeparator)
 import qualified Data.Text as T
 import qualified Data.CaseInsensitive as CI
+import qualified Data.Foldable as Fold
 
 import qualified Data.ByteString.Lazy as LBS
 import Control.Monad.Except
@@ -263,8 +264,8 @@ pdfRenewal' meta = do
 -- PrintJobs --
 ---------------
 
-sendLetter :: Text -> LBS.ByteString -> Maybe UserId -> Maybe UserId -> Maybe CourseId -> Maybe QualificationId -> DB (Either Text (Text, FilePath))
+sendLetter :: Text -> LBS.ByteString -> (Maybe UserId, Maybe UserId) -> Maybe CourseId -> Maybe QualificationId -> DB (Either Text (Text, FilePath))
-sendLetter printJobName pdf printJobRecipient printJobSender printJobCourse printJobQualification = do
+sendLetter printJobName pdf (printJobRecipient, printJobSender) printJobCourse printJobQualification = do
   recipient <- join <$> mapM get printJobRecipient
   sender    <- join <$> mapM get printJobSender
   course    <- join <$> mapM get printJobCourse
@@ -332,12 +333,11 @@ readProcess' pc = do
 
 
 sanitizeCmdArg :: Text -> Text 
-sanitizeCmdArg t =   
+sanitizeCmdArg =  T.filter (\c -> c /= '\'' && c /= '"' && c/= '\\' && not (isSeparator c))
-  T.snoc (T.cons '\'' $ T.filter (\c -> '\'' /= c && '"' /= c && '\\' /= c) t) '\''
+-- | Returns Nothing if ok, otherwise the first mismatching character
--- | Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk
+--   Pin Password is used as a commandline argument in Utils.Print.encryptPDF and hence poses a security risk 
-validCmdArgument :: Text -> Bool
+validCmdArgument :: Text -> Maybe Char
-validCmdArgument t = not (T.null t) && (T.cons '\'' (T.snoc t '\'') == sanitizeCmdArg t)
+validCmdArgument t = t `textDiff` sanitizeCmdArg t
-
 
 
 -----------

start.sh

@@ -23,6 +23,7 @@ export ENCRYPT_ERRORS=${ENCRYPT_ERRORS:-false}
 export RIBBON=${RIBBON:-${__HOST:-localhost}}
 export APPROOT=${APPROOT:-http://localhost:$((${PORT_OFFSET:-0} + 3000))}
 export AVSPASS=${AVSPASS:-nopasswordset}
+export PATH=${PATH:/home/jost/projects/fradrive} 
 unset HOST
 
 move-back() {

templates/ldap.hamlet

@@ -0,0 +1,15 @@
+<section>
+  <p> 
+    LDAP Person Search:
+    ^{personForm}
+  $maybe answers <- mbLdapData
+    <h1>
+      Antwort: #
+    <dl .deflist>
+      $forall (lk, lv) <- answers
+        <dt>
+          #{show lk}
+        <dd>
+          UTF8:  #{presentUtf8 lv}
+          &#8212;
+          Latin: #{presentLatin1 lv}

templates/letter/fraport_renewal.md

@@ -6,7 +6,6 @@ en-subject: Renewal of apron driving License
 author: Fraport AG - Fahrerausbildung (AVN-AR)
 phone: +49 69 690-30306
 email: fahrerausbildung@fraport.de
-url: <http://drive.fraport.de>
 place: Frankfurt/Main
 return-address: 
  - 60547 Frankfurt
@@ -22,6 +21,8 @@ encludes:
 hyperrefoptions: hidelinks
 
 ### Metadaten, welche automatisch ersetzt werden:
+url-text: 'https://drive.fraport.de'
+url: 'https://drive.fraport.de'
 date: 11.11.1111
 expiry: 00.00.0000
 lang: de-de
@@ -66,7 +67,7 @@ Prüfling
 
 URL
 
-  : $url$
+  : [$url-text$]($url$)
 
 
 Sobald die Frist abgelaufen ist, muss zur Wiedererlangung des Vorfeldführerscheins
@@ -93,7 +94,7 @@ Examinee
 
 URL
 
-  : $url$
+  :[$url-text$]($url$)
 
 
 Should your apron driving licence expire before completing this 

templates/mail/passwordReset.hamlet

@@ -13,4 +13,6 @@ $newline never
     <h1>
       <a href=#{resetUrl}>
         _{SomeMessage MsgResetPassword}
+    <p>
+      <a href=#{resetUrl}>
         _{SomeMessage $ MsgLinkActiveUntil activeTime}

templates/mail/qualificationRenewal.hamlet

@@ -28,7 +28,9 @@ $newline never
         <dd>#{expiryDate}
 
     <p>
-      _{SomeMessage MsgLmsRenewalInstructions}      
+      _{SomeMessage MsgLmsRenewalInstructions} #
 
+      <a href=#{lmsLogin}>
+        _{SomeMessage MsgMppURL} #{lmsUrl}
 
     ^{ihamletSomeMessage editNotifications}

templates/mail/userAuthModeUpdate.hamlet

@@ -19,10 +19,15 @@ $newline never
           _{SomeMessage MsgUserAuthModePWHashChangedToLDAP}
         $of AuthPWHash _
           _{SomeMessage MsgUserAuthModeLDAPChangedToPWHash}
+    <p>
+      <a href=@{NewsR}>
+        _{SomeMessage MsgMailFradrive} #
+      _{SomeMessage MsgMailBodyFradrive}
+
     $if is _AuthPWHash userAuthentication
       <p>
         _{SomeMessage MsgAuthPWHashTip}
-      <dd>
+      <dl>
         <dt>
           _{SomeMessage MsgPWHashIdent}
         <dd .email>

test/Database/Fill.hs

@@ -505,28 +505,37 @@ fillDb = do
   qid_f  <- insert' $ Qualification avn "F" "Vorfeldführerschein"  f_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 0 60) True
   qid_r  <- insert' $ Qualification avn "R" "Rollfeldführerschein" r_descr (Just 24) (Just 6) (Just $ CalendarDiffDays 2 3)  False
   qid_l  <- insert' $ Qualification ifi "L" "Lehrbefähigung"       l_descr Nothing   (Just 6) Nothing True
-  void . insert' $ QualificationUser jost       qid_f (n_day    9) (n_day $ -1) (n_day $ -22) -- TODO: better dates!
+  void . insert' $ QualificationUser jost       qid_f (n_day    9) (n_day $ -1) (n_day $ -22) Nothing -- TODO: better dates!
-  void . insert' $ QualificationUser gkleen     qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20)
+  void . insert' $ QualificationUser gkleen     qid_f (n_day $ -3) (n_day $ -4) (n_day $ -20) Nothing
-  void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8)
+  void . insert' $ QualificationUser maxMuster  qid_f (n_day    0) (n_day $ -2) (n_day $  -8) Nothing
-  void . insert' $ QualificationUser svaupel    qid_f (n_day    1) (n_day $ -1) (n_day $  -2)
+  void . insert' $ QualificationUser svaupel    qid_f (n_day    1) (n_day $ -1) (n_day $  -2) Nothing
-  void . insert' $ QualificationUser sbarth     qid_f (n_day  400) (n_day $ -40) (n_day $ -1200)
+  void . insert' $ QualificationUser sbarth     qid_f (n_day  400) (n_day $ -40) (n_day $ -1200) Nothing
-  void . insert' $ QualificationUser tinaTester qid_f (n_day    3) (n_day $ -60) (n_day $ -250)
+  void . insert' $ QualificationUser tinaTester qid_f (n_day    3) (n_day $ -60) (n_day $ -250)  Nothing
-  void . insert' $ QualificationUser gkleen     qid_r (n_day $ -7) (n_day $ -2) (n_day $  -9)
+  void . insert' $ QualificationUser gkleen     qid_r (n_day $ -7) (n_day $ -2) (n_day $  -9) Nothing
-  void . insert' $ QualificationUser maxMuster  qid_r (n_day    1) (n_day $ -1) (n_day $  -2)
+  void . insert' $ QualificationUser maxMuster  qid_r (n_day    1) (n_day $ -1) (n_day $  -2) Nothing
-  void . insert' $ QualificationUser fhamann    qid_r (n_day $ -3) (n_day $ -1) (n_day $  -2)
+  void . insert' $ QualificationUser fhamann    qid_r (n_day $ -3) (n_day $ -1) (n_day $  -2) Nothing
-  void . insert' $ QualificationUser svaupel    qid_l (n_day    1) (n_day $ -1) (n_day $  -2)
+  void . insert' $ QualificationUser svaupel    qid_l (n_day    1) (n_day $ -1) (n_day $  -2) Nothing
-  void . insert' $ QualificationUser gkleen     qid_l (n_day    9) (n_day $ -1) (n_day $  -7)
+  void . insert' $ QualificationUser gkleen     qid_l (n_day    9) (n_day $ -1) (n_day $  -7) Nothing
   void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now
   void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) now
   void . insert' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now
   void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
   void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True  now
   void . insert' $ LmsUserlist qid_f (LmsIdent "ijk"    ) False now
-  void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"    ) "123" False now Nothing now Nothing Nothing
+  void . insert' $ LmsUser qid_f jost        (LmsIdent "ijk"    ) "123" False now Nothing                           now Nothing    Nothing Nothing
-  void . insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1) now (Just now) Nothing
+  void . insert' $ LmsUser qid_f svaupel     (LmsIdent "abcdefg") "abc" False now (Just $ LmsSuccess $ n_day 1)     now (Just now) Nothing Nothing
-  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hijklmn") "@#!" True  now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing
+  void . insert' $ LmsUser qid_f gkleen      (LmsIdent "hijklmn") "@#!" True  now (Just $ LmsBlocked $ utctDay now) now (Just now) Nothing Nothing
-  void . insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")    "45678" True now (Just $ LmsSuccess $ n_day (-2)) now Nothing Nothing
+  void . insert' $ LmsUser qid_f tinaTester  (LmsIdent "qwvu")  "45678" True  now (Just $ LmsSuccess $ n_day (-2))  now Nothing    (Just $ n_day' (-1)) Nothing
-  void . insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")    "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1)) now (Just $ n_day' (-2)) (Just $ n_day' (-1))
+  void . insert' $ LmsUser qid_f maxMuster   (LmsIdent "xyz")  "a1b2c3" False now (Just $ LmsBlocked $ n_day (-1))  now (Just $ n_day' (-2)) (Just $ n_day' (-2)) (Just $ n_day' (-1))
+
+  void . insert $ PrintJob "TestJob1" "job1" "No Text herein." (n_day' (-1)) Nothing Nothing        (Just svaupel)  Nothing (Just qid_f)
+  void . insert $ PrintJob "TestJob2" "job2" "No Text herein." (n_day' (-1)) Nothing (Just jost)    (Just svaupel)  Nothing (Just qid_f)
+  void . insert $ PrintJob "TestJob3" "job3" "No Text herein." (n_day' (-2)) Nothing Nothing        Nothing         Nothing Nothing
+  void . insert $ PrintJob "TestJob4" "job4" "No Text herein." (n_day' (-2)) Nothing (Just jost)    Nothing         Nothing Nothing
+  void . insert $ PrintJob "TestJob5" "job5" "No Text herein." (n_day' (-4)) Nothing (Just jost)    (Just svaupel)  Nothing (Just qid_r)
+  void . insert $ PrintJob "TestJob6" "job6" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing         Nothing (Just qid_r)
+  void . insert $ PrintJob "TestJob7" "job7" "No Text herein." (n_day' (-4)) Nothing (Just svaupel) Nothing         Nothing Nothing
+
 
   let
     examLabels = Map.fromList

test/Model/TypesSpec.hs

@@ -298,6 +298,7 @@ instance Arbitrary CsvFormatOptions where
         <*> arbitrary
         <*> arbitrary
         <*> elements ["UTF8", "CP1252"]
+        <*> pure True
     , pure CsvXlsxFormatOptions
     ]
     where
@@ -619,10 +620,8 @@ spec = do
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorMissing `shouldBe` "[1.0 - D]"
       showCompactCorrectorLoad Load{ byTutorial = Nothing,    byProportion = 1, byDeficit = 0 } CorrectorExcused `shouldBe` "{1.0 - D}"
   describe "Semigroup LmsStatus" $ do 
-    it "LmsSuccess supersedes LmsBlocked" . property $
+    it "lmsStatusDay merges to earliest" . property $
-      \p1 p2 -> (isLmsSuccess p1 || isLmsSuccess p2) == isLmsSuccess (p1 <> p2)
+      \p1 p2 -> lmsStatusDay (p1 <> p2) == min (lmsStatusDay p1) (lmsStatusDay p2) 
-    it "lmsStatusDay merges to latest" . property $
-      \p1 p2 -> (isLmsSuccess p1 == isLmsSuccess p2) ==> lmsStatusDay (p1 <> p2) == max (lmsStatusDay p1) (lmsStatusDay p2) 
 
 
 termExample :: (TermIdentifier, Text) -> Expectation