Merge branch 'fradrive/company' into test
This commit is contained in:
commit
6e5a58aa37
64
CHANGELOG.md
64
CHANGELOG.md
@ -2,6 +2,70 @@
|
|||||||
|
|
||||||
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.
|
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.
|
||||||
|
|
||||||
|
## [27.4.45](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.44...v27.4.45) (2023-10-18)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **hoogle:** remove erroneous comment ([c011d88](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c011d887cece8338920355b540aa4b233e0b994f))
|
||||||
|
* **sap:** yet another fix for finding date intervals ([fde97b0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fde97b048ab04ab59c9e3f2a2f74bb2c1e996b22))
|
||||||
|
|
||||||
|
## [27.4.44](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.43...v27.4.44) (2023-10-18)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **sap:** combine immediate next day licence chnages for SAP ([f4adfdf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f4adfdf87270930d4ca6611f2a9956613fcace53))
|
||||||
|
* **sap:** combine immediate next day licence chnages for SAP ([cbb44f1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cbb44f106ad59e0a53ca04963ade5544120b7e21))
|
||||||
|
* **sap:** combineBlocks yet another bug squashed ([3924d14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3924d14abd868305b42c9d04913536b4999dc45b))
|
||||||
|
* **sap:** compileBlocks ([b4a88ab](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b4a88abcf85783c350ad2bf3a5e973d13d1eb1f6))
|
||||||
|
|
||||||
|
## [27.4.43](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.42...v27.4.43) (2023-10-13)
|
||||||
|
|
||||||
|
## [27.4.42](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.41...v27.4.42) (2023-10-12)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **build:** Update ParticipantInvite.hs ([f888da3](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f888da3ab0df45bb3c515ebb7cbb43569fdaa1fa))
|
||||||
|
* **build:** Update ParticipantInvite.hs ([fa4f9b2](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fa4f9b24475261afc1e534541c8878a85e6a1b10))
|
||||||
|
* **build:** Update Utils.hs ([87f0b2e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/87f0b2edab2bcf696b7b776e47272ef2204c0b75))
|
||||||
|
|
||||||
|
## [27.4.41](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.40...v27.4.41) (2023-10-04)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **lms:** sorting and filtering lms status ([f48862e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/f48862efbcb95e92203a200267e1bcc613af4af1))
|
||||||
|
* **lms:** sorting and filtering lms status works throughout now ([ae44703](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ae4470333e2b1b5c271b38092210c094822f4a19))
|
||||||
|
* **print:** apc ident aliases did not stop at first success ([b7d4f69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b7d4f6913d8b1a70c1b7ef73782cf29861dc11a7))
|
||||||
|
|
||||||
|
## [27.4.40](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.39...v27.4.40) (2023-09-26)
|
||||||
|
|
||||||
|
## [27.4.39](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.38...v27.4.39) (2023-09-26)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **lms:** do not mark lms users with open status as ended ([a848126](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a84812640f02981875275c96e37338de4ab49996))
|
||||||
|
* **qualifications:** latest block could ignore itself ([bb708ca](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bb708ca540557b41d33996cfea9a390a457ed855))
|
||||||
|
|
||||||
|
## [27.4.38](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.37...v27.4.38) (2023-09-21)
|
||||||
|
|
||||||
|
## [27.4.37](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.36...v27.4.37) (2023-09-21)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **lms:** disable workaround for late lms success ([cb9e09d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/cb9e09d071d22f41a92ab8140d7aaa643c748373))
|
||||||
|
|
||||||
|
## [27.4.36](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.34...v27.4.36) (2023-09-21)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **lms:** treat simultaneous blocks/unblocks correctly ([11752dc](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/11752dc5ac96f36ebf9a4cad43fa4e4b55c1b21c))
|
||||||
|
|
||||||
## [27.4.35](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.34...t27.4.35) (2023-09-21)
|
## [27.4.35](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.34...t27.4.35) (2023-09-21)
|
||||||
|
|
||||||
## [27.4.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.33...t27.4.34) (2023-09-21)
|
## [27.4.34](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/t27.4.33...t27.4.34) (2023-09-21)
|
||||||
|
|||||||
22
flake.nix
22
flake.nix
@ -112,8 +112,26 @@
|
|||||||
|
|
||||||
overlays = [
|
overlays = [
|
||||||
(final: prev: let
|
(final: prev: let
|
||||||
pkgs-recent = import nixpkgs-recent { inherit system; };
|
pkgs-recent = import nixpkgs-recent { inherit system; };
|
||||||
in { inherit (pkgs-recent) dockerTools node2nix stack glibcLocalesUtf8 tzdata chromium minio minio-client skopeo; inherit (pkgs-recent.stdenv) fetchurlBoot; })
|
in {
|
||||||
|
inherit (pkgs-recent) dockerTools node2nix glibcLocalesUtf8 tzdata chromium minio minio-client skopeo; inherit (pkgs-recent.stdenv) fetchurlBoot;
|
||||||
|
stack = pkgs.symlinkJoin {
|
||||||
|
inherit (pkgs-recent.stack) name;
|
||||||
|
paths = [pkgs-recent.stack];
|
||||||
|
nativeBuildInputs = [pkgs-recent.makeWrapper];
|
||||||
|
|
||||||
|
postBuild = ''
|
||||||
|
wrapProgram $out/bin/stack \
|
||||||
|
--prefix PATH : "${prev.lib.makeBinPath [pkgs-recent.nix]}" \
|
||||||
|
--add-flags "\
|
||||||
|
--nix \
|
||||||
|
--no-nix-pure \
|
||||||
|
--nix-shell-file=${./stack.nix} \
|
||||||
|
--nix-path=nixpkgs=${nixpkgs} \
|
||||||
|
"
|
||||||
|
'';
|
||||||
|
};
|
||||||
|
})
|
||||||
|
|
||||||
(import ./nix/maildev)
|
(import ./nix/maildev)
|
||||||
haskell-nix.overlay
|
haskell-nix.overlay
|
||||||
|
|||||||
@ -45,7 +45,7 @@ MailTestFormEmail: E-Mail-Adresse
|
|||||||
MailTestFormLanguages: Spracheinstellungen
|
MailTestFormLanguages: Spracheinstellungen
|
||||||
MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}. Druckaufträge werden generiert, aber nicht zum tatsächlichen Druck gesendet.
|
MailRerouteTo dev@Address: Alle Emails werden nicht an die eigentlichen Empfänger versendet, sondern umgeleitet zu _{dev}. Druckaufträge werden generiert, aber nicht zum tatsächlichen Druck gesendet.
|
||||||
TestDownload: Download-Test
|
TestDownload: Download-Test
|
||||||
BearerTokenUsageWarning: Mit diesem Interface können quesi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
|
BearerTokenUsageWarning: Mit diesem Interface können quasi beliebige Rechte als Tokens kodiert und somit ohne wesentliche weitere Beschränkung frei übertragen werden. Benutzen Sie dieses Interface nur, wenn Sie von einem erfahrenen Entwickler/einer erfahrenen Entwicklerin über die Auswirkungen des konkreten Tokens, dass sie ausstellen möchten, beraten wurden!
|
||||||
BearerTokenAuthorityGroups: Token-Authorität (Gruppen)
|
BearerTokenAuthorityGroups: Token-Authorität (Gruppen)
|
||||||
BearerTokenAuthorityGroupsTip: Die primären Benutzer:innen aller angegebenen Gruppen müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt.
|
BearerTokenAuthorityGroupsTip: Die primären Benutzer:innen aller angegebenen Gruppen müssen Zugriff auf eine Route haben, damit das Token den Zugriff auf diese Route erlaubt.
|
||||||
BearerTokenAuthorityGroupMissing: Gruppe wird benötigt
|
BearerTokenAuthorityGroupMissing: Gruppe wird benötigt
|
||||||
|
|||||||
@ -8,7 +8,7 @@ QualificationDescription: Beschreibung
|
|||||||
QualificationValidIndicator: Gültigkeit
|
QualificationValidIndicator: Gültigkeit
|
||||||
QualificationValidDuration: Gültigkeitsdauer
|
QualificationValidDuration: Gültigkeitsdauer
|
||||||
QualificationAuditDuration: Aufbewahrung Audit Log
|
QualificationAuditDuration: Aufbewahrung Audit Log
|
||||||
QualificationAuditDurationTooltip: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hiweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen.
|
QualificationAuditDurationTooltip n@Int: Optionaler Zeitraum zur Löschung von E‑Learning Daten. Hinweis: Der E‑Learning Server kann seine anonymisierten Daten schon früher löschen, aber spätestens #{n} Tage nach Abschluss.
|
||||||
QualificationRefreshWithin: Erneurerungszeitraum
|
QualificationRefreshWithin: Erneurerungszeitraum
|
||||||
QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
|
QualificationRefreshWithinTooltip: Optionaler Zeitraum vor Ablauf für automatischen Start des E‑Learnings und Versand einer Benachrichtigung per Brief oder Email.
|
||||||
QualificationRefreshReminder: 2. Erinnerung
|
QualificationRefreshReminder: 2. Erinnerung
|
||||||
@ -121,7 +121,7 @@ LmsActNotify: Benachrichtigung E‑Learning erneut per Post oder E-Mail versende
|
|||||||
LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen
|
LmsActRenewPin: Neues zufällige E‑Learning Passwort zuweisen
|
||||||
LmsActRenewNotify: Neue zufällige E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden
|
LmsActRenewNotify: Neue zufällige E‑Learning Passwort zuweisen und Benachrichtigung per Post oder E-Mail versenden
|
||||||
LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren
|
LmsActReset: E‑Learning Fehlversuche zurücksetzen und entsperren
|
||||||
LmsActResetInfo: E‑Learning Login und Passwort bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat.
|
LmsActResetInfo: E‑Learning Login, Passwort und Fortschritt bleiben unverändert, eine neue Benachrichtigung ist nicht notwendig. Nur möglich für bereits gesperrte Lerner. Es kann bis zu 2 Stunden dauern, bis das LMS die Anfrage umgesetzt hat.
|
||||||
LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt.
|
LmsActResetFeedback n@Int m@Int: Für #{n}/#{m} E‑Learning Nutzer wurden alle Fehlversuche zurückgesetzt.
|
||||||
LmsActRestart: E‑Learning komplett neu starten
|
LmsActRestart: E‑Learning komplett neu starten
|
||||||
LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
|
LmsActRestartWarning: Das vorhandene E‑Learning wird komplett gelöscht! Für Inhaber einer gültigen Fahrlizenz werden später Benutzer und Passwort neu vergeben und es sollte eine neue Benachrichtigung versendet werden. Hinweis: Es kann mehrere Stunden dauern, bis das LMS diese Anfrage umgesetzt hat.
|
||||||
|
|||||||
@ -8,7 +8,7 @@ QualificationDescription: Description
|
|||||||
QualificationValidIndicator: Validity
|
QualificationValidIndicator: Validity
|
||||||
QualificationValidDuration: Validity period
|
QualificationValidDuration: Validity period
|
||||||
QualificationAuditDuration: Audit log keept
|
QualificationAuditDuration: Audit log keept
|
||||||
QualificationAuditDurationTooltip: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier.
|
QualificationAuditDurationTooltip n@Int: Optional period for deletion of e‑learning data. Note that the e‑learning server may delete its anonymised data earlier, at most #{n} days after closing.
|
||||||
QualificationRefreshWithin: Refresh within
|
QualificationRefreshWithin: Refresh within
|
||||||
QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
|
QualificationRefreshWithinTooltip: Optional period before expiry to start e‑learning and send a notification by post or email.
|
||||||
QualificationRefreshReminder: 2. Reminder
|
QualificationRefreshReminder: 2. Reminder
|
||||||
@ -121,7 +121,7 @@ LmsActNotify: Resend e‑learning notification by post or email
|
|||||||
LmsActRenewPin: Randomly replace e‑learning password
|
LmsActRenewPin: Randomly replace e‑learning password
|
||||||
LmsActRenewNotify: Randomly replace e‑learning password and re-send notification by post or email
|
LmsActRenewNotify: Randomly replace e‑learning password and re-send notification by post or email
|
||||||
LmsActReset: Reset and unlock e‑learning
|
LmsActReset: Reset and unlock e‑learning
|
||||||
LmsActResetInfo: E‑learning login and password remain unchanged; a notification is thus not necessary. This is only possible for already failed learners. Note that the reset procedure may take up to 2 hours.
|
LmsActResetInfo: E‑learning login, password and progress remain unchanged; a notification is thus not necessary. This is only possible for already failed learners. Note that the reset procedure may take up to 2 hours.
|
||||||
LmsActResetFeedback n@Int m@Int: For #{n}/#{m} learners all failures were erased, preserving login credentials.
|
LmsActResetFeedback n@Int m@Int: For #{n}/#{m} learners all failures were erased, preserving login credentials.
|
||||||
LmsActRestart: Restart e‑learning
|
LmsActRestart: Restart e‑learning
|
||||||
LmsActRestartWarning: The existing e‑learning will be erased immediately! For drivers with a valid licence, user and password will later be generated anew and a notification will be queued as usual, which may take several hours.
|
LmsActRestartWarning: The existing e‑learning will be erased immediately! For drivers with a valid licence, user and password will later be generated anew and a notification will be queued as usual, which may take several hours.
|
||||||
|
|||||||
@ -133,6 +133,8 @@ MenuLmsFake: Testnutzer generieren
|
|||||||
MenuLmsLearners: Export Benutzer E‑Learning
|
MenuLmsLearners: Export Benutzer E‑Learning
|
||||||
MenuLmsReport: Ergebnisse E‑Learning
|
MenuLmsReport: Ergebnisse E‑Learning
|
||||||
|
|
||||||
|
MenuFirms: Firmen
|
||||||
|
|
||||||
MenuSap: SAP Schnittstelle
|
MenuSap: SAP Schnittstelle
|
||||||
|
|
||||||
MenuAvs: AVS Schnittstelle
|
MenuAvs: AVS Schnittstelle
|
||||||
|
|||||||
@ -134,6 +134,8 @@ MenuLmsFake: Generate Test Users
|
|||||||
MenuLmsLearners: E‑learning Users
|
MenuLmsLearners: E‑learning Users
|
||||||
MenuLmsReport: E‑learning Results
|
MenuLmsReport: E‑learning Results
|
||||||
|
|
||||||
|
MenuFirms: Companies
|
||||||
|
|
||||||
MenuSap: SAP Interface
|
MenuSap: SAP Interface
|
||||||
|
|
||||||
MenuAvs: AVS Interface
|
MenuAvs: AVS Interface
|
||||||
|
|||||||
@ -75,8 +75,15 @@ TableExamOfficeLabelStatus: Label-Farbe
|
|||||||
TableExamOfficeLabelPriority: Label-Priorität
|
TableExamOfficeLabelPriority: Label-Priorität
|
||||||
TableQualifications: Qualifikationen
|
TableQualifications: Qualifikationen
|
||||||
TableCompany: Firma
|
TableCompany: Firma
|
||||||
|
TableCompanyShort: Firmenkürzel
|
||||||
TableCompanies: Firmen
|
TableCompanies: Firmen
|
||||||
|
TableCompanyNo: Firmennummer
|
||||||
TableCompanyNos: Firmennummern
|
TableCompanyNos: Firmennummern
|
||||||
|
TableCompanyNrUsers: Firmenangehörige
|
||||||
|
TableCompanyNrSupers: Ansprechpartner
|
||||||
|
TableCompanyNrForeignSupers: Firmenfremde Ansprechpartner
|
||||||
|
TableCompanyNrRerouteDefault: Standard Umleitungen
|
||||||
|
TableCompanyNrRerouteActive: Aktive Umleitungen
|
||||||
TableSupervisor: Ansprechpartner
|
TableSupervisor: Ansprechpartner
|
||||||
TableCreationTime: Erstellungszeit
|
TableCreationTime: Erstellungszeit
|
||||||
TableJob !ident-ok: Job
|
TableJob !ident-ok: Job
|
||||||
|
|||||||
@ -75,8 +75,15 @@ TableExamOfficeLabelStatus: Label colour
|
|||||||
TableExamOfficeLabelPriority: Label priority
|
TableExamOfficeLabelPriority: Label priority
|
||||||
TableQualifications: Qualifications
|
TableQualifications: Qualifications
|
||||||
TableCompany: Company
|
TableCompany: Company
|
||||||
|
TableCompanyShort: Company shorthand
|
||||||
TableCompanies: Companies
|
TableCompanies: Companies
|
||||||
|
TableCompanyNo: Company number
|
||||||
TableCompanyNos: Company numbers
|
TableCompanyNos: Company numbers
|
||||||
|
TableCompanyNrUsers: Associates
|
||||||
|
TableCompanyNrSupers: Supervisors
|
||||||
|
TableCompanyNrForeignSupers: External Supervisors
|
||||||
|
TableCompanyNrRerouteDefault: Default reroutes
|
||||||
|
TableCompanyNrRerouteActive: Active reroutes
|
||||||
TableSupervisor: Supervisor
|
TableSupervisor: Supervisor
|
||||||
TableCreationTime: Creation
|
TableCreationTime: Creation
|
||||||
TableJob !ident-ok: Job
|
TableJob !ident-ok: Job
|
||||||
|
|||||||
@ -1,3 +1,3 @@
|
|||||||
{
|
{
|
||||||
"version": "27.4.35"
|
"version": "27.4.45"
|
||||||
}
|
}
|
||||||
|
|||||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"name": "uni2work",
|
"name": "uni2work",
|
||||||
"version": "27.4.35",
|
"version": "27.4.45",
|
||||||
"lockfileVersion": 1,
|
"lockfileVersion": 1,
|
||||||
"requires": true,
|
"requires": true,
|
||||||
"dependencies": {
|
"dependencies": {
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"name": "uni2work",
|
"name": "uni2work",
|
||||||
"version": "27.4.35",
|
"version": "27.4.45",
|
||||||
"description": "",
|
"description": "",
|
||||||
"keywords": [],
|
"keywords": [],
|
||||||
"author": "",
|
"author": "",
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: uniworx
|
name: uniworx
|
||||||
version: 27.4.35
|
version: 27.4.45
|
||||||
dependencies:
|
dependencies:
|
||||||
- base
|
- base
|
||||||
- yesod
|
- yesod
|
||||||
|
|||||||
10
routes
10
routes
@ -113,6 +113,10 @@
|
|||||||
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
|
/for/#CryptoUUIDUser/user ForProfileR GET POST !supervisor !self
|
||||||
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
/for/#CryptoUUIDUser/user/profile ForProfileDataR GET !supervisor !self
|
||||||
|
|
||||||
|
/firm FirmAllR GET
|
||||||
|
/firm/#CompanyShorthand FirmR GET POST
|
||||||
|
/firm/#CompanyShorthand/users FirmUsersR GET POST
|
||||||
|
/firm/#CompanyShorthand/supers FirmSupersR GET POST
|
||||||
|
|
||||||
/exam-office ExamOfficeR !exam-office:
|
/exam-office ExamOfficeR !exam-office:
|
||||||
/ EOExamsR GET POST !system-exam-office
|
/ EOExamsR GET POST !system-exam-office
|
||||||
@ -276,7 +280,7 @@
|
|||||||
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
|
/lms/#SchoolId/#QualificationShorthand/edit LmsEditR GET POST
|
||||||
-- old V1 LMS Interface
|
-- old V1 LMS Interface
|
||||||
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
|
/lms/#SchoolId/#QualificationShorthand/users LmsUsersR GET
|
||||||
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS
|
/lms/#SchoolId/#QualificationShorthand/users/direct LmsUsersDirectR GET !token -- LMS
|
||||||
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
|
/lms/#SchoolId/#QualificationShorthand/userlist LmsUserlistR GET POST
|
||||||
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development
|
/lms/#SchoolId/#QualificationShorthand/userlist/upload LmsUserlistUploadR GET POST !development
|
||||||
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor
|
/lms/#SchoolId/#QualificationShorthand/userlist/direct LmsUserlistDirectR POST !token -- LMS, also remove JobLmsUserlist constructor
|
||||||
@ -285,11 +289,11 @@
|
|||||||
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor
|
/lms/#SchoolId/#QualificationShorthand/result/direct LmsResultDirectR POST !token -- LMS, also remove JobLmsResults constructor
|
||||||
-- new V2 LMS Interface
|
-- new V2 LMS Interface
|
||||||
/lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET
|
/lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET
|
||||||
/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS
|
/lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS
|
||||||
/lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST
|
/lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST
|
||||||
/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development
|
/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development
|
||||||
/lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS
|
/lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS
|
||||||
-- other lms routes
|
-- other lms routes
|
||||||
/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter
|
/lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter
|
||||||
/lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET
|
/lms/#SchoolId/#QualificationShorthand/user/#CryptoUUIDUser LmsUserR GET
|
||||||
/lmsuser/#CryptoUUIDUser LmsUserAllR GET
|
/lmsuser/#CryptoUUIDUser LmsUserAllR GET
|
||||||
|
|||||||
@ -275,7 +275,7 @@ in pkgs.mkShell {
|
|||||||
++ (with pkgs;
|
++ (with pkgs;
|
||||||
[ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client
|
[ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client
|
||||||
gup reuse pre-commit
|
gup reuse pre-commit
|
||||||
node2nix
|
# node2nix
|
||||||
# busybox # for print services, but interferes with build commands in develop-shell
|
# busybox # for print services, but interferes with build commands in develop-shell
|
||||||
htop
|
htop
|
||||||
pdftk # pdftk just for testing pdf-passwords
|
pdftk # pdftk just for testing pdf-passwords
|
||||||
@ -290,5 +290,5 @@ in pkgs.mkShell {
|
|||||||
;
|
;
|
||||||
})
|
})
|
||||||
]
|
]
|
||||||
) ++ (with pkgs.haskellPackages; [ yesod-bin hlint cabal-install weeder profiteur ]);
|
) ++ (with pkgs.haskellPackages; [ yesod-bin hlint cabal-install weeder ]);
|
||||||
}
|
}
|
||||||
|
|||||||
@ -159,6 +159,7 @@ import Handler.SAP
|
|||||||
import Handler.PrintCenter
|
import Handler.PrintCenter
|
||||||
import Handler.ApiDocs
|
import Handler.ApiDocs
|
||||||
import Handler.Swagger
|
import Handler.Swagger
|
||||||
|
import Handler.Firm
|
||||||
|
|
||||||
import ServantApi () -- YesodSubDispatch instances
|
import ServantApi () -- YesodSubDispatch instances
|
||||||
import Servant.API
|
import Servant.API
|
||||||
|
|||||||
@ -212,7 +212,7 @@ data Transaction
|
|||||||
}
|
}
|
||||||
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
|
| TransactionQualificationUserEdit -- Note that a renewal always entails unblocking as well!
|
||||||
{ transactionUser :: UserId -- qualification holder that is updated
|
{ transactionUser :: UserId -- qualification holder that is updated
|
||||||
, transactionQualificationUser :: QualificationUserId -- könnte entfernt werden
|
, transactionQualificationUser :: QualificationUserId -- not really necessary, maybe remove?
|
||||||
, transactionQualification :: QualificationId
|
, transactionQualification :: QualificationId
|
||||||
, transactionQualificationValidUntil :: Day
|
, transactionQualificationValidUntil :: Day
|
||||||
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
|
, transactionQualificationScheduleRenewal :: Maybe Bool -- Maybe, because some update may leave it unchanged (also avoids DB Migration)
|
||||||
@ -226,7 +226,12 @@ data Transaction
|
|||||||
{ transactionUser :: UserId -- qualification holder that is updated
|
{ transactionUser :: UserId -- qualification holder that is updated
|
||||||
-- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser
|
-- , transactionQualificationUser :: QualificationUserId -- not neccessary due to UniqueQualificationUser
|
||||||
, transactionQualification :: QualificationId
|
, transactionQualification :: QualificationId
|
||||||
, transactionQualificationBlock :: QualificationUserBlock -- TODO --
|
, transactionQualificationBlock :: QualificationUserBlock -- full information about block
|
||||||
|
}
|
||||||
|
| TransactionQualificationUserScheduleRenewal
|
||||||
|
{ transactionUser :: UserId -- qualification holder that is updated
|
||||||
|
, transactionQualification :: QualificationId
|
||||||
|
, transactionQualificationScheduleRenewal :: Maybe Bool -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit
|
||||||
}
|
}
|
||||||
deriving (Eq, Ord, Read, Show, Generic)
|
deriving (Eq, Ord, Read, Show, Generic)
|
||||||
|
|
||||||
|
|||||||
@ -20,7 +20,7 @@ module Database.Esqueleto.Utils
|
|||||||
, subSelectAnd, subSelectOr
|
, subSelectAnd, subSelectOr
|
||||||
, mkExactFilter, mkExactFilterWith
|
, mkExactFilter, mkExactFilterWith
|
||||||
, mkExactFilterLast, mkExactFilterLastWith
|
, mkExactFilterLast, mkExactFilterLastWith
|
||||||
, mkExactFilterMaybeLast
|
, mkExactFilterMaybeLast, mkExactFilterMaybeLast'
|
||||||
, mkContainsFilter, mkContainsFilterWith
|
, mkContainsFilter, mkContainsFilterWith
|
||||||
, mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
|
, mkContainsFilterWithSet, mkContainsFilterWithComma, mkContainsFilterWithCommaPlus
|
||||||
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo
|
, mkDayFilter, mkDayFilterFrom, mkDayFilterTo
|
||||||
@ -33,6 +33,7 @@ module Database.Esqueleto.Utils
|
|||||||
, selectExists, selectNotExists
|
, selectExists, selectNotExists
|
||||||
, SqlHashable
|
, SqlHashable
|
||||||
, sha256
|
, sha256
|
||||||
|
, isTrue, isFalse
|
||||||
, maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce
|
, maybe, maybe2, maybeEq, guardMaybe, unsafeCoalesce
|
||||||
, bool
|
, bool
|
||||||
, max, min
|
, max, min
|
||||||
@ -42,9 +43,10 @@ module Database.Esqueleto.Utils
|
|||||||
, (->.), (->>.), (#>>.)
|
, (->.), (->>.), (#>>.)
|
||||||
, fromSqlKey
|
, fromSqlKey
|
||||||
, unKey
|
, unKey
|
||||||
|
, subSelectCountDistinct
|
||||||
, selectCountRows, selectCountDistinct
|
, selectCountRows, selectCountDistinct
|
||||||
, selectMaybe
|
, selectMaybe
|
||||||
, day, day', interval, diffDays, diffTimes
|
, day, day', dayMaybe, interval, diffDays, diffTimes
|
||||||
, exprLift
|
, exprLift
|
||||||
, explicitUnsafeCoerceSqlExprValue
|
, explicitUnsafeCoerceSqlExprValue
|
||||||
, module Database.Esqueleto.Utils.TH
|
, module Database.Esqueleto.Utils.TH
|
||||||
@ -313,6 +315,18 @@ mkExactFilterMaybeLast lenslike row criterias
|
|||||||
| Last (Just crit) <- criterias = lenslike row E.==. E.val crit
|
| Last (Just crit) <- criterias = lenslike row E.==. E.val crit
|
||||||
| otherwise = true
|
| otherwise = true
|
||||||
|
|
||||||
|
-- | like `mkExactFilterMaybeLast` but for doubly wrapped Maybes
|
||||||
|
mkExactFilterMaybeLast' :: (PersistField a, PersistField b)
|
||||||
|
=> (t -> E.SqlExpr (E.Value (Maybe b))) -- ^ getter from query ensure entity exists at all
|
||||||
|
-> (t -> E.SqlExpr (E.Value (Maybe (Maybe a)))) -- ^ getter from query to searched element
|
||||||
|
-> t -- ^ query row
|
||||||
|
-> Last (Maybe a) -- ^ needle
|
||||||
|
-> E.SqlExpr (E.Value Bool)
|
||||||
|
mkExactFilterMaybeLast' lensexists lenslike row criterias
|
||||||
|
| Last (Just Nothing) <- criterias = isJust (lensexists row) E.&&. E.isNothing (E.joinV $ lenslike row)
|
||||||
|
| Last (Just crit) <- criterias = lenslike row E.==. E.val (Just crit)
|
||||||
|
| otherwise = true
|
||||||
|
|
||||||
-- | generic filter creation for dbTable
|
-- | generic filter creation for dbTable
|
||||||
-- Given a lens-like function, make filter searching for needles in String-like elements
|
-- Given a lens-like function, make filter searching for needles in String-like elements
|
||||||
-- (Keep Set here to ensure that there are no duplicates)
|
-- (Keep Set here to ensure that there are no duplicates)
|
||||||
@ -476,6 +490,12 @@ sha256 :: SqlHashable a => E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value (Digest S
|
|||||||
sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text))
|
sha256 = E.unsafeSqlFunction "digest" . (, E.val "sha256" :: E.SqlExpr (E.Value Text))
|
||||||
|
|
||||||
|
|
||||||
|
isTrue :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool)
|
||||||
|
isTrue expr = E.unsafeSqlBinOp "IS TRUE" expr $ E.unsafeSqlValue ""
|
||||||
|
|
||||||
|
isFalse :: E.SqlExpr (E.Value (Maybe Bool)) -> E.SqlExpr (E.Value Bool)
|
||||||
|
isFalse expr = E.unsafeSqlBinOp "IS FALSE" expr $ E.unsafeSqlValue ""
|
||||||
|
|
||||||
maybe :: (PersistField a, PersistField b)
|
maybe :: (PersistField a, PersistField b)
|
||||||
=> E.SqlExpr (E.Value b)
|
=> E.SqlExpr (E.Value b)
|
||||||
-> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b))
|
-> (E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value b))
|
||||||
@ -608,6 +628,12 @@ unKey :: ( Coercible (Key entity) a
|
|||||||
=> E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a)
|
=> E.SqlExpr (E.Value (Key entity)) -> E.SqlExpr (E.Value a)
|
||||||
unKey = E.veryUnsafeCoerceSqlExprValue
|
unKey = E.veryUnsafeCoerceSqlExprValue
|
||||||
|
|
||||||
|
-- | distinct version of `Database.Esqueleto.subSelectCount`
|
||||||
|
subSelectCountDistinct :: (Num a, PersistField a) => Ex.SqlQuery (Ex.SqlExpr (Ex.Value typ)) -> Ex.SqlExpr (Ex.Value a)
|
||||||
|
subSelectCountDistinct query = Ex.subSelectUnsafe (Ex.countDistinct <$> query)
|
||||||
|
|
||||||
|
-- PersistField a => SqlQuery (SqlExpr (Value a)) -> SqlExpr (Value a)
|
||||||
|
-- countDistinct :: Num a => SqlExpr (Value typ) -> SqlExpr (Value a)
|
||||||
|
|
||||||
selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a
|
selectCountRows :: (Num a, PersistField a, MonadIO m) => E.SqlQuery ignored -> E.SqlReadT m a
|
||||||
selectCountRows q = do
|
selectCountRows q = do
|
||||||
@ -637,6 +663,9 @@ day = E.unsafeSqlCastAs "date"
|
|||||||
day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day)
|
day' :: E.SqlExpr (E.Value Text) -> E.SqlExpr (E.Value Day)
|
||||||
day' = E.unsafeSqlCastAs "date"
|
day' = E.unsafeSqlCastAs "date"
|
||||||
|
|
||||||
|
dayMaybe :: E.SqlExpr (E.Value (Maybe UTCTime)) -> E.SqlExpr (E.Value (Maybe Day))
|
||||||
|
dayMaybe = E.unsafeSqlCastAs "date"
|
||||||
|
|
||||||
interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day
|
interval :: CalendarDiffDays -> E.SqlExpr (E.Value Day) -- E.+=. requires both types to be the same, so we use Day
|
||||||
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
|
-- interval _ = E.unsafeSqlCastAs "interval" $ E.unsafeSqlValue "'P2Y'" -- tested working example
|
||||||
interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
|
interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text.Builder.fromString . iso8601Show
|
||||||
|
|||||||
@ -123,6 +123,11 @@ breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just
|
|||||||
breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR
|
breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR
|
||||||
breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR
|
breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR
|
||||||
|
|
||||||
|
breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
|
||||||
|
breadcrumb FirmR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR
|
||||||
|
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR
|
||||||
|
breadcrumb FirmSupersR{} = i18nCrumb MsgMenuFirms $ Just FirmAllR
|
||||||
|
|
||||||
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
|
breadcrumb PrintCenterR = i18nCrumb MsgMenuApc Nothing
|
||||||
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
breadcrumb PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR
|
||||||
breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
|
breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR
|
||||||
@ -754,6 +759,18 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
|
|||||||
, navForceActive = False
|
, navForceActive = False
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
, return NavHeader
|
||||||
|
{ navHeaderRole = NavHeaderPrimary
|
||||||
|
, navIcon = IconCompany
|
||||||
|
, navLink = NavLink
|
||||||
|
{ navLabel = MsgMenuFirms
|
||||||
|
, navRoute = FirmAllR
|
||||||
|
, navAccess' = NavAccessTrue
|
||||||
|
, navType = NavTypeLink { navModal = False }
|
||||||
|
, navQuick' = mempty
|
||||||
|
, navForceActive = False
|
||||||
|
}
|
||||||
|
}
|
||||||
, return NavHeader
|
, return NavHeader
|
||||||
{ navHeaderRole = NavHeaderPrimary
|
{ navHeaderRole = NavHeaderPrimary
|
||||||
, navIcon = IconPrintCenter
|
, navIcon = IconPrintCenter
|
||||||
@ -2398,6 +2415,16 @@ pageActions ApiDocsR = return
|
|||||||
, navChildren = []
|
, navChildren = []
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
|
pageActions (FirmR fsh) = return
|
||||||
|
[ NavPageActionPrimary
|
||||||
|
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
|
||||||
|
, navChildren = []
|
||||||
|
}
|
||||||
|
, NavPageActionPrimary
|
||||||
|
{ navLink = defNavLink MsgTableCompanyNrUsers $ FirmUsersR fsh
|
||||||
|
, navChildren = []
|
||||||
|
}
|
||||||
|
]
|
||||||
pageActions PrintCenterR = do
|
pageActions PrintCenterR = do
|
||||||
openDays <- useRunDB $ Ex.select $ do
|
openDays <- useRunDB $ Ex.select $ do
|
||||||
pj <- Ex.from $ Ex.table @PrintJob
|
pj <- Ex.from $ Ex.table @PrintJob
|
||||||
|
|||||||
@ -431,8 +431,7 @@ getProblemAvsSynchR = do
|
|||||||
<*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
<*> mkLicenceTable apidStatus "avsLicDiffGrantRollfeld" AvsNoLicence avsLicenceDiffGrantRollfeld
|
||||||
|
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
let nowaday = utctDay now
|
let procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
||||||
procRes :: AvsLicence -> (LicenceTableActionData, Set AvsPersonId) -> Handler ()
|
|
||||||
procRes aLic (LicenceTableChangeAvsData , apids) = do
|
procRes aLic (LicenceTableChangeAvsData , apids) = do
|
||||||
oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
|
oks <- catchAllAvs $ setLicencesAvs $ Set.map (AvsPersonLicence aLic) apids
|
||||||
let no_req = Set.size apids
|
let no_req = Set.size apids
|
||||||
@ -458,7 +457,7 @@ getProblemAvsSynchR = do
|
|||||||
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
uids <- view _userAvsUser <<$>> selectList [UserAvsPersonId <-. Set.toList apids] []
|
||||||
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
|
-- addMessage Info $ text2Html $ "UIDs: " <> tshow uids -- DEBUG
|
||||||
void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
|
void $ qualificationUserBlocking licenceTableChangeFDriveQId uids True Nothing (Left licenceTableChangeFDriveReason) False
|
||||||
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId nowaday licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew
|
forM_ uids $ upsertQualificationUser licenceTableChangeFDriveQId now licenceTableChangeFDriveEnd licenceTableChangeFDriveRenew "Admin Resolution"
|
||||||
(length uids,) <$> get404 licenceTableChangeFDriveQId
|
(length uids,) <$> get404 licenceTableChangeFDriveQId
|
||||||
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
|
addMessageI (bool Success Warning $ null apids) $ MsgSetFraDriveLicences (citext2string qualificationShorthand) n
|
||||||
redirect ProblemAvsSynchR -- must be outside runDB
|
redirect ProblemAvsSynchR -- must be outside runDB
|
||||||
@ -556,11 +555,12 @@ mkLicenceTable apidStatus dbtIdent aLic apids = do
|
|||||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
||||||
E.orderBy [E.asc (comp E.^. CompanyName)]
|
E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||||
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
||||||
let companies = intersperse (text2markup ", ") $
|
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
||||||
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
|
companies =
|
||||||
icnSuper = text2markup " " <> icon IconSupervisor
|
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||||
pure $ toWgt $ mconcat companies
|
|
||||||
|
pure $ intercalate (text2widget "; ") companies
|
||||||
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
, sortable (Just "qualification") (i18nCell MsgTableQualifications) $ \(preview resultQualification -> q) -> cellMaybe lmsShortCell q
|
||||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \(preview $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> cellMaybe dayCell d
|
||||||
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
|
, sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \(preview $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> cellMaybe dayCell d
|
||||||
|
|||||||
@ -220,5 +220,5 @@ postAdminJobsR = do
|
|||||||
|
|
||||||
getJobName :: Value -> Maybe Text
|
getJobName :: Value -> Maybe Text
|
||||||
getJobName (Object o)
|
getJobName (Object o)
|
||||||
| Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s
|
| Just (String s) <- HashMap.lookup "job" o = Just s -- (kebabToCamel s)
|
||||||
getJobName _ = Nothing
|
getJobName _ = Nothing
|
||||||
@ -49,11 +49,19 @@ tutorialTemplateNames Nothing = ["Vorlage", "Template"]
|
|||||||
tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]
|
tutorialTemplateNames (Just name) = [prefixes <> suffixes | prefixes <- tutorialTemplateNames Nothing, suffixes <- [mempty, tutorialTypeSeparator <> name]]
|
||||||
|
|
||||||
tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
|
tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName
|
||||||
tutorialDefaultName Nothing = CI.mk . tshow -- Don't use user date display setting, so that tutorial default names conform to all users
|
tutorialDefaultName Nothing = formatDayForTutName
|
||||||
tutorialDefaultName (Just ttyp) =
|
tutorialDefaultName (Just ttyp) =
|
||||||
let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
|
let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp
|
||||||
in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing
|
in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing
|
||||||
|
|
||||||
|
formatDayForTutName :: Day -> CI Text -- "%yy_%mm_%dd" -- Do not use user date display setting, since tutorial default names must be universal regardless of user
|
||||||
|
-- formatDayForTutName = CI.mk . formatTime' "%y_%m_%d" -- we don't want to go monadic for this
|
||||||
|
formatDayForTutName = CI.mk . Text.map d2u . Text.drop 2 . tshow
|
||||||
|
where
|
||||||
|
d2u '-' = '_'
|
||||||
|
d2u c = c
|
||||||
|
|
||||||
|
|
||||||
data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
|
data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort
|
||||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||||
instance Universe ButtonCourseRegisterMode
|
instance Universe ButtonCourseRegisterMode
|
||||||
|
|||||||
779
src/Handler/Firm.hs
Normal file
779
src/Handler/Firm.hs
Normal file
@ -0,0 +1,779 @@
|
|||||||
|
-- SPDX-FileCopyrightText: 2023 Steffen Jost <S.Jost@fraport.de>
|
||||||
|
--
|
||||||
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
{-# OPTIONS -Wno-unused-top-binds -Wno-unused-imports #-} -- TODO: remove me, for debugging only
|
||||||
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
||||||
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
|
module Handler.Firm
|
||||||
|
( getFirmAllR , postFirmAllR
|
||||||
|
, getFirmR , postFirmR
|
||||||
|
, getFirmUsersR , postFirmUsersR
|
||||||
|
, getFirmSupersR, postFirmSupersR
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
-- import Jobs
|
||||||
|
import Handler.Utils
|
||||||
|
|
||||||
|
-- import qualified Data.Set as Set
|
||||||
|
-- import qualified Data.Map as Map
|
||||||
|
-- import qualified Data.Csv as Csv
|
||||||
|
-- import qualified Data.Text as T
|
||||||
|
-- import qualified Data.CaseInsensitive as CI
|
||||||
|
-- import qualified Data.Conduit.List as C
|
||||||
|
-- import Database.Persist.Sql (updateWhereCount)
|
||||||
|
import Database.Esqueleto.Experimental ((:&)(..))
|
||||||
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||||
|
-- import qualified Database.Esqueleto.Legacy as EL
|
||||||
|
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||||
|
import qualified Database.Esqueleto.Utils as E
|
||||||
|
import Database.Esqueleto.Utils.TH
|
||||||
|
|
||||||
|
|
||||||
|
-- avoids repetition of local definitions
|
||||||
|
-- single :: (k,a) -> Map k a
|
||||||
|
-- single = uncurry Map.singleton
|
||||||
|
|
||||||
|
|
||||||
|
getFirmR, postFirmR :: CompanyShorthand -> Handler Html
|
||||||
|
getFirmR = postFirmR
|
||||||
|
postFirmR fsh = do
|
||||||
|
let fshId = CompanyKey fsh
|
||||||
|
cusers <- runDB $ do
|
||||||
|
cusers <- selectList [UserCompanyCompany ==. fshId] []
|
||||||
|
selectList [UserId <-. fmap (userCompanyUser . entityVal) cusers] [Asc UserDisplayName]
|
||||||
|
csuper <- runDB $ do
|
||||||
|
csuper <- selectList [UserCompanyCompany ==. fshId, UserCompanySupervisor ==. True] []
|
||||||
|
selectList [UserId <-. fmap (userCompanyUser . entityVal) csuper] [Asc UserDisplayName]
|
||||||
|
cactSuper <- runDB $ E.select $ do
|
||||||
|
(usr :& spr :& scmpy) <- E.from $
|
||||||
|
E.table @User
|
||||||
|
`E.innerJoin` E.table @UserSupervisor
|
||||||
|
`E.on` (\(usr :& spr ) -> spr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId)
|
||||||
|
`E.leftJoin` E.table @UserCompany
|
||||||
|
`E.on` (\(_ :& spr :& scmpy) -> spr E.^. UserSupervisorSupervisor E.=?. scmpy E.?. UserCompanyUser)
|
||||||
|
E.where_ $ (spr E.^. UserSupervisorUser) `E.in_` E.valList (entityKey <$> cusers)
|
||||||
|
E.groupBy (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany)
|
||||||
|
E.orderBy [E.asc $ usr E.^. UserId, E.asc $ usr E.^. UserDisplayName, E.asc $ usr E.^. UserSurname, E.asc $ scmpy E.?. UserCompanyCompany]
|
||||||
|
let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
||||||
|
return (usr E.^. UserId, usr E.^. UserDisplayName, usr E.^. UserSurname, scmpy E.?. UserCompanyCompany, countRows')
|
||||||
|
|
||||||
|
siteLayoutMsg (SomeMessage fsh) $ do
|
||||||
|
setTitle $ citext2Html fsh
|
||||||
|
[whamlet|
|
||||||
|
<h3>#{length csuper} Company Default Supervisors (non-foreign only)
|
||||||
|
<ul>
|
||||||
|
$forall u <- csuper
|
||||||
|
<li>^{linkUserWidget ForProfileDataR u}
|
||||||
|
|
||||||
|
<h3>#{length cactSuper} Active Supervisors for Employees
|
||||||
|
<ul>
|
||||||
|
$forall (E.Value _, E.Value dn, E.Value sn, E.Value mbCsh, E.Value nr) <- cactSuper
|
||||||
|
<li>#{nr} Employees supervised by ^{nameWidget dn sn}
|
||||||
|
$maybe csh <- mbCsh
|
||||||
|
$if csh /= fshId
|
||||||
|
from foreign company #{unCompanyKey csh}
|
||||||
|
$else
|
||||||
|
from this company
|
||||||
|
$nothing
|
||||||
|
having no associated company
|
||||||
|
|
||||||
|
<h3>#{length cusers} Employees
|
||||||
|
<ul>
|
||||||
|
$forall u <- cusers
|
||||||
|
<li>^{linkUserWidget ForProfileDataR u}
|
||||||
|
|
||||||
|
In the end, this needs to be a dbTable, of course!
|
||||||
|
|]
|
||||||
|
|
||||||
|
|
||||||
|
getFirmAllR, postFirmAllR :: Handler Html
|
||||||
|
getFirmAllR = postFirmAllR
|
||||||
|
postFirmAllR = do
|
||||||
|
uid <- requireAuthId
|
||||||
|
isAdmin <- hasReadAccessTo AdminR
|
||||||
|
firmTable <- runDB $ do
|
||||||
|
view _2 <$> mkFirmAllTable isAdmin uid -- filter to associated companies for non-admins
|
||||||
|
siteLayoutMsg MsgMenuFirms $ do
|
||||||
|
setTitleI MsgMenuFirms
|
||||||
|
-- $(widgetFile "firm-all")
|
||||||
|
[whamlet|!!!STUB!!!TO DO!!!
|
||||||
|
^{firmTable}
|
||||||
|
|]
|
||||||
|
|
||||||
|
|
||||||
|
type AllCompanyTableData = DBRow (Entity Company, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64, E.Value Word64)
|
||||||
|
resultAllCompany :: Lens' AllCompanyTableData Company
|
||||||
|
resultAllCompany = _dbrOutput . _1 . _entityVal
|
||||||
|
|
||||||
|
resultAllCompanyUsers :: Lens' AllCompanyTableData Word64
|
||||||
|
resultAllCompanyUsers = _dbrOutput . _2 . _unValue
|
||||||
|
|
||||||
|
resultAllCompanySupervisors :: Lens' AllCompanyTableData Word64
|
||||||
|
resultAllCompanySupervisors = _dbrOutput . _3 . _unValue
|
||||||
|
|
||||||
|
resultAllCompanyForeignSupers :: Lens' AllCompanyTableData Word64
|
||||||
|
resultAllCompanyForeignSupers = _dbrOutput . _4 . _unValue
|
||||||
|
|
||||||
|
resultAllCompanyDefaultReroutes :: Lens' AllCompanyTableData Word64
|
||||||
|
resultAllCompanyDefaultReroutes = _dbrOutput . _5 . _unValue
|
||||||
|
|
||||||
|
resultAllCompanyActiveReroutes :: Lens' AllCompanyTableData Word64
|
||||||
|
resultAllCompanyActiveReroutes = _dbrOutput . _6 . _unValue
|
||||||
|
|
||||||
|
resultAllCompanyActiveReroutes' :: Lens' AllCompanyTableData Word64
|
||||||
|
resultAllCompanyActiveReroutes' = _dbrOutput . _7 . _unValue
|
||||||
|
|
||||||
|
fromUserCompany :: Maybe (E.SqlExpr (Entity UserCompany) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity Company) -> E.SqlQuery ()
|
||||||
|
fromUserCompany mbFltr cmpy = do
|
||||||
|
usrCmpy <- E.from $ E.table @UserCompany
|
||||||
|
let basecond = usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
||||||
|
E.where_ $ maybe basecond ((basecond E.&&.).($ usrCmpy)) mbFltr
|
||||||
|
|
||||||
|
firmCountUsers :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||||
|
firmCountUsers = E.subSelectCount . fromUserCompany Nothing
|
||||||
|
|
||||||
|
firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||||
|
firmCountSupervisors = E.subSelectCount . fromUserCompany (Just (E.^. UserCompanySupervisor))
|
||||||
|
-- firmCountSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||||
|
-- firmCountSupervisors cmpy = E.subSelectCount $ E.distinct $ do
|
||||||
|
-- usrCmpy <- E.from $ E.table @UserCompany
|
||||||
|
-- E.where_ $ (usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId)
|
||||||
|
-- E.&&. (usrCmpy E.^. UserCompanySupervisor E.==. E.true)
|
||||||
|
-- return $ usrCmpy E.^. UserCompanyUser
|
||||||
|
|
||||||
|
firmCountDefaultReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||||
|
firmCountDefaultReroutes = E.subSelectCount . fromUserCompany (Just (\uc -> uc E.^. UserCompanySupervisor E.&&. uc E.^. UserCompanySupervisorReroute))
|
||||||
|
|
||||||
|
-- firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||||
|
-- firmCountForeignSupervisors cmpy = E.coalesceDefault
|
||||||
|
-- [E.subSelect $ do
|
||||||
|
-- usrSuper <- E.from $ E.table @UserSupervisor
|
||||||
|
-- E.groupBy (usrSuper E.^. UserSupervisorSupervisor)
|
||||||
|
-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
||||||
|
-- E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
|
||||||
|
-- return E.countRows
|
||||||
|
-- ] (E.val 0)
|
||||||
|
|
||||||
|
firmCountForeignSupervisors :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||||
|
firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do
|
||||||
|
usrSuper <- E.from $ E.table @UserSupervisor
|
||||||
|
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
||||||
|
E.&&. E.notExists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorSupervisor) cmpy)
|
||||||
|
pure $ usrSuper E.^. UserSupervisorSupervisor
|
||||||
|
|
||||||
|
firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||||
|
firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do
|
||||||
|
usrSuper <- E.from $ E.table @UserSupervisor
|
||||||
|
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
||||||
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
||||||
|
pure $ usrSuper E.^. UserSupervisorSupervisor
|
||||||
|
|
||||||
|
firmCountActiveReroutes' :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64)
|
||||||
|
firmCountActiveReroutes' cmpy = E.subSelectCount $ do
|
||||||
|
usrSuper <- E.from $ E.table @UserSupervisor
|
||||||
|
E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy)
|
||||||
|
E.&&. usrSuper E.^. UserSupervisorRerouteNotifications
|
||||||
|
|
||||||
|
|
||||||
|
mkFirmAllTable :: Bool -> UserId -> DB (Any, Widget)
|
||||||
|
mkFirmAllTable isAdmin uid = do
|
||||||
|
-- now <- liftIO getCurrentTime
|
||||||
|
let
|
||||||
|
resultDBTable = DBTable{..}
|
||||||
|
where
|
||||||
|
dbtSQLQuery cmpy = do
|
||||||
|
unless isAdmin $ E.where_ $ E.exists $ do -- only show associated companies
|
||||||
|
usrCmpy <- E.from $ E.table @UserCompany
|
||||||
|
E.where_ $ usrCmpy E.^. UserCompanyCompany E.==. cmpy E.^. CompanyId
|
||||||
|
E.&&. usrCmpy E.^. UserCompanyUser E.==. E.val uid
|
||||||
|
return ( cmpy
|
||||||
|
, cmpy & firmCountUsers
|
||||||
|
, cmpy & firmCountSupervisors
|
||||||
|
, cmpy & firmCountForeignSupervisors
|
||||||
|
, cmpy & firmCountDefaultReroutes
|
||||||
|
, cmpy & firmCountActiveReroutes
|
||||||
|
, cmpy & firmCountActiveReroutes'
|
||||||
|
)
|
||||||
|
dbtRowKey = (E.^. CompanyId)
|
||||||
|
dbtProj = dbtProjId
|
||||||
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
|
[ -- if not isAdmin then mempty else dbSelect (applying _2) id (return . view (resultAllCompany . _companyShorthand))
|
||||||
|
sortable (Just "name") (i18nCell MsgTableCompany) $ \(view resultAllCompany -> firm) ->
|
||||||
|
anchorCell (FirmR $ companyShorthand firm) . toWgt $ companyName firm
|
||||||
|
, sortable (Just "short") (i18nCell MsgTableCompanyShort) $ \(view resultAllCompany -> firm) ->
|
||||||
|
let fsh = companyShorthand firm
|
||||||
|
in anchorCell (FirmR fsh) $ toWgt fsh
|
||||||
|
, sortable (Just "avsnr") (i18nCell MsgTableCompanyNo) $ \(view resultAllCompany -> firm) ->
|
||||||
|
anchorCell (FirmR $ companyShorthand firm) $ toWgt $ companyAvsId firm
|
||||||
|
, sortable (Just "users") (i18nCell MsgTableCompanyNrUsers) $ \(view resultAllCompanyUsers -> nr) -> wgtCell $ word2widget nr
|
||||||
|
, sortable (Just "supervisors") (i18nCell MsgTableCompanyNrSupers) $ \(view resultAllCompanySupervisors -> nr) -> wgtCell $ word2widget nr
|
||||||
|
, sortable (Just "reroute-def") (i18nCell MsgTableCompanyNrRerouteDefault) $ \(view resultAllCompanyDefaultReroutes -> nr) -> wgtCell $ word2widget nr
|
||||||
|
, sortable (Just "foreigners") (i18nCell MsgTableCompanyNrForeignSupers) $ \(view resultAllCompanyForeignSupers -> nr) -> wgtCell $ word2widget nr
|
||||||
|
, sortable (Just "reroute-act") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes -> nr) -> wgtCell $ word2widget nr
|
||||||
|
, sortable (Just "reroute-all") (i18nCell MsgTableCompanyNrRerouteActive) $ \(view resultAllCompanyActiveReroutes' -> nr) -> wgtCell $ word2widget nr
|
||||||
|
]
|
||||||
|
dbtSorting = mconcat
|
||||||
|
[ singletonMap "name" $ SortColumn (E.^. CompanyName)
|
||||||
|
, singletonMap "short" $ SortColumn (E.^. CompanyShorthand)
|
||||||
|
, singletonMap "avsnr" $ SortColumn (E.^. CompanyAvsId)
|
||||||
|
, singletonMap "users" $ SortColumn firmCountUsers
|
||||||
|
, singletonMap "supervisors" $ SortColumn firmCountSupervisors
|
||||||
|
, singletonMap "reroute-def" $ SortColumn firmCountDefaultReroutes
|
||||||
|
, singletonMap "foreigners" $ SortColumn firmCountForeignSupervisors
|
||||||
|
, singletonMap "reroute-act" $ SortColumn firmCountActiveReroutes
|
||||||
|
, singletonMap "reroute-all" $ SortColumn firmCountActiveReroutes'
|
||||||
|
]
|
||||||
|
dbtFilter = mconcat
|
||||||
|
[
|
||||||
|
]
|
||||||
|
dbtFilterUI = mconcat
|
||||||
|
[
|
||||||
|
]
|
||||||
|
dbtStyle = def -- { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
|
dbtParams = def
|
||||||
|
dbtIdent :: Text
|
||||||
|
dbtIdent = "firm"
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
dbtExtraReps = []
|
||||||
|
|
||||||
|
resultDBTableValidator = def
|
||||||
|
-- & defaultSorting [SortAscBy "school", SortAscBy "qshort"]
|
||||||
|
dbTable resultDBTableValidator resultDBTable
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- -- getQualificationEditR, postQualificationEditR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||||
|
-- -- getQualificationEditR = postQualificationEditR
|
||||||
|
-- -- postQualificationEditR = error "TODO"
|
||||||
|
|
||||||
|
getFirmUsersR, postFirmUsersR :: CompanyShorthand -> Handler Html
|
||||||
|
getFirmUsersR = postFirmUsersR
|
||||||
|
postFirmUsersR fsh = do
|
||||||
|
let _fshId = CompanyKey fsh
|
||||||
|
siteLayout (citext2widget fsh) $ do
|
||||||
|
setTitle $ citext2Html fsh
|
||||||
|
[whamlet|!!!STUB!!!TO DO!!!|]
|
||||||
|
|
||||||
|
getFirmSupersR, postFirmSupersR :: CompanyShorthand -> Handler Html
|
||||||
|
getFirmSupersR = postFirmSupersR
|
||||||
|
postFirmSupersR fsh = do
|
||||||
|
let _fshId = CompanyKey fsh
|
||||||
|
siteLayout (citext2widget fsh) $ do
|
||||||
|
setTitle $ citext2Html fsh
|
||||||
|
[whamlet|!!!STUB!!!TO DO!!!|]
|
||||||
|
|
||||||
|
|
||||||
|
-- data QualificationTableCsv = QualificationTableCsv -- Q..T..C.. -> qtc..
|
||||||
|
-- { qtcDisplayName :: UserDisplayName
|
||||||
|
-- , qtcEmail :: UserEmail
|
||||||
|
-- , qtcCompany :: Maybe Text
|
||||||
|
-- , qtcCompanyNumbers :: CsvSemicolonList Int
|
||||||
|
-- , qtcValidUntil :: Day
|
||||||
|
-- , qtcLastRefresh :: Day
|
||||||
|
-- , qtcBlockStatus :: Maybe Bool
|
||||||
|
-- , qtcBlockFrom :: Maybe UTCTime
|
||||||
|
-- , qtcScheduleRenewal:: Bool
|
||||||
|
-- , qtcLmsStatusTxt :: Maybe Text
|
||||||
|
-- , qtcLmsStatusDay :: Maybe UTCTime
|
||||||
|
-- }
|
||||||
|
-- deriving Generic
|
||||||
|
-- makeLenses_ ''QualificationTableCsv
|
||||||
|
|
||||||
|
-- qtcExample :: QualificationTableCsv
|
||||||
|
-- qtcExample = QualificationTableCsv
|
||||||
|
-- { qtcDisplayName = "Max Mustermann"
|
||||||
|
-- , qtcEmail = "m.mustermann@example.com"
|
||||||
|
-- , qtcCompany = Just "Example Brothers LLC, SecondaryJobs Inc"
|
||||||
|
-- , qtcCompanyNumbers = CsvSemicolonList [27,69]
|
||||||
|
-- , qtcValidUntil = compDay
|
||||||
|
-- , qtcLastRefresh = compDay
|
||||||
|
-- , qtcBlockStatus = Nothing
|
||||||
|
-- , qtcBlockFrom = Nothing
|
||||||
|
-- , qtcScheduleRenewal= True
|
||||||
|
-- , qtcLmsStatusTxt = Just "Success"
|
||||||
|
-- , qtcLmsStatusDay = Just compTime
|
||||||
|
-- }
|
||||||
|
-- where
|
||||||
|
-- compTime :: UTCTime
|
||||||
|
-- compTime = $compileTime
|
||||||
|
-- compDay :: Day
|
||||||
|
-- compDay = utctDay compTime
|
||||||
|
|
||||||
|
-- qtcOptions :: Csv.Options
|
||||||
|
-- qtcOptions = Csv.defaultOptions { Csv.fieldLabelModifier = renameLtc }
|
||||||
|
-- where
|
||||||
|
-- renameLtc "qtcDisplayName" = "licensee"
|
||||||
|
-- renameLtc other = replaceLtc $ camelToPathPiece' 1 other
|
||||||
|
-- replaceLtc ('l':'m':'s':'-':t) = prefixLms t
|
||||||
|
-- replaceLtc other = other
|
||||||
|
-- prefixLms = ("elearn-" <>)
|
||||||
|
|
||||||
|
-- instance Csv.ToNamedRecord QualificationTableCsv where
|
||||||
|
-- toNamedRecord = Csv.genericToNamedRecord qtcOptions
|
||||||
|
|
||||||
|
-- instance Csv.DefaultOrdered QualificationTableCsv where
|
||||||
|
-- headerOrder = Csv.genericHeaderOrder qtcOptions
|
||||||
|
|
||||||
|
-- instance CsvColumnsExplained QualificationTableCsv where
|
||||||
|
-- csvColumnsExplanations = genericCsvColumnsExplanations qtcOptions $ Map.fromList
|
||||||
|
-- [ ('qtcDisplayName , SomeMessage MsgLmsUser)
|
||||||
|
-- , ('qtcEmail , SomeMessage MsgTableLmsEmail)
|
||||||
|
-- , ('qtcCompany , SomeMessage MsgTableCompanies)
|
||||||
|
-- , ('qtcCompanyNumbers , SomeMessage MsgTableCompanyNos)
|
||||||
|
-- , ('qtcValidUntil , SomeMessage MsgLmsQualificationValidUntil)
|
||||||
|
-- , ('qtcLastRefresh , SomeMessage MsgTableQualificationLastRefresh)
|
||||||
|
-- , ('qtcBlockStatus , SomeMessage MsgInfoQualificationBlockStatus)
|
||||||
|
-- , ('qtcBlockFrom , SomeMessage MsgInfoQualificationBlockFrom)
|
||||||
|
-- , ('qtcScheduleRenewal, SomeMessage MsgQualificationScheduleRenewalTooltip)
|
||||||
|
-- , ('qtcLmsStatusTxt , SomeMessage MsgTableLmsStatus)
|
||||||
|
-- , ('qtcLmsStatusDay , SomeMessage MsgTableLmsStatusDay)
|
||||||
|
-- ]
|
||||||
|
|
||||||
|
|
||||||
|
-- type QualificationTableExpr = ( E.SqlExpr (Entity QualificationUser)
|
||||||
|
-- `E.InnerJoin` E.SqlExpr (Entity User)
|
||||||
|
-- ) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity LmsUser))
|
||||||
|
-- `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||||
|
|
||||||
|
-- queryQualUser :: QualificationTableExpr -> E.SqlExpr (Entity QualificationUser)
|
||||||
|
-- queryQualUser = $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||||
|
|
||||||
|
-- queryUser :: QualificationTableExpr -> E.SqlExpr (Entity User)
|
||||||
|
-- queryUser = $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||||
|
|
||||||
|
-- queryLmsUser :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity LmsUser))
|
||||||
|
-- queryLmsUser = $(sqlLOJproj 3 2)
|
||||||
|
|
||||||
|
-- queryQualBlock :: QualificationTableExpr -> E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||||
|
-- queryQualBlock = $(sqlLOJproj 3 3)
|
||||||
|
|
||||||
|
-- type QualificationTableData = DBRow (Entity QualificationUser, Entity User, Maybe (Entity LmsUser), Maybe (Entity QualificationUserBlock), [Entity UserCompany])
|
||||||
|
|
||||||
|
-- resultQualUser :: Lens' QualificationTableData (Entity QualificationUser)
|
||||||
|
-- resultQualUser = _dbrOutput . _1
|
||||||
|
|
||||||
|
-- resultUser :: Lens' QualificationTableData (Entity User)
|
||||||
|
-- resultUser = _dbrOutput . _2
|
||||||
|
|
||||||
|
-- resultLmsUser :: Traversal' QualificationTableData (Entity LmsUser)
|
||||||
|
-- resultLmsUser = _dbrOutput . _3 . _Just
|
||||||
|
|
||||||
|
-- resultQualBlock :: Traversal' QualificationTableData (Entity QualificationUserBlock)
|
||||||
|
-- resultQualBlock = _dbrOutput . _4 . _Just
|
||||||
|
|
||||||
|
-- resultCompanyUser :: Lens' QualificationTableData [Entity UserCompany]
|
||||||
|
-- resultCompanyUser = _dbrOutput . _5
|
||||||
|
|
||||||
|
|
||||||
|
-- instance HasEntity QualificationTableData User where
|
||||||
|
-- hasEntity = resultUser
|
||||||
|
|
||||||
|
-- instance HasUser QualificationTableData where
|
||||||
|
-- hasUser = resultUser . _entityVal
|
||||||
|
|
||||||
|
-- instance HasEntity QualificationTableData QualificationUser where
|
||||||
|
-- hasEntity = resultQualUser
|
||||||
|
|
||||||
|
-- instance HasQualificationUser QualificationTableData where
|
||||||
|
-- hasQualificationUser = resultQualUser . _entityVal
|
||||||
|
|
||||||
|
-- -- instance HasEntity QualificationUserBlock where
|
||||||
|
-- -- hasQualificationUserBlock = resultQualBlock
|
||||||
|
|
||||||
|
|
||||||
|
-- data QualificationTableAction
|
||||||
|
-- = QualificationActExpire
|
||||||
|
-- | QualificationActUnexpire
|
||||||
|
-- | QualificationActBlockSupervisor
|
||||||
|
-- | QualificationActBlock
|
||||||
|
-- | QualificationActUnblock
|
||||||
|
-- | QualificationActRenew
|
||||||
|
-- | QualificationActGrant
|
||||||
|
-- deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||||
|
|
||||||
|
-- instance Universe QualificationTableAction
|
||||||
|
-- instance Finite QualificationTableAction
|
||||||
|
-- nullaryPathPiece ''QualificationTableAction $ camelToPathPiece' 2
|
||||||
|
-- embedRenderMessage ''UniWorX ''QualificationTableAction id
|
||||||
|
|
||||||
|
-- {-
|
||||||
|
-- isAdminAct :: QualificationTableAction -> Bool
|
||||||
|
-- isAdminAct QualificationActExpire = False
|
||||||
|
-- isAdminAct QualificationActUnexpire = False
|
||||||
|
-- isAdminAct QualificationActBlockSupervisor = False
|
||||||
|
-- isAdminAct _ = True
|
||||||
|
-- -}
|
||||||
|
|
||||||
|
-- data QualificationTableActionData
|
||||||
|
-- = QualificationActExpireData
|
||||||
|
-- | QualificationActUnexpireData
|
||||||
|
-- | QualificationActBlockSupervisorData
|
||||||
|
-- | QualificationActBlockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool, qualTableActRemoveSupervisors :: Bool }
|
||||||
|
-- | QualificationActUnblockData { qualTableActBlockReason :: Text, qualTableActNotify :: Bool}
|
||||||
|
-- | QualificationActRenewData
|
||||||
|
-- | QualificationActGrantData { qualTableActGrantUntil :: Day }
|
||||||
|
-- deriving (Eq, Ord, Show, Generic)
|
||||||
|
|
||||||
|
-- isExpiryAct :: QualificationTableActionData -> Bool
|
||||||
|
-- isExpiryAct QualificationActExpireData = True
|
||||||
|
-- isExpiryAct QualificationActUnexpireData = True
|
||||||
|
-- isExpiryAct _ = False
|
||||||
|
|
||||||
|
-- isBlockAct :: QualificationTableActionData -> Bool
|
||||||
|
-- isBlockAct QualificationActBlockSupervisorData = True
|
||||||
|
-- isBlockAct QualificationActBlockData{} = True
|
||||||
|
-- isBlockAct QualificationActUnblockData{} = True
|
||||||
|
-- isBlockAct _ = False
|
||||||
|
|
||||||
|
-- blockActRemoveSupervisors :: QualificationTableActionData -> Bool
|
||||||
|
-- blockActRemoveSupervisors QualificationActBlockSupervisorData = True
|
||||||
|
-- blockActRemoveSupervisors QualificationActBlockData{qualTableActRemoveSupervisors=res} = res
|
||||||
|
-- blockActRemoveSupervisors _ = False
|
||||||
|
|
||||||
|
-- -- qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
|
||||||
|
-- -- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
||||||
|
-- -- , E.SqlExpr (Entity User)
|
||||||
|
-- -- , E.SqlExpr (Maybe (Entity LmsUser))
|
||||||
|
-- -- )
|
||||||
|
-- -- qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUse) = do
|
||||||
|
-- -- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
||||||
|
-- -- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
|
||||||
|
-- -- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||||
|
-- -- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
|
||||||
|
-- -- return (qualUser, user, lmsUser)
|
||||||
|
|
||||||
|
-- qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
|
||||||
|
-- -> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
||||||
|
-- , E.SqlExpr (Entity User)
|
||||||
|
-- , E.SqlExpr (Maybe (Entity LmsUser))
|
||||||
|
-- , E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||||
|
-- )
|
||||||
|
-- qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
||||||
|
-- -- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
|
||||||
|
-- --
|
||||||
|
-- E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
|
||||||
|
-- E.&&. qualBlock `isLatestBlockBefore` E.val now
|
||||||
|
-- E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
||||||
|
-- E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
|
||||||
|
-- E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||||
|
-- E.where_ $ fltr qualUser
|
||||||
|
-- E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
|
||||||
|
-- return (qualUser, user, lmsUser, qualBlock)
|
||||||
|
|
||||||
|
|
||||||
|
-- mkQualificationTable ::
|
||||||
|
-- ( Functor h, ToSortable h
|
||||||
|
-- , AsCornice h p QualificationTableData (DBCell (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))) cols
|
||||||
|
-- )
|
||||||
|
-- => Bool
|
||||||
|
-- -> Entity Qualification
|
||||||
|
-- -> Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
||||||
|
-- -> (Map CompanyId Company -> cols)
|
||||||
|
-- -> PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData))
|
||||||
|
-- -> DB (FormResult (QualificationTableActionData, Set UserId), Widget)
|
||||||
|
-- mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
||||||
|
-- svs <- getSupervisees
|
||||||
|
-- now <- liftIO getCurrentTime
|
||||||
|
-- -- lookup all companies
|
||||||
|
-- cmpMap <- memcachedBy (Just . Right $ 5 * diffMinute) ("CompanyDictionary"::Text) $ do
|
||||||
|
-- cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
||||||
|
-- return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
||||||
|
-- let
|
||||||
|
-- nowaday = utctDay now
|
||||||
|
-- mbRenewal = addGregorianDurationClip <$> qualificationRefreshWithin quali <*> Just nowaday
|
||||||
|
-- csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
|
||||||
|
-- dbtIdent :: Text
|
||||||
|
-- dbtIdent = "qualification"
|
||||||
|
-- fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `E.in_` E.vals svs
|
||||||
|
-- dbtSQLQuery = qualificationTableQuery now qid fltrSvs
|
||||||
|
-- dbtRowKey = queryUser >>> (E.^. UserId)
|
||||||
|
-- dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
|
||||||
|
-- -- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||||
|
-- -- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
|
-- -- E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val (entityKey usr)
|
||||||
|
-- -- E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||||
|
-- -- return (comp E.^. CompanyName, comp E.^. CompanyAvsId, usrComp E.^. UserCompanySupervisor)
|
||||||
|
-- cmpUsr <- selectList [UserCompanyUser ==. entityKey usr] [Asc UserCompanyCompany]
|
||||||
|
-- return (qualUsr, usr, lmsUsr, qUsrBlock, cmpUsr)
|
||||||
|
-- dbtColonnade = cols cmpMap
|
||||||
|
-- dbtSorting = mconcat
|
||||||
|
-- [ single $ sortUserNameLink queryUser
|
||||||
|
-- , single $ sortUserEmail queryUser
|
||||||
|
-- , single $ sortUserMatriclenr queryUser
|
||||||
|
-- , single ("first-held" , SortColumn $ queryQualUser >>> (E.^. QualificationUserFirstHeld))
|
||||||
|
-- , single ("last-refresh" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastRefresh))
|
||||||
|
-- , single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
|
||||||
|
-- , single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||||
|
-- , single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
||||||
|
-- , single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
|
||||||
|
-- , E.joinV (queryLmsUser row E.?. LmsUserNotified)
|
||||||
|
-- , queryLmsUser row E.?. LmsUserStarted])
|
||||||
|
-- , single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
||||||
|
-- , single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||||
|
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
|
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
|
||||||
|
-- E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||||
|
-- return (comp E.^. CompanyName)
|
||||||
|
-- )
|
||||||
|
-- -- , single ("validity", SortColumn $ queryQualUser >>> validQualification now)
|
||||||
|
-- ]
|
||||||
|
-- dbtFilter = mconcat
|
||||||
|
-- [ single $ fltrUserNameEmail queryUser
|
||||||
|
-- , single ("avs-number" , FilterColumn . E.mkExistsFilter $ \row criterion ->
|
||||||
|
-- E.from $ \usrAvs -> -- do
|
||||||
|
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. queryUser row E.^. UserId
|
||||||
|
-- E.&&. ((E.val criterion :: E.SqlExpr (E.Value (CI Text))) E.==.
|
||||||
|
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (usrAvs E.^. UserAvsNoPerson) :: E.SqlExpr (E.Value (CI Text))) ))
|
||||||
|
-- , single ("avs-card" , FilterColumn $ \(queryUser -> user) (criterion :: Set.Set Text) -> case readAvsFullCardNo =<< Set.lookupMin criterion of
|
||||||
|
-- Nothing -> E.false
|
||||||
|
-- Just cardNo -> E.exists $ E.from $ \(avsCard `E.InnerJoin` usrAvs) -> do
|
||||||
|
-- E.on $ usrAvs E.^. UserAvsPersonId E.==. avsCard E.^. UserAvsCardPersonId
|
||||||
|
-- E.where_ $ usrAvs E.^. UserAvsUser E.==. user E.^. UserId
|
||||||
|
-- E.&&. (avsCard E.^. UserAvsCardCardNo E.==. E.val cardNo)
|
||||||
|
-- )
|
||||||
|
-- , single ("personal-number", FilterColumn $ \(queryUser -> user) (criteria :: Set.Set Text) -> if
|
||||||
|
-- | Set.null criteria -> E.true
|
||||||
|
-- | otherwise -> E.any (\c -> user E.^. UserCompanyPersonalNumber `E.hasInfix` E.val c) criteria
|
||||||
|
-- )
|
||||||
|
-- , single ("user-company", FilterColumn . E.mkExistsFilter $ \row criterion ->
|
||||||
|
-- E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||||
|
-- let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
|
||||||
|
-- (E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
|
||||||
|
-- testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
|
||||||
|
-- testcrit = maybe testname testnumber $ readMay $ CI.original criterion
|
||||||
|
-- E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
|
-- E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
||||||
|
-- )
|
||||||
|
-- , single ("validity" , FilterColumn . E.mkExactFilterLast $ views (to queryQualUser) (validQualification now))
|
||||||
|
-- , single ("renewal-due" , FilterColumn $ \(queryQualUser -> quser) criterion ->
|
||||||
|
-- if | Just renewal <- mbRenewal
|
||||||
|
-- , Just True <- getLast criterion -> quser E.^. QualificationUserValidUntil E.<=. E.val renewal
|
||||||
|
-- E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
||||||
|
-- | otherwise -> E.true
|
||||||
|
-- )
|
||||||
|
-- , single ("tobe-notified", FilterColumn $ \row criterion ->
|
||||||
|
-- if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
|
||||||
|
-- | otherwise -> E.true
|
||||||
|
-- )
|
||||||
|
-- , single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
|
||||||
|
-- ]
|
||||||
|
-- dbtFilterUI mPrev = mconcat
|
||||||
|
-- [ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||||
|
-- , prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
||||||
|
-- , prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
|
||||||
|
-- , prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
|
||||||
|
-- , prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
|
||||||
|
-- , prismAForm (singletonFilter "validity" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterLmsValid)
|
||||||
|
-- , if isNothing mbRenewal then mempty
|
||||||
|
-- else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
||||||
|
-- , prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
|
||||||
|
-- , prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
|
||||||
|
-- ]
|
||||||
|
-- dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
|
-- dbtCsvEncode = Just DBTCsvEncode
|
||||||
|
-- { dbtCsvExportForm = pure ()
|
||||||
|
-- , dbtCsvDoEncode = \() -> C.map (doEncode' . view _2)
|
||||||
|
-- , dbtCsvName = csvName
|
||||||
|
-- , dbtCsvSheetName = csvName
|
||||||
|
-- , dbtCsvNoExportData = Just id
|
||||||
|
-- , dbtCsvHeader = const $ return $ Csv.headerOrder qtcExample
|
||||||
|
-- , dbtCsvExampleData = Just [qtcExample]
|
||||||
|
-- }
|
||||||
|
-- where
|
||||||
|
-- doEncode' :: QualificationTableData -> QualificationTableCsv
|
||||||
|
-- doEncode' = QualificationTableCsv
|
||||||
|
-- <$> view (resultUser . _entityVal . _userDisplayName)
|
||||||
|
-- <*> view (resultUser . _entityVal . _userDisplayEmail)
|
||||||
|
-- <*> (view resultCompanyUser >>= getCompanies)
|
||||||
|
-- <*> (view resultCompanyUser >>= getCompanyNos)
|
||||||
|
-- <*> view (resultQualUser . _entityVal . _qualificationUserValidUntil)
|
||||||
|
-- <*> view (resultQualUser . _entityVal . _qualificationUserLastRefresh)
|
||||||
|
-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockUnblock . _not)
|
||||||
|
-- <*> preview (resultQualBlock. _entityVal . _qualificationUserBlockFrom)
|
||||||
|
-- <*> view (resultQualUser . _entityVal . _qualificationUserScheduleRenewal)
|
||||||
|
-- <*> getStatusPlusTxt
|
||||||
|
-- <*> getStatusPlusDay
|
||||||
|
-- getCompanies cmps = case mapMaybe (flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany)) cmps of
|
||||||
|
-- [] -> pure Nothing
|
||||||
|
-- somecmps -> pure $ Just $ intercalate ", " $ fmap (view (_companyName . _CI)) somecmps
|
||||||
|
-- getCompanyNos = pure . CsvSemicolonList . mapMaybe (preview (_Just . _companyAvsId) . flip Map.lookup cmpMap . view (_entityVal . _userCompanyCompany))
|
||||||
|
|
||||||
|
-- getStatusPlusTxt =
|
||||||
|
-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatus)) >>= \case
|
||||||
|
-- Just LmsBlocked{} -> return $ Just "Failed"
|
||||||
|
-- Just LmsExpired{} -> return $ Just "Expired"
|
||||||
|
-- Just LmsSuccess{} -> return $ Just "Success"
|
||||||
|
-- Nothing -> maybeM (return Nothing) (const $ return $ Just "Open") $
|
||||||
|
-- preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||||
|
-- getStatusPlusDay =
|
||||||
|
-- (join . preview (resultLmsUser . _entityVal . _lmsUserStatusDay)) >>= \case
|
||||||
|
-- lsd@(Just _) -> return lsd
|
||||||
|
-- Nothing -> preview (resultLmsUser . _entityVal . _lmsUserStarted)
|
||||||
|
|
||||||
|
-- dbtCsvDecode = Nothing
|
||||||
|
-- dbtExtraReps = []
|
||||||
|
-- dbtParams = DBParamsForm
|
||||||
|
-- { dbParamsFormMethod = POST
|
||||||
|
-- , dbParamsFormAction = Nothing
|
||||||
|
-- , dbParamsFormAttrs = []
|
||||||
|
-- , dbParamsFormSubmit = FormSubmit
|
||||||
|
-- , dbParamsFormAdditional
|
||||||
|
-- = renderAForm FormStandard
|
||||||
|
-- $ (, mempty) . First . Just
|
||||||
|
-- <$> multiActionA acts (fslI MsgTableAction) Nothing
|
||||||
|
-- , dbParamsFormEvaluate = liftHandler . runFormPost
|
||||||
|
-- , dbParamsFormResult = id
|
||||||
|
-- , dbParamsFormIdent = def
|
||||||
|
-- }
|
||||||
|
|
||||||
|
-- postprocess :: FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableData)
|
||||||
|
-- -> FormResult ( QualificationTableActionData, Set UserId)
|
||||||
|
-- postprocess inp = do
|
||||||
|
-- (First (Just act), usrMap) <- inp
|
||||||
|
-- let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
|
||||||
|
-- return (act, usrSet)
|
||||||
|
|
||||||
|
-- -- resultDBTableValidator :: PSValidator (MForm Handler) (FormResult (First QualificationTableActionData, DBFormResult UserId Bool QualificationTableActionData))
|
||||||
|
-- -- resultDBTableValidator = def
|
||||||
|
-- -- & defaultSorting [SortAscBy csvLmsIdent]
|
||||||
|
-- over _1 postprocess <$> dbTable psValidator DBTable{..}
|
||||||
|
|
||||||
|
-- getQualificationR, postQualificationR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||||
|
-- getQualificationR = postQualificationR
|
||||||
|
-- postQualificationR sid qsh = do
|
||||||
|
-- isAdmin <- hasReadAccessTo AdminR
|
||||||
|
-- msgGrantWarning <- messageIconI Warning IconWarning MsgQualificationActGrantWarning
|
||||||
|
-- msgUnexpire <- messageIconI Info IconWarning MsgQualificationActUnexpireWarning
|
||||||
|
-- now <- liftIO getCurrentTime
|
||||||
|
-- let nowaday = utctDay now
|
||||||
|
-- ((lmsRes, qualificationTable), Entity qid quali) <- runDB $ do
|
||||||
|
-- qent@Entity{
|
||||||
|
-- entityKey=qid
|
||||||
|
-- , entityVal=Qualification{
|
||||||
|
-- qualificationAuditDuration=auditMonths
|
||||||
|
-- , qualificationValidDuration=validMonths
|
||||||
|
-- }} <- getBy404 $ SchoolQualificationShort sid qsh
|
||||||
|
|
||||||
|
-- -- Block copied to Handler/Qualifications TODO: refactor
|
||||||
|
-- let getBlockReasons unblk = E.select $ do
|
||||||
|
-- (quser :& qblock) <- E.from $ E.table @QualificationUser
|
||||||
|
-- `E.innerJoin` E.table @QualificationUserBlock
|
||||||
|
-- `E.on` (\(quser :& qblock) -> quser E.^. QualificationUserId E.==. qblock E.^. QualificationUserBlockQualificationUser)
|
||||||
|
-- E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||||
|
-- E.&&. unblk (qblock E.^. QualificationUserBlockUnblock)
|
||||||
|
-- E.groupBy (qblock E.^. QualificationUserBlockReason)
|
||||||
|
-- let countRows' :: E.SqlExpr (E.Value Int64) = E.countRows
|
||||||
|
-- E.orderBy [E.desc countRows']
|
||||||
|
-- E.limit 7
|
||||||
|
-- pure (qblock E.^. QualificationUserBlockReason)
|
||||||
|
-- mkOption :: E.Value Text -> Option Text
|
||||||
|
-- mkOption (E.unValue -> t) = Option{ optionDisplay = t, optionInternalValue = t, optionExternalValue = toPathPiece t }
|
||||||
|
-- suggestionsBlock :: HandlerFor UniWorX (OptionList Text)
|
||||||
|
-- suggestionsBlock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons E.not_)
|
||||||
|
-- suggestionsUnblock = mkOptionList . fmap mkOption <$> runDB (getBlockReasons id)
|
||||||
|
-- dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> validMonths
|
||||||
|
-- acts :: Map QualificationTableAction (AForm Handler QualificationTableActionData)
|
||||||
|
-- acts = mconcat $
|
||||||
|
-- [ singletonMap QualificationActExpire $ pure QualificationActExpireData
|
||||||
|
-- , singletonMap QualificationActUnexpire $ QualificationActUnexpireData
|
||||||
|
-- <$ aformMessage msgUnexpire
|
||||||
|
-- ] ++ bool
|
||||||
|
-- -- nonAdmin actions, ie. Supervisor
|
||||||
|
-- [ singletonMap QualificationActBlockSupervisor $ pure QualificationActBlockSupervisorData ]
|
||||||
|
-- -- Admin-only actions
|
||||||
|
-- [ singletonMap QualificationActUnblock $ QualificationActUnblockData
|
||||||
|
-- <$> apreq (textField & cfStrip & addDatalist suggestionsUnblock) (fslI MsgQualificationGrantReason) Nothing
|
||||||
|
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
||||||
|
-- , singletonMap QualificationActBlock $ QualificationActBlockData
|
||||||
|
-- <$> apreq (textField & cfStrip & addDatalist suggestionsBlock) (fslI MsgQualificationBlockReason) Nothing
|
||||||
|
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockNotify) (Just False)
|
||||||
|
-- <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgQualificationBlockRemoveSupervisor) (Just False)
|
||||||
|
-- , singletonMap QualificationActRenew $ pure QualificationActRenewData
|
||||||
|
-- , singletonMap QualificationActGrant $ QualificationActGrantData
|
||||||
|
-- <$> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
|
||||||
|
-- <* aformMessage msgGrantWarning
|
||||||
|
-- ] isAdmin
|
||||||
|
-- linkLmsUser = toMaybe isAdmin (LmsUserR sid qsh)
|
||||||
|
-- linkUserName = bool ForProfileR ForProfileDataR isAdmin
|
||||||
|
-- colChoices cmpMap = mconcat
|
||||||
|
-- [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
|
||||||
|
-- , colUserNameModalHdr MsgLmsUser linkUserName
|
||||||
|
-- , colUserEmail
|
||||||
|
-- , sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
||||||
|
-- let icnSuper = text2markup " " <> icon IconSupervisor
|
||||||
|
-- cs = [ (cmpName, cmpSpr)
|
||||||
|
-- | Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||||
|
-- , let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||||
|
-- ]
|
||||||
|
-- companies = intercalate (text2markup ", ") $
|
||||||
|
-- (\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
|
||||||
|
-- in wgtCell companies
|
||||||
|
-- , guardMonoid isAdmin colUserMatriclenr
|
||||||
|
-- -- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||||
|
-- , sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||||
|
-- , sortable (Just "last-refresh") (i18nCell MsgTableQualificationLastRefresh)$ \( view $ resultQualUser . _entityVal . _qualificationUserLastRefresh -> d) -> dayCell d
|
||||||
|
-- , sortable (Just "valid-until") (i18nCell MsgLmsQualificationValidUntil) (dayCell . view ( resultQualUser . _entityVal . _qualificationUserValidUntil))
|
||||||
|
-- , sortable (Just "blocked") (i18nCell MsgQualificationValidIndicator & cellTooltip MsgTableQualificationBlockedTooltipSimple) $ \row ->
|
||||||
|
-- qualificationValidReasonCell' (Just $ LmsUserR sid qsh) isAdmin nowaday (row ^? resultQualBlock) row
|
||||||
|
-- , sortable (Just "schedule-renew")(i18nCell MsgTableQualificationNoRenewal & cellTooltip MsgTableQualificationNoRenewalTooltip
|
||||||
|
-- ) $ \( view $ resultQualUser . _entityVal . _qualificationUserScheduleRenewal -> b) -> ifIconCell (not b) IconNoNotification
|
||||||
|
-- , sortable (Just "lms-status-plus")(i18nCell MsgTableLmsStatus & cellTooltipWgt Nothing (lmsStatusInfoCell isAdmin auditMonths))
|
||||||
|
-- $ \(preview $ resultLmsUser . _entityVal -> lu) -> foldMap (lmsStatusCell isAdmin linkLmsUser) lu
|
||||||
|
-- , sortable (Just "last-notified") (i18nCell MsgTableQualificationLastNotified) $ \( view $ resultQualUser . _entityVal . _qualificationUserLastNotified -> d) -> dateTimeCell d
|
||||||
|
-- ]
|
||||||
|
-- psValidator = def & defaultSorting [SortDescBy "last-refresh"]
|
||||||
|
-- tbl <- mkQualificationTable isAdmin qent acts colChoices psValidator
|
||||||
|
-- return (tbl, qent)
|
||||||
|
|
||||||
|
-- formResult lmsRes $ \case
|
||||||
|
-- (QualificationActRenewData, selectedUsers) | isAdmin -> do
|
||||||
|
-- noks <- runDB $ renewValidQualificationUsers qid Nothing $ Set.toList selectedUsers
|
||||||
|
-- addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
||||||
|
-- reloadKeepGetParams $ QualificationR sid qsh
|
||||||
|
-- (QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
||||||
|
-- runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
|
||||||
|
-- addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
||||||
|
-- reloadKeepGetParams $ QualificationR sid qsh
|
||||||
|
-- (action, selectedUsers) | isExpiryAct action -> do
|
||||||
|
-- let isUnexpire = action == QualificationActUnexpireData
|
||||||
|
-- upd <- runDB $ updateWhereCount
|
||||||
|
-- [QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
|
||||||
|
-- [QualificationUserScheduleRenewal =. isUnexpire]
|
||||||
|
-- let msgKind = if upd > 0 then Success else Warning
|
||||||
|
-- msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
|
||||||
|
-- addMessageI msgKind msgVal
|
||||||
|
-- reloadKeepGetParams $ QualificationR sid qsh
|
||||||
|
-- (action, selectedUsers) | isBlockAct action && (isAdmin || action == QualificationActBlockSupervisorData) -> do
|
||||||
|
-- let selUserIds = Set.toList selectedUsers
|
||||||
|
-- (unblock, reason) = case action of
|
||||||
|
-- QualificationActBlockSupervisorData -> (False, Right QualificationBlockReturnedByCompany)
|
||||||
|
-- QualificationActBlockData{..} -> (False, Left qualTableActBlockReason)
|
||||||
|
-- QualificationActUnblockData{..} -> (True , Left qualTableActBlockReason)
|
||||||
|
-- _ -> error "Handle.Qualification.isBlockAct returned non-block action" -- cannot occur due to earlier checks
|
||||||
|
-- notify = case action of
|
||||||
|
-- QualificationActBlockData{qualTableActNotify} -> qualTableActNotify
|
||||||
|
-- _ -> False
|
||||||
|
|
||||||
|
-- oks <- runDB $ do
|
||||||
|
-- when (blockActRemoveSupervisors action) $ deleteWhere [UserSupervisorUser <-. selUserIds]
|
||||||
|
-- qualificationUserBlocking qid selUserIds unblock Nothing reason notify
|
||||||
|
-- let nrq = length selectedUsers
|
||||||
|
-- warnLevel = if
|
||||||
|
-- | oks < 0 -> Error
|
||||||
|
-- | oks == nrq -> Success
|
||||||
|
-- | otherwise -> Warning
|
||||||
|
-- fbmsg = if unblock then MsgQualificationStatusUnblock else MsgQualificationStatusBlock
|
||||||
|
-- addMessageI warnLevel $ fbmsg qsh oks nrq
|
||||||
|
-- reloadKeepGetParams $ QualificationR sid qsh
|
||||||
|
-- _ -> addMessageI Error MsgInvalidFormAction
|
||||||
|
|
||||||
|
-- let heading = citext2widget $ qualificationName quali
|
||||||
|
-- siteLayout heading $ do
|
||||||
|
-- setTitle $ toHtml $ unSchoolKey sid <> "-" <> qsh
|
||||||
|
-- $(widgetFile "qualification")
|
||||||
@ -3,7 +3,6 @@
|
|||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
{-# OPTIONS_GHC -fno-warn-orphans #-} -- needed for HasEntity instances
|
||||||
{-# OPTIONS -Wno-unused-top-binds #-} -- TODO: remove me, for debugging only
|
|
||||||
{-# LANGUAGE TypeApplications #-}
|
{-# LANGUAGE TypeApplications #-}
|
||||||
|
|
||||||
module Handler.LMS
|
module Handler.LMS
|
||||||
@ -42,7 +41,7 @@ import qualified Data.Set as Set
|
|||||||
import qualified Data.Map as Map
|
import qualified Data.Map as Map
|
||||||
import qualified Data.Csv as Csv
|
import qualified Data.Csv as Csv
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.CaseInsensitive as CI
|
-- import qualified Data.CaseInsensitive as CI
|
||||||
import qualified Data.Conduit.List as C
|
import qualified Data.Conduit.List as C
|
||||||
import Database.Esqueleto.Experimental ((:&)(..))
|
import Database.Esqueleto.Experimental ((:&)(..))
|
||||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||||
@ -104,9 +103,10 @@ postLmsAllR = do
|
|||||||
, formEncoding = btnEnctype
|
, formEncoding = btnEnctype
|
||||||
, formSubmit = FormNoSubmit
|
, formSubmit = FormNoSubmit
|
||||||
}
|
}
|
||||||
|
|
||||||
|
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
|
||||||
lmsTable <- runDB $ do
|
lmsTable <- runDB $ do
|
||||||
view _2 <$> mkLmsAllTable isAdmin
|
view _2 <$> mkLmsAllTable isAdmin lmsDeletionDays
|
||||||
siteLayoutMsg MsgMenuLms $ do
|
siteLayoutMsg MsgMenuLms $ do
|
||||||
setTitleI MsgMenuLms
|
setTitleI MsgMenuLms
|
||||||
$(widgetFile "lms-all")
|
$(widgetFile "lms-all")
|
||||||
@ -122,8 +122,8 @@ resultAllQualificationTotal :: Lens' AllQualificationTableData Word64
|
|||||||
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
resultAllQualificationTotal = _dbrOutput . _3 . _unValue
|
||||||
|
|
||||||
|
|
||||||
mkLmsAllTable :: Bool -> DB (Any, Widget)
|
mkLmsAllTable :: Bool -> Int -> DB (Any, Widget)
|
||||||
mkLmsAllTable isAdmin = do
|
mkLmsAllTable isAdmin lmsDeletionDays = do
|
||||||
svs <- getSupervisees
|
svs <- getSupervisees
|
||||||
let
|
let
|
||||||
resultDBTable = DBTable{..}
|
resultDBTable = DBTable{..}
|
||||||
@ -160,7 +160,7 @@ mkLmsAllTable isAdmin = do
|
|||||||
-- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
|
-- , sortable Nothing (i18nCell MsgQualificationRefreshWithin) $ foldMap textCell . view (resultAllQualification . _qualificationRefreshWithin . to formatCalendarDiffDays) -- does not work, since there is a maybe in between
|
||||||
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
, sortable Nothing (i18nCell MsgQualificationRefreshReminder & cellTooltips [SomeMessage MsgQualificationRefreshReminderTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
||||||
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
foldMap (textCell . formatCalendarDiffDays ) . view (resultAllQualification . _qualificationRefreshReminder)
|
||||||
, sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage MsgQualificationAuditDurationTooltip, SomeMessage MsgTableDiffDaysTooltip]) $
|
, sortable Nothing (i18nCell MsgQualificationAuditDuration & cellTooltips [SomeMessage (MsgQualificationAuditDurationTooltip lmsDeletionDays), SomeMessage MsgTableDiffDaysTooltip]) $
|
||||||
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
|
foldMap (textCell . formatCalendarDiffDays . fromMonths) . view (resultAllQualification . _qualificationAuditDuration)
|
||||||
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
, sortable (Just "qelearning") (i18nCell MsgTableLmsElearning & cellTooltip MsgQualificationElearningStart)
|
||||||
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
$ tickmarkCell . view (resultAllQualification . _qualificationElearningStart)
|
||||||
@ -423,7 +423,7 @@ lmsTableQuery now qid (qualUser `E.InnerJoin` user `E.InnerJoin` lmsUser `E.Left
|
|||||||
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
E.where_ $ E.isJust (pj E.^. PrintJobLmsUser)
|
||||||
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
|
E.&&. ((lmsUser E.^. LmsUserIdent) E.=?. (pj E.^. PrintJobLmsUser))
|
||||||
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
let pjOrder = [E.desc $ pj E.^. PrintJobCreated, E.desc $ pj E.^. PrintJobAcknowledged] -- latest created comes first! This is assumed to be the case later on!
|
||||||
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted typr of subSelect does not seem to support this!
|
pure $ --(E.arrayAggWith E.AggModeAll (pj E.^. PrintJobCreated ) pjOrder, -- return two aggregates only works with select, the restricted type of subSelect does not seem to support this!
|
||||||
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
E.arrayAggWith E.AggModeAll (pj E.^. PrintJobAcknowledged) pjOrder
|
||||||
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
|
return (qualUser, user, lmsUser, qualBlock, printAcknowledged, validQualification now qualUser)
|
||||||
|
|
||||||
@ -444,7 +444,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
cmps <- selectList [] [] -- [Asc CompanyShorthand]
|
||||||
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
return $ Map.fromList $ fmap (\Entity{..} -> (entityKey, entityVal)) cmps
|
||||||
let
|
let
|
||||||
csvName = T.replace " " "-" $ CI.original (quali ^. _qualificationName)
|
csvName = T.replace " " "-" $ ciOriginal (quali ^. _qualificationName)
|
||||||
dbtIdent :: Text
|
dbtIdent :: Text
|
||||||
dbtIdent = "lms"
|
dbtIdent = "lms"
|
||||||
dbtSQLQuery = lmsTableQuery now qid
|
dbtSQLQuery = lmsTableQuery now qid
|
||||||
@ -465,7 +465,11 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
||||||
, single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
|
, single ("ident" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserIdent))
|
||||||
, single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
|
, single ("pin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserPin))
|
||||||
, single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatus))
|
-- , single ("status" , SortColumnNullsInv $ views (to queryLmsUser) (E.^. LmsUserStatusDay))
|
||||||
|
, single ("status" , SortColumnNeverNull $ \row -> E.coalesceDefault [ queryLmsUser row E.^. LmsUserStatusDay
|
||||||
|
, queryLmsUser row E.^. LmsUserNotified
|
||||||
|
](queryLmsUser row E.^. LmsUserStarted))
|
||||||
|
|
||||||
, single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
|
, single ("started" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserStarted))
|
||||||
, single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
|
, single ("datepin" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserDatePin))
|
||||||
, single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
|
, single ("received" , SortColumnNullsInv $ queryLmsUser >>> (E.^. LmsUserReceived))
|
||||||
@ -501,7 +505,7 @@ mkLmsTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
|
let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
|
||||||
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
|
(E.explicitUnsafeCoerceSqlExprValue "citext" (comp E.^. CompanyName) :: E.SqlExpr (E.Value (CI Text)))
|
||||||
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
|
testnumber nr = E.val nr E.==. comp E.^. CompanyAvsId
|
||||||
testcrit = maybe testname testnumber $ readMay $ CI.original criterion
|
testcrit = maybe testname testnumber $ readMay $ ciOriginal criterion
|
||||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId E.&&. testcrit
|
||||||
)
|
)
|
||||||
@ -632,14 +636,11 @@ postLmsR sid qsh = do
|
|||||||
, colUserNameModalHdr MsgLmsUser AdminUserR
|
, colUserNameModalHdr MsgLmsUser AdminUserR
|
||||||
, colUserEmail
|
, colUserEmail
|
||||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
||||||
let icnSuper = text2markup " " <> icon IconSupervisor
|
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||||
cs = [ (cmpName, cmpSpr)
|
|
||||||
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||||
]
|
]
|
||||||
companies = intercalate (text2markup ", ") $
|
in intercalate spacerCell cs
|
||||||
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
|
|
||||||
in wgtCell companies
|
|
||||||
, colUserMatriclenr
|
, colUserMatriclenr
|
||||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||||
@ -734,10 +735,10 @@ postLmsR sid qsh = do
|
|||||||
, QualificationUserUser <-. usersList
|
, QualificationUserUser <-. usersList
|
||||||
, QualificationUserValidUntil <. cutoff
|
, QualificationUserValidUntil <. cutoff
|
||||||
] []
|
] []
|
||||||
forM_ shortUsers $ upsertQualificationUser qid nowaday cutoff Nothing
|
forM_ shortUsers $ upsertQualificationUser qid now cutoff Nothing "E-Learning Reset"
|
||||||
|
|
||||||
fromIntegral <$> (if isReset
|
fromIntegral <$> (if isReset
|
||||||
then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
|
then updateWhereCount ([LmsUserQualification ==. qid, LmsUserUser <-. usersList, LmsUserResetTries ==. False, LmsUserEnded ==. Nothing] -- , LmsUserLocked ==. True] -- needs to be locked for reset, but this is counter-intuitive for users; should be harmles, but delays reset until lock is effective
|
||||||
++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True]
|
++ ([LmsUserStatus ==. Just LmsBlocked] ||. [LmsUserStatus ==. Just LmsExpired])) [LmsUserResetTries =. True]
|
||||||
else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
|
else deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList]
|
||||||
)
|
)
|
||||||
@ -786,6 +787,7 @@ postLmsR sid qsh = do
|
|||||||
let heading = citext2widget $ "LMS " <> qualificationName quali
|
let heading = citext2widget $ "LMS " <> qualificationName quali
|
||||||
siteLayout heading $ do
|
siteLayout heading $ do
|
||||||
setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh
|
setTitle $ toHtml $ "LMS " <> unSchoolKey sid <> "-" <> qsh
|
||||||
|
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
|
||||||
$(widgetFile "lms")
|
$(widgetFile "lms")
|
||||||
|
|
||||||
-- redirect to a specific lms user
|
-- redirect to a specific lms user
|
||||||
|
|||||||
@ -90,9 +90,8 @@ instance CsvColumnsExplained LmsUserTableCsv where
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> UTCTime -> DB (Any, Widget)
|
||||||
mkUserTable _sid qsh qid = do
|
mkUserTable _sid qsh qid cutoff = do
|
||||||
cutoff <- liftHandler lmsDeletionDate
|
|
||||||
dbtCsvName <- csvFilenameLmsUser qsh
|
dbtCsvName <- csvFilenameLmsUser qsh
|
||||||
let dbtCsvSheetName = dbtCsvName
|
let dbtCsvSheetName = dbtCsvName
|
||||||
let
|
let
|
||||||
@ -158,25 +157,31 @@ mkUserTable _sid qsh qid = do
|
|||||||
& defaultSorting [SortAscBy csvLmsIdent]
|
& defaultSorting [SortAscBy csvLmsIdent]
|
||||||
dbTable userDBTableValidator userDBTable
|
dbTable userDBTableValidator userDBTable
|
||||||
|
|
||||||
|
getQidCutoff :: SchoolId -> QualificationShorthand -> DB (QualificationId, UTCTime)
|
||||||
|
getQidCutoff sid qsh = do
|
||||||
|
Entity{entityKey = qid, entityVal = Qualification{qualificationAuditDuration=auditDur}} <- getBy404 $ SchoolQualificationShort sid qsh
|
||||||
|
cutoff <- liftHandler $ lmsDeletionDate auditDur
|
||||||
|
return (qid, cutoff)
|
||||||
|
|
||||||
getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
|
getLmsLearnersR :: SchoolId -> QualificationShorthand -> Handler Html
|
||||||
getLmsLearnersR sid qsh = do
|
getLmsLearnersR sid qsh = do
|
||||||
lmsTable <- runDB $ do
|
lmsTable <- runDB $ do
|
||||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
(qid, cutoff) <- getQidCutoff sid qsh
|
||||||
view _2 <$> mkUserTable sid qsh qid
|
view _2 <$> mkUserTable sid qsh qid cutoff
|
||||||
siteLayoutMsg MsgMenuLmsLearners $ do
|
siteLayoutMsg MsgMenuLmsLearners $ do
|
||||||
setTitleI MsgMenuLmsLearners
|
setTitleI MsgMenuLmsLearners
|
||||||
lmsTable
|
lmsTable
|
||||||
|
|
||||||
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
getLmsLearnersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
||||||
getLmsLearnersDirectR sid qsh = do
|
getLmsLearnersDirectR sid qsh = do
|
||||||
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
||||||
cutoff <- lmsDeletionDate
|
(lms_users,cutoff) <- runDB $ do
|
||||||
lms_users <- runDB $ do
|
(qid, cutoff) <- getQidCutoff sid qsh
|
||||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
lms_users <- selectList [ LmsUserQualification ==. qid
|
||||||
selectList [ LmsUserQualification ==. qid
|
, LmsUserEnded ==. Nothing
|
||||||
, LmsUserEnded ==. Nothing
|
-- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
|
||||||
-- , LmsUserReceived ==. Nothing ||. LmsUserResetPin ==. True ||. LmsUserStatus !=. Nothing -- send delta only NOTE: know-how no longer expects delta
|
] [Asc LmsUserStarted, Asc LmsUserIdent]
|
||||||
] [Asc LmsUserStarted, Asc LmsUserIdent]
|
return (lms_users, cutoff)
|
||||||
|
|
||||||
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
|
{- To avoid exporting unneeded columns, we would need an SqlSelect instance for LmsUserTableCsv; probably not worth it
|
||||||
Ex.select $ do
|
Ex.select $ do
|
||||||
@ -202,12 +207,12 @@ getLmsLearnersDirectR sid qsh = do
|
|||||||
, csvUseCrLf = lmsDownloadCrLf
|
, csvUseCrLf = lmsDownloadCrLf
|
||||||
}
|
}
|
||||||
csvOpts = def { csvFormat = fmtOpts }
|
csvOpts = def { csvFormat = fmtOpts }
|
||||||
csvSheetName <- csvFilenameLmsUser "t" -- DEBUG UNDO ME BEFORE PRODUCTION qsh
|
csvSheetName <- csvFilenameLmsUser qsh
|
||||||
let nr = length lms_users
|
let nr = length lms_users
|
||||||
msg = "Success. LMS Users download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
|
msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
|
||||||
$logInfoS "LMS" msg
|
$logInfoS "LMS" msg
|
||||||
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
||||||
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
|
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered
|
||||||
|
|
||||||
-- direct Download see:
|
-- direct Download see:
|
||||||
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
|
-- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod
|
||||||
@ -83,7 +83,7 @@ instance CsvColumnsExplained LmsUserTableCsv where
|
|||||||
|
|
||||||
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
mkUserTable :: SchoolId -> QualificationShorthand -> QualificationId -> DB (Any, Widget)
|
||||||
mkUserTable _sid qsh qid = do
|
mkUserTable _sid qsh qid = do
|
||||||
cutoff <- liftHandler lmsDeletionDate
|
cutoff <- liftHandler $ lmsDeletionDate Nothing
|
||||||
dbtCsvName <- csvFilenameLmsUser qsh
|
dbtCsvName <- csvFilenameLmsUser qsh
|
||||||
let dbtCsvSheetName = dbtCsvName
|
let dbtCsvSheetName = dbtCsvName
|
||||||
let
|
let
|
||||||
@ -154,7 +154,7 @@ getLmsUsersR sid qsh = do
|
|||||||
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
getLmsUsersDirectR :: SchoolId -> QualificationShorthand -> Handler TypedContent
|
||||||
getLmsUsersDirectR sid qsh = do
|
getLmsUsersDirectR sid qsh = do
|
||||||
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
$logInfoS "LMS" $ "Direct Download Users for " <> tshow qsh <> " at " <> tshow sid
|
||||||
cutoff <- lmsDeletionDate
|
cutoff <- lmsDeletionDate Nothing
|
||||||
lms_users <- runDB $ do
|
lms_users <- runDB $ do
|
||||||
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
qid <- getKeyBy404 $ SchoolQualificationShort sid qsh
|
||||||
selectList [ LmsUserQualification ==. qid
|
selectList [ LmsUserQualification ==. qid
|
||||||
|
|||||||
@ -30,7 +30,7 @@ import Database.Persist.Sql (updateWhereCount)
|
|||||||
import Database.Esqueleto.Experimental ((:&)(..))
|
import Database.Esqueleto.Experimental ((:&)(..))
|
||||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
||||||
import qualified Database.Esqueleto.Legacy as E
|
import qualified Database.Esqueleto.Legacy as E
|
||||||
import qualified Database.Esqueleto.PostgreSQL as E
|
-- import qualified Database.Esqueleto.PostgreSQL as E
|
||||||
import qualified Database.Esqueleto.Utils as E
|
import qualified Database.Esqueleto.Utils as E
|
||||||
import Database.Esqueleto.Utils.TH
|
import Database.Esqueleto.Utils.TH
|
||||||
|
|
||||||
@ -328,17 +328,17 @@ blockActRemoveSupervisors _ = False
|
|||||||
-- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
|
-- E.where_ $ fltr qualUser E.&&. (E.val qid E.==. qualUser E.^. QualificationUserQualification)
|
||||||
-- return (qualUser, user, lmsUser)
|
-- return (qualUser, user, lmsUser)
|
||||||
|
|
||||||
qualificationTableQuery :: QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
|
qualificationTableQuery :: UTCTime -> QualificationId -> (_ -> E.SqlExpr (E.Value Bool)) -> QualificationTableExpr
|
||||||
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
-> E.SqlQuery ( E.SqlExpr (Entity QualificationUser)
|
||||||
, E.SqlExpr (Entity User)
|
, E.SqlExpr (Entity User)
|
||||||
, E.SqlExpr (Maybe (Entity LmsUser))
|
, E.SqlExpr (Maybe (Entity LmsUser))
|
||||||
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
, E.SqlExpr (Maybe (Entity QualificationUserBlock))
|
||||||
)
|
)
|
||||||
qualificationTableQuery qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
qualificationTableQuery now qid fltr (qualUser `E.InnerJoin` user `E.LeftOuterJoin` lmsUser `E.LeftOuterJoin` qualBlock) = do
|
||||||
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
|
-- E.distinctOnOrderBy will not work: sorting with dbTable should work, except that columns contained in distinctOnOrderBy cannot be sorted inversely by user; but PostgreSQL leftJoin with distinct filters too many results, see SQL Example lead/lag under jost/misc DevOps
|
||||||
--
|
--
|
||||||
E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
|
E.on $ qualBlock E.?. QualificationUserBlockQualificationUser E.?=. qualUser E.^. QualificationUserId
|
||||||
E.&&. qualBlock `isLatestBlockBefore` E.now_
|
E.&&. qualBlock `isLatestBlockBefore` E.val now
|
||||||
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
E.on $ user E.^. UserId E.=?. lmsUser E.?. LmsUserUser
|
||||||
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
|
E.&&. E.val qid E.=?. lmsUser E.?. LmsUserQualification -- NOTE: condition was once erroneously placed in where-clause, which does not work
|
||||||
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
E.on $ user E.^. UserId E.==. qualUser E.^. QualificationUserUser
|
||||||
@ -371,7 +371,7 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
dbtIdent :: Text
|
dbtIdent :: Text
|
||||||
dbtIdent = "qualification"
|
dbtIdent = "qualification"
|
||||||
fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
|
fltrSvs = if isAdmin then const E.true else \quser -> quser E.^. QualificationUserUser `Ex.in_` E.vals svs
|
||||||
dbtSQLQuery = qualificationTableQuery qid fltrSvs
|
dbtSQLQuery = qualificationTableQuery now qid fltrSvs
|
||||||
dbtRowKey = queryUser >>> (E.^. UserId)
|
dbtRowKey = queryUser >>> (E.^. UserId)
|
||||||
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
|
dbtProj = dbtProjSimple $ \(qualUsr, usr, lmsUsr, qUsrBlock) -> do
|
||||||
-- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
-- cmps <- E.select . E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||||
@ -391,9 +391,10 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
|
, single ("last-notified" , SortColumn $ queryQualUser >>> (E.^. QualificationUserLastNotified))
|
||||||
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
, single ("valid-until" , SortColumn $ queryQualUser >>> (E.^. QualificationUserValidUntil))
|
||||||
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
, single ("blocked" , SortColumnNeverNull $ queryQualBlock >>> (E.?. QualificationUserBlockFrom))
|
||||||
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [E.explicitUnsafeCoerceSqlExprValue "timestamp" $ (queryLmsUser row E.?. LmsUserStatus) E.#>>. "{day}"
|
, single ("lms-status-plus",SortColumnNeverNull $ \row -> E.coalesce [ E.joinV (queryLmsUser row E.?. LmsUserStatusDay)
|
||||||
, queryLmsUser row E.?. LmsUserStarted])
|
, E.joinV (queryLmsUser row E.?. LmsUserNotified)
|
||||||
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
, queryLmsUser row E.?. LmsUserStarted])
|
||||||
|
, single ("schedule-renew", SortColumnNullsInv $ queryQualUser >>> (E.^. QualificationUserScheduleRenewal))
|
||||||
, single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
, single ("user-company" , SortColumn $ \row -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
|
||||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. queryUser row E.^. UserId
|
||||||
@ -436,21 +437,23 @@ mkQualificationTable isAdmin (Entity qid quali) acts cols psValidator = do
|
|||||||
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
E.&&. quser E.^. QualificationUserValidUntil E.>=. E.val nowaday
|
||||||
| otherwise -> E.true
|
| otherwise -> E.true
|
||||||
)
|
)
|
||||||
, single ("tobe-notified", FilterColumn $ \(queryQualUser -> quser) criterion ->
|
, single ("tobe-notified", FilterColumn $ \row criterion ->
|
||||||
if | Just True <- getLast criterion -> quser `quserToNotify` now
|
if | Just True <- getLast criterion -> quserToNotify now (queryQualUser row) (queryQualBlock row)
|
||||||
| otherwise -> E.true
|
| otherwise -> E.true
|
||||||
)
|
)
|
||||||
|
, single ("status" , FilterColumn . E.mkExactFilterMaybeLast' (views (to queryLmsUser) (E.?. LmsUserId)) $ views (to queryLmsUser) (E.?. LmsUserStatus))
|
||||||
]
|
]
|
||||||
dbtFilterUI mPrev = mconcat
|
dbtFilterUI mPrev = mconcat
|
||||||
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
[ fltrUserNameEmailHdrUI MsgLmsUser mPrev
|
||||||
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
, prismAForm (singletonFilter "user-company") mPrev $ aopt textField (fslI MsgTableCompany)
|
||||||
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
|
, prismAForm (singletonFilter "personal-number" ) mPrev $ aopt textField (fslI MsgCompanyPersonalNumber)
|
||||||
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
|
, prismAForm (singletonFilter "avs-card" ) mPrev $ aopt textField (fslI MsgAvsCardNo)
|
||||||
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
|
, prismAForm (singletonFilter "avs-number" ) mPrev $ aopt textField (fslI MsgAvsPersonNo)
|
||||||
, 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)
|
||||||
, if isNothing mbRenewal then mempty
|
, if isNothing mbRenewal then mempty
|
||||||
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
else prismAForm (singletonFilter "renewal-due" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsRenewal)
|
||||||
, prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
|
, prismAForm (singletonFilter "tobe-notified" . maybePrism _PathPiece) mPrev $ aopt checkBoxField (fslI MsgFilterLmsNotificationDue)
|
||||||
|
, prismAForm (singletonFilter "status" . maybePrism _PathPiece) mPrev $ aopt (hoistField liftHandler (selectField optionsFinite) :: (Field _ (Maybe LmsStatus))) (fslI MsgTableLmsStatus)
|
||||||
]
|
]
|
||||||
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
||||||
dbtCsvEncode = Just DBTCsvEncode
|
dbtCsvEncode = Just DBTCsvEncode
|
||||||
@ -583,14 +586,11 @@ postQualificationR sid qsh = do
|
|||||||
, colUserNameModalHdr MsgLmsUser linkUserName
|
, colUserNameModalHdr MsgLmsUser linkUserName
|
||||||
, colUserEmail
|
, colUserEmail
|
||||||
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
, sortable (Just "user-company") (i18nCell MsgTableCompanies) $ \( view resultCompanyUser -> cmps) ->
|
||||||
let icnSuper = text2markup " " <> icon IconSupervisor
|
let cs = [ companyCell (unCompanyKey cmpId) cmpName cmpSpr
|
||||||
cs = [ (cmpName, cmpSpr)
|
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
||||||
| Entity _ UserCompany{userCompanyCompany=cmpId, userCompanySupervisor=cmpSpr} <- cmps
|
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
||||||
, let cmpName = maybe (unCompanyKey cmpId) companyName $ Map.lookup cmpId cmpMap
|
|
||||||
]
|
]
|
||||||
companies = intercalate (text2markup ", ") $
|
in intercalate spacerCell cs
|
||||||
(\(cmpName, cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> cs
|
|
||||||
in wgtCell companies
|
|
||||||
, guardMonoid isAdmin colUserMatriclenr
|
, guardMonoid isAdmin colUserMatriclenr
|
||||||
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
-- , sortable (Just "validity") (i18nCell MsgQualificationValidIndicator) (qualificationValidIconCell nowaday . view resultQualUser)
|
||||||
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
, sortable (Just "first-held") (i18nCell MsgTableQualificationFirstHeld) $ \( view $ resultQualUser . _entityVal . _qualificationUserFirstHeld -> d) -> dayCell d
|
||||||
@ -614,14 +614,20 @@ postQualificationR sid qsh = do
|
|||||||
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
|
||||||
reloadKeepGetParams $ QualificationR sid qsh
|
reloadKeepGetParams $ QualificationR sid qsh
|
||||||
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
(QualificationActGrantData grantValidday, selectedUsers) | isAdmin -> do
|
||||||
runDB . forM_ selectedUsers $ upsertQualificationUser qid nowaday grantValidday Nothing
|
runDB . forM_ selectedUsers $ upsertQualificationUser qid now grantValidday Nothing "Admin"
|
||||||
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
||||||
reloadKeepGetParams $ QualificationR sid qsh
|
reloadKeepGetParams $ QualificationR sid qsh
|
||||||
(action, selectedUsers) | isExpiryAct action -> do
|
(action, selectedUsers) | isExpiryAct action -> do
|
||||||
let isUnexpire = action == QualificationActUnexpireData
|
let isUnexpire = action == QualificationActUnexpireData
|
||||||
upd <- runDB $ updateWhereCount
|
upd <- runDB $ do
|
||||||
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
|
forM_ selectedUsers $ \uid -> audit TransactionQualificationUserScheduleRenewal
|
||||||
[QualificationUserScheduleRenewal =. isUnexpire]
|
{ transactionUser = uid
|
||||||
|
, transactionQualification = qid
|
||||||
|
, transactionQualificationScheduleRenewal = Just isUnexpire
|
||||||
|
}
|
||||||
|
updateWhereCount
|
||||||
|
[QualificationUserQualification ==. qid, QualificationUserUser <-. Set.toList selectedUsers]
|
||||||
|
[QualificationUserScheduleRenewal =. isUnexpire]
|
||||||
let msgKind = if upd > 0 then Success else Warning
|
let msgKind = if upd > 0 then Success else Warning
|
||||||
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
|
msgVal = upd & if isUnexpire then MsgQualificationSetUnexpire else MsgQualificationSetExpire
|
||||||
addMessageI msgKind msgVal
|
addMessageI msgKind msgVal
|
||||||
|
|||||||
@ -6,6 +6,7 @@
|
|||||||
|
|
||||||
module Handler.SAP
|
module Handler.SAP
|
||||||
( getQualificationSAPDirectR
|
( getQualificationSAPDirectR
|
||||||
|
, compileBlocks -- for Test in Handler.SAPSpec only
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@ -18,8 +19,9 @@ import Handler.Utils.Profile
|
|||||||
-- import qualified Data.CaseInsensitive as CI
|
-- import qualified Data.CaseInsensitive as CI
|
||||||
import qualified Data.Csv as Csv
|
import qualified Data.Csv as Csv
|
||||||
import Database.Esqueleto.Experimental ((:&)(..))
|
import Database.Esqueleto.Experimental ((:&)(..))
|
||||||
import qualified Database.Esqueleto.Experimental as Ex -- needs TypeApplications Lang-Pragma
|
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
|
||||||
-- import qualified Database.Esqueleto.Legacy as E
|
-- import qualified Database.Esqueleto.Legacy as E
|
||||||
|
import qualified Database.Esqueleto.PostgreSQL as E
|
||||||
import qualified Database.Esqueleto.Utils as E
|
import qualified Database.Esqueleto.Utils as E
|
||||||
|
|
||||||
|
|
||||||
@ -55,22 +57,39 @@ instance ToNamedRecord SapUserTableCsv where
|
|||||||
]
|
]
|
||||||
|
|
||||||
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
|
-- | Removes all personalNummer which are not numbers between 10000 and 99999 (also excludes E-Accounts), which should not be returned by the query anyway (only qualfications with sap id and users with internal personnel number must be transmitted)
|
||||||
-- TODO: once temporary suspensions are implemented, a user must be transmitted to SAP in two rows: firstheld->suspensionFrom & suspensionTo->validTo
|
-- temporary suspensions are transmitted to SAP in multiple rows: firstheld->suspension1, reinstate1->suspension2, reinstate2->validTo
|
||||||
sapRes2csv :: [(Ex.Value (Maybe Text), Ex.Value Day, Ex.Value Day, Ex.Value (Maybe Text))] -> [SapUserTableCsv]
|
sapRes2csv :: [(E.Value (Maybe Text), E.Value (Maybe Text), E.Value Day, E.Value Day, E.Value (Maybe [Maybe Day]), E.Value (Maybe [Maybe Bool]))] -> [SapUserTableCsv]
|
||||||
sapRes2csv l = [ res | (Ex.Value pn@(Just persNo), Ex.Value firstHeld, Ex.Value validUntil, Ex.Value (Just sapId)) <- l
|
sapRes2csv = concatMap procRes
|
||||||
-- , let persNoAsInt = readMay =<< persNo -- also see Handler.Utils.Profile.validFraportPersonalNumber
|
where
|
||||||
-- , persNoAsInt >= Just (10000::Int) -- filter E-accounts for SAP export
|
procRes (E.Value pn@(Just persNo), E.Value (Just sapId), E.Value firstHeld, E.Value validUntil, E.Value (fromMaybe [] -> qubFroms), E.Value (fromMaybe [] -> qubUnblocks))
|
||||||
-- , persNoAsInt <= Just (99999::Int) -- filter E-accounts for SAP export
|
| validFraportPersonalNumber pn -- between 10000 and 99999 also see Handler.Utils.Profile.validFraportPersonalNumber
|
||||||
, let res = SapUserTableCsv
|
= let mkSap (dfrom,duntil) = SapUserTableCsv
|
||||||
{ csvSUTpersonalNummer = persNo
|
{ csvSUTpersonalNummer = persNo
|
||||||
, csvSUTqualifikation = sapId
|
, csvSUTqualifikation = sapId
|
||||||
, csvSUTgültigVon = firstHeld
|
, csvSUTgültigVon = dfrom
|
||||||
, csvSUTgültigBis = validUntil
|
, csvSUTgültigBis = duntil
|
||||||
-- , csvSUTsupendiertBis = blocked
|
, csvSUTausprägung = "J"
|
||||||
, csvSUTausprägung = "J"
|
}
|
||||||
}
|
in fmap mkSap $ compileBlocks firstHeld validUntil $ zipMaybes qubFroms qubUnblocks
|
||||||
, validFraportPersonalNumber pn
|
procRes _ = []
|
||||||
]
|
|
||||||
|
-- | compute a series of valid periods, assume that lists is already sorted by Day
|
||||||
|
-- the lists encodes qualification_user_blocks with block=False/unblock=True
|
||||||
|
compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
|
||||||
|
compileBlocks dStart dEnd = go (dStart, True)
|
||||||
|
where
|
||||||
|
go :: (Day,Bool) -> [(Day,Bool)] -> [(Day, Day)]
|
||||||
|
go (d,s) (p1@(d1,s1):r1@((d2,s2):r2))
|
||||||
|
| s1 == s2 && d <= d1 = go (d,s) (p1:r2) -- ignore unnecessary 2nd change
|
||||||
|
| d1 == d2 || succ d1 == d2 || s == s1 || d > d1 = go (d,s) r1 -- ignore unnecessary 1st change
|
||||||
|
go (d,s) ((d1,s1):r1)
|
||||||
|
| dEnd <= d1 = go (d ,s ) [] -- remaining dates extend validity
|
||||||
|
| s, not s1, d < d1 = (d,d1) : go (d1,s1) r1 -- valid interval found
|
||||||
|
| s == s1 = go (d ,s ) r1 -- no change
|
||||||
|
| otherwise = go (d1,s1) r1 -- ignore invalid interval
|
||||||
|
go (d,s) []
|
||||||
|
| s = [(d,dEnd)]
|
||||||
|
| otherwise = []
|
||||||
|
|
||||||
-- | Deliver all employess with a successful LDAP synch within the last 3 months
|
-- | Deliver all employess with a successful LDAP synch within the last 3 months
|
||||||
getQualificationSAPDirectR :: Handler TypedContent
|
getQualificationSAPDirectR :: Handler TypedContent
|
||||||
@ -78,23 +97,36 @@ getQualificationSAPDirectR = do
|
|||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
fdate <- formatTime' "%Y%m%d_%H-%M" now
|
fdate <- formatTime' "%Y%m%d_%H-%M" now
|
||||||
let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
|
let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
|
||||||
qualUsers <- runDB $ Ex.select $ do
|
qualUsers <- runDB $ E.select $ do
|
||||||
(qual :& qualUser :& user) <-
|
(qual :& qualUser :& user :& qualBlock) <-
|
||||||
Ex.from $ Ex.table @Qualification
|
E.from $ E.table @Qualification
|
||||||
`Ex.innerJoin` Ex.table @QualificationUser
|
`E.innerJoin` E.table @QualificationUser
|
||||||
`Ex.on` (\(qual :& qualUser) -> qual Ex.^. QualificationId Ex.==. qualUser Ex.^. QualificationUserQualification)
|
`E.on` (\(qual :& qualUser) -> qual E.^. QualificationId E.==. qualUser E.^. QualificationUserQualification)
|
||||||
`Ex.innerJoin` Ex.table @User
|
`E.innerJoin` E.table @User
|
||||||
`Ex.on` (\(_ :& qualUser :& user) -> qualUser Ex.^. QualificationUserUser Ex.==. user Ex.^. UserId)
|
`E.on` (\(_ :& qualUser :& user) -> qualUser E.^. QualificationUserUser E.==. user E.^. UserId)
|
||||||
Ex.where_ $ E.isJust (qual Ex.^. QualificationSapId)
|
`E.leftJoin` E.table @QualificationUserBlock
|
||||||
Ex.&&. E.isJust (user Ex.^. UserCompanyPersonalNumber)
|
`E.on` (\(_ :& qualUser :& _ :& qualBlock) ->
|
||||||
Ex.&&. E.isJust (user Ex.^. UserLastLdapSynchronisation)
|
qualUser E.^. QualificationUserId E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
||||||
Ex.&&. (E.justVal ldap_cutoff Ex.<=. user Ex.^. UserLastLdapSynchronisation)
|
E.&&. E.val now E.>~. qualBlock E.?. QualificationUserBlockFrom
|
||||||
|
)
|
||||||
|
E.where_ $ E.isJust (qual E.^. QualificationSapId)
|
||||||
|
E.&&. E.isJust (user E.^. UserCompanyPersonalNumber)
|
||||||
|
E.&&. E.isJust (user E.^. UserLastLdapSynchronisation)
|
||||||
|
E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
|
||||||
|
E.groupBy ( user E.^. UserCompanyPersonalNumber
|
||||||
|
, qualUser E.^. QualificationUserFirstHeld
|
||||||
|
, qualUser E.^. QualificationUserValidUntil
|
||||||
|
, qual E.^. QualificationSapId
|
||||||
|
)
|
||||||
|
let blockOrder = [E.asc $ qualBlock E.?. QualificationUserBlockFrom, E.asc $ qualBlock E.?. QualificationUserBlockId]
|
||||||
|
-- blockAgg f = E.arrayAggWith E.AggModeAll (qualBlock E.^. f) blockOrder
|
||||||
return
|
return
|
||||||
( user Ex.^. UserCompanyPersonalNumber
|
( user E.^. UserCompanyPersonalNumber
|
||||||
, qualUser Ex.^. QualificationUserFirstHeld
|
, qual E.^. QualificationSapId
|
||||||
, qualUser Ex.^. QualificationUserValidUntil
|
, qualUser E.^. QualificationUserFirstHeld
|
||||||
-- , qualUser Ex.^. QualificationUserBlockedDue
|
, qualUser E.^. QualificationUserValidUntil
|
||||||
, qual Ex.^. QualificationSapId
|
, E.arrayAggWith E.AggModeAll (E.dayMaybe $ qualBlock E.?. QualificationUserBlockFrom ) blockOrder
|
||||||
|
, E.arrayAggWith E.AggModeAll ( qualBlock E.?. QualificationUserBlockUnblock) blockOrder
|
||||||
)
|
)
|
||||||
let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
|
let csvRendered = toCsvRendered sapUserTableCsvHeader $ sapRes2csv qualUsers
|
||||||
fmtOpts = (review csvPreset CsvPresetRFC)
|
fmtOpts = (review csvPreset CsvPresetRFC)
|
||||||
|
|||||||
@ -139,8 +139,9 @@ postTUsersR tid ssh csh tutn = do
|
|||||||
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
(TutorialUserGrantQualificationData{..}, selectedUsers)
|
||||||
| tuQualification `Set.member` courseQids -> do
|
| tuQualification `Set.member` courseQids -> do
|
||||||
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
-- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
|
||||||
today <- utctDay <$> liftIO getCurrentTime
|
today <- liftIO getCurrentTime
|
||||||
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing
|
let reason = "Kurs " <> CI.original (unSchoolKey ssh) <> "-" <> CI.original csh <> "-" <> CI.original tutn
|
||||||
|
runDB . forM_ selectedUsers $ upsertQualificationUser tuQualification today tuValidUntil Nothing reason
|
||||||
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
addMessageI (if 0 < Set.size selectedUsers then Success else Warning) . MsgTutorialUserGrantedQualification $ Set.size selectedUsers
|
||||||
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
redirect $ CTutorialR tid ssh csh tutn TUsersR
|
||||||
(TutorialUserRenewQualificationData{..}, selectedUsers)
|
(TutorialUserRenewQualificationData{..}, selectedUsers)
|
||||||
|
|||||||
@ -106,11 +106,11 @@ postUsersR = do
|
|||||||
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
|
||||||
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
E.where_ $ usrComp E.^. UserCompanyUser E.==. E.val uid
|
||||||
E.orderBy [E.asc (comp E.^. CompanyName)]
|
E.orderBy [E.asc (comp E.^. CompanyName)]
|
||||||
return (comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
return (comp E.^. CompanyShorthand, comp E.^. CompanyName, usrComp E.^. UserCompanySupervisor)
|
||||||
let companies = intersperse (text2markup ", ") $
|
let icnSuper = toWidget $ text2markup " " <> icon IconSupervisor
|
||||||
(\(E.Value cmpName, E.Value cmpSpr) -> text2markup (CI.original cmpName) <> bool mempty icnSuper cmpSpr) <$> companies'
|
companies =
|
||||||
icnSuper = text2markup " " <> icon IconSupervisor
|
(\(E.Value cmpSh, E.Value cmpName, E.Value cmpSpr) -> simpleLink (citext2widget cmpName) (FirmR cmpSh) <> bool mempty icnSuper cmpSpr) <$> companies'
|
||||||
pure $ toWgt $ mconcat companies
|
pure $ intercalate (text2widget "; ") companies
|
||||||
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
, sortable (Just "personal-number") (i18nCell MsgCompanyPersonalNumber) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
|
||||||
(AdminUserR <$> encrypt uid)
|
(AdminUserR <$> encrypt uid)
|
||||||
(toWgt userCompanyPersonalNumber)
|
(toWgt userCompanyPersonalNumber)
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||||
--
|
--
|
||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
|||||||
@ -39,6 +39,7 @@ import Import
|
|||||||
import Handler.Utils.DateTime
|
import Handler.Utils.DateTime
|
||||||
import Handler.Utils.Csv
|
import Handler.Utils.Csv
|
||||||
import Data.Csv (HasHeader(..), FromRecord)
|
import Data.Csv (HasHeader(..), FromRecord)
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
import qualified Data.Set as Set (notMember)
|
import qualified Data.Set as Set (notMember)
|
||||||
import qualified Database.Esqueleto.Legacy as E
|
import qualified Database.Esqueleto.Legacy as E
|
||||||
@ -130,11 +131,16 @@ makeLmsFilename ftag (citext2lower -> qsh) = do
|
|||||||
getYMTH :: MonadHandler m => m Text
|
getYMTH :: MonadHandler m => m Text
|
||||||
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
|
getYMTH = formatTime' "%Y%m%d%H" =<< liftIO getCurrentTime
|
||||||
|
|
||||||
--
|
-- | Given the QualificationAuditDuration, determines the time to signal the deletion of an LMS User to the e-learning server. Note that the e-learning server ought to delete LMS users on its own
|
||||||
lmsDeletionDate :: Handler UTCTime
|
lmsDeletionDate :: Maybe Int -> Handler UTCTime
|
||||||
lmsDeletionDate = do
|
lmsDeletionDate mbMaxAuditMonths = do
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
|
LmsConf{lmsDeletionDays} <- getsYesod $ view _appLmsConf
|
||||||
addLocalDays (fromIntegral $ negate lmsDeletionDays) <$> liftIO getCurrentTime
|
let ldd = addDiffDaysRollOver (fromDays $ negate lmsDeletionDays) now
|
||||||
|
return $ case mbMaxAuditMonths of
|
||||||
|
Nothing -> ldd
|
||||||
|
(Just maxAuditMonths) ->
|
||||||
|
max ldd (addDiffDaysRollOver (fromMonths $ negate maxAuditMonths) now)
|
||||||
|
|
||||||
-- | Decide whether LMS platform should delete an identifier
|
-- | Decide whether LMS platform should delete an identifier
|
||||||
lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
|
lmsUserToDeleteExpr :: UTCTime -> E.SqlExpr (Entity LmsUser) -> E.SqlExpr (E.Value Bool)
|
||||||
@ -196,7 +202,7 @@ maxLmsUserIdentRetries = 27
|
|||||||
randomText :: MonadIO m => String -> Int -> m Text
|
randomText :: MonadIO m => String -> Int -> m Text
|
||||||
randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
|
randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
|
||||||
where
|
where
|
||||||
num_letters = ['2'..'9'] ++ ['a'..'h'] ++ ['j','k'] ++ ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j
|
num_letters = ['2'..'9'] ++ ['a'..'h'] ++ 'k' : ['m'..'z'] -- users have trouble distinguishing 1/l and 0/O so we eliminate these; apc has trouble distinguishing i/j and read "ji", "jf" as ligatures "ij", "fj" so we eliminate j as well
|
||||||
range = extra ++ num_letters
|
range = extra ++ num_letters
|
||||||
|
|
||||||
--TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though
|
--TODO: consider using package elocrypt for user-friendly passwords here, licence requires mentioning of author, etc. though
|
||||||
@ -206,14 +212,15 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
|
|||||||
-- where
|
-- where
|
||||||
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
|
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
|
||||||
|
|
||||||
randomLMSIdent :: MonadIO m => m LmsIdent
|
randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent
|
||||||
randomLMSIdent = LmsIdent <$> randomText [] lengthIdent -- idents must not contain '_' nor '-'
|
randomLMSIdent Nothing = LmsIdent . Text.cons 'j' <$> randomText [] (pred lengthIdent) -- idents must not contain '_' nor '-'
|
||||||
|
randomLMSIdent (Just c) = LmsIdent . Text.cons c <$> randomText [] (pred lengthIdent)
|
||||||
|
|
||||||
randomLMSIdentBut :: MonadIO m => Set LmsIdent -> m (Maybe LmsIdent)
|
randomLMSIdentBut :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent)
|
||||||
randomLMSIdentBut banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
|
randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
|
||||||
where
|
where
|
||||||
getIdentOk = do
|
getIdentOk = do
|
||||||
l <- randomLMSIdent
|
l <- randomLMSIdent prefix
|
||||||
return $ toMaybe (Set.notMember l banList) l
|
return $ toMaybe (Set.notMember l banList) l
|
||||||
|
|
||||||
randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_'
|
randomLMSpw :: MonadIO m => m Text -- may contain all kinds of symbols, but our users had trouble with some, like ',' '.' ':' '_'
|
||||||
@ -255,23 +262,20 @@ lmsStatusIcon LmsSuccess{} = IconOK
|
|||||||
lmsStatusIcon LmsExpired{} = IconExpired
|
lmsStatusIcon LmsExpired{} = IconExpired
|
||||||
lmsStatusIcon _other = IconNotOK
|
lmsStatusIcon _other = IconNotOK
|
||||||
|
|
||||||
lmsUserStatusWidget :: Bool -> LmsUser -> Widget
|
lmsUserStatusWidget :: Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> Widget
|
||||||
lmsUserStatusWidget adminInfo luser = case luser of
|
lmsUserStatusWidget adminInfo mbLink luser = case luser of
|
||||||
LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} ->
|
LmsUser{lmsUserStatus=Just lStat, lmsUserStatusDay=mbDay} ->
|
||||||
[whamlet|$newline never
|
[whamlet|$newline never
|
||||||
$maybe aday <- mbDay
|
^{dateWgt mbDay}
|
||||||
^{formatTimeW SelFormatDateTime aday}
|
|
||||||
$nothing
|
|
||||||
--.--.----
|
|
||||||
\ ^{iconFixed (lmsStatusIcon lStat)}
|
\ ^{iconFixed (lmsStatusIcon lStat)}
|
||||||
$if adminInfo
|
$if adminInfo
|
||||||
\ ^{lockIcon}
|
\ ^{lockIcon}
|
||||||
\ ^{resetIcon}
|
\ ^{resetIcon}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
LmsUser{lmsUserNotified=Just d} ->
|
LmsUser{lmsUserNotified=mbDay@(Just _)} ->
|
||||||
[whamlet|$newline never
|
[whamlet|$newline never
|
||||||
^{formatTimeW SelFormatDateTime d}
|
^{dateWgt mbDay}
|
||||||
\ ^{iconFixed IconNotificationSent}
|
\ ^{iconFixed IconNotificationSent}
|
||||||
$if adminInfo
|
$if adminInfo
|
||||||
\ ^{lockIcon}
|
\ ^{lockIcon}
|
||||||
@ -280,7 +284,7 @@ lmsUserStatusWidget adminInfo luser = case luser of
|
|||||||
|
|
||||||
LmsUser{lmsUserStarted=dstart} | adminInfo -> -- E-Learning started, but not yet notified; only intended for Admins;
|
LmsUser{lmsUserStarted=dstart} | adminInfo -> -- E-Learning started, but not yet notified; only intended for Admins;
|
||||||
[whamlet|$newline never
|
[whamlet|$newline never
|
||||||
^{formatTimeW SelFormatDateTime dstart}
|
^{dateWgt (Just dstart)}
|
||||||
\ ^{iconFixed IconPlanned}
|
\ ^{iconFixed IconPlanned}
|
||||||
$if adminInfo
|
$if adminInfo
|
||||||
\ ^{resetIcon}
|
\ ^{resetIcon}
|
||||||
@ -297,3 +301,12 @@ lmsUserStatusWidget adminInfo luser = case luser of
|
|||||||
resetIcon
|
resetIcon
|
||||||
| lmsUserResetTries luser = iconFixed IconResetTries
|
| lmsUserResetTries luser = iconFixed IconResetTries
|
||||||
| otherwise = mempty
|
| otherwise = mempty
|
||||||
|
|
||||||
|
dateWgt :: Maybe UTCTime -> Widget
|
||||||
|
dateWgt =
|
||||||
|
let mkDayWgt = maybe (text2widget "--.--.----") (formatTimeW SelFormatDateTime)
|
||||||
|
in case mbLink of
|
||||||
|
Nothing -> mkDayWgt
|
||||||
|
(Just mkLink) -> \mbDay -> do
|
||||||
|
uuid <- liftHandler $ encrypt $ luser ^. _lmsUserUser
|
||||||
|
modal (mkDayWgt mbDay) $ Left $ SomeRoute $ mkLink uuid
|
||||||
|
|||||||
@ -41,47 +41,32 @@ isValidQualification d qu qb= d `inBetween` (qu ^. hasQualificationUser . _quali
|
|||||||
-- SQL Snippets --
|
-- SQL Snippets --
|
||||||
------------------
|
------------------
|
||||||
|
|
||||||
-- | Recently became invalid or blocked and not yet notified
|
-- | Recently became invalid or blocked and not yet notified; assumes that second argument is latest active block (if exists), also checks validity with respect to given timestamp
|
||||||
quserToNotify :: E.SqlExpr (Entity QualificationUser) -> UTCTime -> E.SqlExpr (E.Value Bool)
|
quserToNotify :: UTCTime -> E.SqlExpr (Entity QualificationUser) -> E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value Bool)
|
||||||
quserToNotify quser cutoff = -- recently invalid or...
|
quserToNotify cutoff quser qblock = -- either recently become invalid with no prior block or recently blocked
|
||||||
( E.day (quser E.^. QualificationUserLastNotified) E.<. quser E.^. QualificationUserValidUntil
|
-- has expired without being blocked
|
||||||
E.&&. E.notExists (do
|
quser E.^. QualificationUserScheduleRenewal
|
||||||
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
E.&&. (( quser E.^. QualificationUserValidUntil E.<. E.val (utctDay cutoff)
|
||||||
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock)
|
E.&&. quser E.^. QualificationUserValidUntil E.>. E.day (quser E.^. QualificationUserLastNotified)
|
||||||
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified
|
E.&&. E.not_ (E.isFalse (qblock E.?. QualificationUserBlockUnblock)) -- not currently blocked
|
||||||
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
) E.||. ( -- was recently blocked
|
||||||
E.&&. E.notExists (do -- block is the most recent block
|
E.isFalse (qblock E.?. QualificationUserBlockUnblock)
|
||||||
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
|
E.&&. qblock E.?. QualificationUserBlockFrom E.>. E.just (quser E.^. QualificationUserLastNotified)
|
||||||
E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock)
|
))
|
||||||
qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
|
|
||||||
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
|
||||||
)
|
|
||||||
)
|
|
||||||
) E.||. E.exists (do -- ...recently blocked
|
|
||||||
qualUserBlock <- E.from $ E.table @QualificationUserBlock
|
|
||||||
E.where_ $ E.not_ (qualUserBlock E.^. QualificationUserBlockUnblock) -- block is not an unblock
|
|
||||||
E.&&. E.day (qualUserBlock E.^. QualificationUserBlockFrom) E.<. quser E.^. QualificationUserValidUntil -- block was essential during validity
|
|
||||||
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.>. quser E.^. QualificationUserLastNotified -- block has not yet been communicated
|
|
||||||
E.&&. qualUserBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff -- block is already active
|
|
||||||
E.&&. E.notExists (do -- block is the most recent block
|
|
||||||
qualUserLaterBlock <- E.from $ E.table @QualificationUserBlock
|
|
||||||
E.where_ $ -- ((E.>.) `on` (E.^. QualificationUserBlockFrom) qualUserLaterBlock qualUserBlock))
|
|
||||||
qualUserLaterBlock E.^. QualificationUserBlockFrom E.>. qualUserBlock E.^. QualificationUserBlockFrom
|
|
||||||
E.&&. qualUserLaterBlock E.^. QualificationUserBlockFrom E.<=. E.val cutoff
|
|
||||||
)
|
|
||||||
)
|
|
||||||
|
|
||||||
-- condition to ensure that the lastes QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
-- condition to ensure that the lastest QualificationUserBlock was picked, better to be used in join-on clauses, since inside a where-clause it might not work as intended
|
||||||
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
|
isLatestBlockBefore :: E.SqlExpr (Maybe (Entity QualificationUserBlock)) -> E.SqlExpr (E.Value UTCTime) -> E.SqlExpr (E.Value Bool)
|
||||||
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
|
isLatestBlockBefore qualBlock cutoff = (cutoff E.>~. qualBlock E.?. QualificationUserBlockFrom) E.&&. E.notExists (do
|
||||||
newerBlock <- E.from $ E.table @QualificationUserBlock
|
newerBlock <- E.from $ E.table @QualificationUserBlock
|
||||||
E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
E.where_ $ newerBlock E.^. QualificationUserBlockQualificationUser E.=?. qualBlock E.?. QualificationUserBlockQualificationUser
|
||||||
E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
|
E.&&. newerBlock E.^. QualificationUserBlockFrom E.<=. cutoff
|
||||||
|
E.&&. E.just(newerBlock E.^. QualificationUserBlockId) E.!=. qualBlock E.?. QualificationUserBlockId
|
||||||
E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom)
|
E.&&. ((E.just(newerBlock E.^. QualificationUserBlockFrom) E.>. qualBlock E.?. QualificationUserBlockFrom)
|
||||||
E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins
|
E.||. ( newerBlock E.^. QualificationUserBlockUnblock -- in case of equal timestamps, any unblock wins
|
||||||
E.&&. (newerBlock E.^. QualificationUserBlockFrom E.=?. qualBlock E.?. QualificationUserBlockFrom)
|
E.&&. (newerBlock E.^. QualificationUserBlockFrom E.=?. qualBlock E.?. QualificationUserBlockFrom)
|
||||||
))
|
))
|
||||||
)
|
)
|
||||||
|
|
||||||
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
|
-- cutoff can be `E.val now` or even `Database.Esqueleto.PostgreSQL.now_`
|
||||||
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
quserBlockAux :: Bool -> E.SqlExpr (E.Value UTCTime) -> (E.SqlExpr (E.Value QualificationUserId) -> E.SqlExpr (E.Value Bool)) -> Maybe (E.SqlExpr (Entity QualificationUserBlock) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
|
||||||
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
quserBlockAux negCond cutoff checkQualUserId mbBlockCondition = bool E.notExists E.exists negCond $ do
|
||||||
@ -148,8 +133,9 @@ selectRelevantBlock cutoff quid =
|
|||||||
------------------------
|
------------------------
|
||||||
|
|
||||||
|
|
||||||
upsertQualificationUser :: QualificationId -> Day -> Day -> Maybe Bool -> UserId -> DB () -- ignores blocking
|
upsertQualificationUser :: QualificationId -> UTCTime -> Day -> Maybe Bool -> Text -> UserId -> DB () -- ignores blocking
|
||||||
upsertQualificationUser qualificationUserQualification qualificationUserLastRefresh qualificationUserValidUntil mbScheduleRenewal qualificationUserUser = do
|
upsertQualificationUser qualificationUserQualification startTime qualificationUserValidUntil mbScheduleRenewal reason qualificationUserUser = do
|
||||||
|
let qualificationUserLastRefresh = utctDay startTime
|
||||||
Entity quid _ <- upsert
|
Entity quid _ <- upsert
|
||||||
QualificationUser
|
QualificationUser
|
||||||
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
{ qualificationUserFirstHeld = qualificationUserLastRefresh
|
||||||
@ -164,7 +150,8 @@ upsertQualificationUser qualificationUserQualification qualificationUserLastRef
|
|||||||
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
, QualificationUserLastRefresh =. qualificationUserLastRefresh
|
||||||
]
|
]
|
||||||
)
|
)
|
||||||
|
authUsr <- liftHandler maybeAuthId
|
||||||
|
insert_ $ QualificationUserBlock quid True startTime reason authUsr
|
||||||
audit TransactionQualificationUserEdit
|
audit TransactionQualificationUserEdit
|
||||||
{ transactionQualificationUser = quid
|
{ transactionQualificationUser = quid
|
||||||
, transactionQualification = qualificationUserQualification
|
, transactionQualification = qualificationUserQualification
|
||||||
@ -198,8 +185,8 @@ renewValidQualificationUsers qid renewalTime uids =
|
|||||||
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
|
Just Qualification{qualificationValidDuration=Just renewalMonths} -> do
|
||||||
cutoff <- maybe (liftIO getCurrentTime) return renewalTime
|
cutoff <- maybe (liftIO getCurrentTime) return renewalTime
|
||||||
quEntsAll <- selectValidQualifications qid uids cutoff
|
quEntsAll <- selectValidQualifications qid uids cutoff
|
||||||
let cutoffday = utctDay cutoff
|
let cutoffday = utctDay cutoff
|
||||||
maxValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) cutoffday
|
maxValidTo = addGregorianMonthsRollOver (toInteger $ renewalMonths `div` 2) cutoffday
|
||||||
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
|
quEnts = filter (\q -> maxValidTo >= (q ^. _entityVal . _qualificationUserValidUntil)) quEntsAll
|
||||||
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
|
forM_ quEnts $ \(Entity quId QualificationUser{..}) -> do
|
||||||
let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
|
let newValidTo = addGregorianMonthsRollOver (toInteger renewalMonths) qualificationUserValidUntil
|
||||||
@ -216,7 +203,7 @@ renewValidQualificationUsers qid renewalTime uids =
|
|||||||
return $ length quEnts
|
return $ length quEnts
|
||||||
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
|
_ -> return (-1) -- qualificationId not found, isNothing qualificationValidDuration, etc.
|
||||||
|
|
||||||
-- | Block or unblock some users for a given reason
|
-- | Block or unblock some users for a given reason, but only if they are not already blocked (essential assumption that is actually used)
|
||||||
qualificationUserBlocking ::
|
qualificationUserBlocking ::
|
||||||
( AuthId (HandlerSite m) ~ Key User
|
( AuthId (HandlerSite m) ~ Key User
|
||||||
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
, IsPersistBackend (YesodPersistBackend (HandlerSite m))
|
||||||
@ -261,7 +248,7 @@ qualificationUserBlocking qid uids unblock mbBlockTime (qualificationBlockReason
|
|||||||
, qualificationUserBlockBlocker = authUsr
|
, qualificationUserBlockBlocker = authUsr
|
||||||
})) toChange
|
})) toChange
|
||||||
E.insertMany_ (snd <$> newBlocks)
|
E.insertMany_ (snd <$> newBlocks)
|
||||||
unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. now]
|
unless notify $ updateWhere [QualificationUserId <-. (qualificationUserBlockQualificationUser . snd <$> newBlocks)] [QualificationUserLastNotified =. addUTCTime 1 blockTime]
|
||||||
forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking
|
forM_ newBlocks $ \(uid, qub) -> audit TransactionQualificationUserBlocking
|
||||||
{ transactionQualification = qid
|
{ transactionQualification = qid
|
||||||
, transactionUser = uid
|
, transactionUser = uid
|
||||||
|
|||||||
@ -307,6 +307,16 @@ courseCell Course{..} = anchorCell link name `mappend` desc
|
|||||||
^{modal "Beschreibung" (Right $ toWidget descr)}
|
^{modal "Beschreibung" (Right $ toWidget descr)}
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
companyCell :: IsDBTable m a => CompanyShorthand -> CompanyName -> Bool -> DBCell m a
|
||||||
|
companyCell cid cname isSupervisor = anchorCell link name
|
||||||
|
where
|
||||||
|
link = FirmR cid
|
||||||
|
corg = ciOriginal cname
|
||||||
|
name
|
||||||
|
| isSupervisor = text2markup (corg <> " ") <> icon IconSupervisor
|
||||||
|
| otherwise = text2markup corg
|
||||||
|
|
||||||
|
|
||||||
qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
|
qualificationCell :: (IsDBTable m c, HasQualification a) => a -> DBCell m c
|
||||||
qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
|
qualificationCell (view hasQualification -> Qualification{..}) = anchorCell link name
|
||||||
where
|
where
|
||||||
@ -426,10 +436,7 @@ cryptoidCell :: (IsDBTable m a, PathPiece cid) => cid -> DBCell m a
|
|||||||
cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece
|
cryptoidCell = addCellClass ("cryptoid" :: Text) . textCell . toPathPiece
|
||||||
|
|
||||||
lmsStatusCell :: IsDBTable m a => Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a
|
lmsStatusCell :: IsDBTable m a => Bool -> Maybe (CryptoUUIDUser -> Route UniWorX) -> LmsUser -> DBCell m a
|
||||||
lmsStatusCell extendedInfo Nothing lu = wgtCell $ lmsUserStatusWidget extendedInfo lu
|
lmsStatusCell extendedInfo mkLink = wgtCell . lmsUserStatusWidget extendedInfo mkLink
|
||||||
lmsStatusCell extendedInfo (Just toLink) lu = cell $ do
|
|
||||||
uuid <- liftHandler $ encrypt $ lu ^. _lmsUserUser
|
|
||||||
modal (lmsUserStatusWidget extendedInfo lu) (Left $ SomeRoute $ toLink uuid)
|
|
||||||
|
|
||||||
lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
|
lmsStateCell :: IsDBTable m a => LmsState -> DBCell m a
|
||||||
lmsStateCell LmsFailed = iconBoolCell False
|
lmsStateCell LmsFailed = iconBoolCell False
|
||||||
|
|||||||
@ -34,7 +34,7 @@ import Handler.Utils.LMS (randomLMSIdentBut, randomLMSpw, maxLmsUserIdentRetries
|
|||||||
import Handler.Utils.Qualification
|
import Handler.Utils.Qualification
|
||||||
|
|
||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
|
||||||
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
|
dispatchJobLmsQualificationsEnqueue :: JobHandler UniWorX
|
||||||
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
|
dispatchJobLmsQualificationsEnqueue = JobHandlerAtomic $ fetchRefreshQualifications JobLmsEnqueue
|
||||||
@ -125,6 +125,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
|||||||
where
|
where
|
||||||
act :: YesodJobDB UniWorX ()
|
act :: YesodJobDB UniWorX ()
|
||||||
act = do
|
act = do
|
||||||
|
quali <- getJust qid -- may throw an error, aborting the job
|
||||||
|
let qshort = CI.original $ qualificationShorthand quali
|
||||||
|
qprefix = fst <$> Text.uncons (Text.toLower qshort)
|
||||||
identsInUseVs <- E.select $ do
|
identsInUseVs <- E.select $ do
|
||||||
lui <- E.from $
|
lui <- E.from $
|
||||||
|
|
||||||
@ -158,9 +161,9 @@ dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
|||||||
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
|
-- startLmsUser :: YesodJobDB UniWorX (Maybe (Entity LmsUser))
|
||||||
startLmsUser = do
|
startLmsUser = do
|
||||||
lpw <- randomLMSpw
|
lpw <- randomLMSpw
|
||||||
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut identsInUse)
|
maybeM (pure Nothing) (E.insertUniqueEntity . mkLmsUser lpw) (randomLMSIdentBut qprefix identsInUse)
|
||||||
-- runMaybeT $ do
|
-- runMaybeT $ do
|
||||||
-- lid <- MaybeT $ randomLMSIdentBut identsInUse
|
-- lid <- MaybeT $ randomLMSIdentBu qprefix identsInUse
|
||||||
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
-- MaybeT $ E.insertUniqueEntity $ mkLmsUser lpw lid
|
||||||
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
|
inserted <- untilJustMaxM maxLmsUserIdentRetries startLmsUser
|
||||||
case inserted of
|
case inserted of
|
||||||
@ -186,31 +189,39 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
|||||||
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
|
$logInfoS "LMS" $ "Processing e-learning results for qualification " <> qshort
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
-- end users that expired by doing nothing
|
-- end users that expired by doing nothing
|
||||||
expiredLearners <- E.select $ do
|
expiredUsers <- E.select $ do
|
||||||
(quser :& luser) <- E.from $
|
(quser :& luser) <- E.from $
|
||||||
E.table @QualificationUser
|
E.table @QualificationUser
|
||||||
`E.innerJoin` E.table @LmsUser
|
`E.leftJoin` E.table @LmsUser
|
||||||
`E.on` (\(quser :& luser) ->
|
`E.on` (\(quser :& luser) ->
|
||||||
luser E.^. LmsUserUser E.==. quser E.^. QualificationUserUser
|
luser E.?. LmsUserUser E.?=. quser E.^. QualificationUserUser
|
||||||
E.&&. luser E.^. LmsUserQualification E.==. quser E.^. QualificationUserQualification)
|
E.&&. luser E.?. LmsUserQualification E.?=. quser E.^. QualificationUserQualification)
|
||||||
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
E.where_ $ quser E.^. QualificationUserQualification E.==. E.val qid
|
||||||
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
-- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid
|
||||||
E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
-- E.&&. E.isNothing (luser E.^. LmsUserStatus)
|
||||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
-- E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
||||||
E.&&. E.not_ (validQualification now quser)
|
E.&&. E.not_ (validQualification now quser)
|
||||||
pure (luser E.^. LmsUserId)
|
pure (quser E.^. QualificationUserUser, luser E.?. LmsUserId)
|
||||||
|
nrBlocked <- qualificationUserBlocking qid (E.unValue . fst <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
||||||
|
let expiredLearners = [luid | (_, E.Value (Just luid)) <- expiredUsers]
|
||||||
nrExpired <- E.updateCount $ \luser -> do
|
nrExpired <- E.updateCount $ \luser -> do
|
||||||
E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now]
|
E.set luser [LmsUserStatus E.=. E.justVal LmsExpired, LmsUserStatusDay E.=. E.justVal now]
|
||||||
E.where_ $ (luser E.^. LmsUserId) `E.in_` E.valList (E.unValue <$> expiredLearners)
|
E.where_ $ E.isNothing (luser E.^. LmsUserStatus)
|
||||||
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
||||||
$logInfoS "LMS" $ "Expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
|
E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners
|
||||||
|
$logInfoS "LMS" $ "Expired qualification holders " <> tshow nrBlocked <> " and expired lms users " <> tshow nrExpired <> " for qualification " <> qshort
|
||||||
|
|
||||||
when (quali ^. _qualificationExpiryNotification) $ do
|
when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers
|
||||||
notifyInvalidDrivers <- E.select $ do
|
notifyInvalidDrivers <- E.select $ do
|
||||||
quser <- E.from $ E.table @QualificationUser
|
(quser :& qblock) <- E.from $
|
||||||
E.where_ $ E.not_ (quser `qualificationValid` now) -- currently invalid
|
E.table @QualificationUser
|
||||||
E.&&. quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
|
`E.leftJoin` E.table @QualificationUserBlock
|
||||||
E.&&. quser `quserToNotify` now -- recently became invalid or blocked
|
`E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
|
||||||
|
E.&&. qblock `isLatestBlockBefore` E.val now
|
||||||
|
)
|
||||||
|
E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid
|
||||||
|
quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
|
||||||
|
E.&&. quserToNotify now quser qblock -- recently became invalid or blocked
|
||||||
pure (quser E.^. QualificationUserUser)
|
pure (quser E.^. QualificationUserUser)
|
||||||
|
|
||||||
forM_ notifyInvalidDrivers $ \(E.Value uid) ->
|
forM_ notifyInvalidDrivers $ \(E.Value uid) ->
|
||||||
@ -254,118 +265,121 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
|||||||
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
|
act = whenM (exists [LmsReportQualification ==. qid]) $ do -- executing twice must be prohibited due to assertion that ALL learners are always sent (D fails otherwise)
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
-- DEBUG 2rows; remove later
|
-- DEBUG 2rows; remove later
|
||||||
totalrows <- count [LmsReportQualification ==. qid]
|
totalrows <- count [LmsReportQualification ==. qid]
|
||||||
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
|
$logInfoS "LMS" $ "Report processing " <> tshow totalrows <> " rows for qualification " <> tshow qid
|
||||||
let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
|
when (totalrows > 0) $ do
|
||||||
-- DB query for LmsUserUser, provided a matching LmsReport exists
|
let -- locDay = localDay $ TZ.utcToLocalTimeTZ appTZ now -- no longer necessary, since LMS reports dates only
|
||||||
luserQry luFltr repFltr = E.select $ do
|
-- DB query for LmsUserUser, provided a matching LmsReport exists
|
||||||
luser <- E.from $ E.table @LmsUser
|
luserQry luFltr repFltr = E.select $ do
|
||||||
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
luser <- E.from $ E.table @LmsUser
|
||||||
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
|
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
||||||
E.&&. luFltr luser
|
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
|
||||||
E.&&. E.exists (do
|
E.&&. luFltr luser
|
||||||
|
E.&&. E.exists (do
|
||||||
|
lreport <- E.from $ E.table @LmsReport
|
||||||
|
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
||||||
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
||||||
|
E.&&. repFltr luser lreport
|
||||||
|
)
|
||||||
|
return $ luser E.^. LmsUserUser
|
||||||
|
-- DB query for LmsUser innerJoin LmsReport
|
||||||
|
lrepQry lrFltr = E.select $ do
|
||||||
|
(luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport
|
||||||
|
`E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent
|
||||||
|
E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification)
|
||||||
|
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
||||||
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
||||||
|
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
|
||||||
|
E.&&. lrFltr luser lreport
|
||||||
|
return (luser, lreport)
|
||||||
|
-- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
|
||||||
|
E.update $ \luser -> do
|
||||||
|
E.set luser [ LmsUserStatus E.=. E.nothing
|
||||||
|
, LmsUserStatusDay E.=. E.nothing
|
||||||
|
, LmsUserResetTries E.=. E.false ]
|
||||||
|
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
||||||
|
E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server
|
||||||
|
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
|
||||||
|
E.&&. luser E.^. LmsUserResetTries
|
||||||
|
E.&&. E.exists (do
|
||||||
lreport <- E.from $ E.table @LmsReport
|
lreport <- E.from $ E.table @LmsReport
|
||||||
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
||||||
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
||||||
E.&&. repFltr luser lreport
|
E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen
|
||||||
)
|
E.&&. lreport E.^. LmsReportLock E.==. E.true
|
||||||
return $ luser E.^. LmsUserUser
|
|
||||||
-- DB query for LmsUser innerJoin LmsReport
|
|
||||||
lrepQry lrFltr = E.select $ do
|
|
||||||
(luser :& lreport) <- E.from $ E.table @LmsUser`E.innerJoin` E.table @LmsReport
|
|
||||||
`E.on` (\(luser :& lreport) -> luser E.^. LmsUserIdent E.==. lreport E.^. LmsReportIdent
|
|
||||||
E.&&. luser E.^. LmsUserQualification E.==. lreport E.^. LmsReportQualification)
|
|
||||||
E.where_ $ luser E.^. LmsUserQualification E.==. E.val qid
|
|
||||||
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
||||||
E.&&. E.isNothing (luser E.^. LmsUserEnded) -- ignore all closed learners
|
|
||||||
E.&&. lrFltr luser lreport
|
|
||||||
return (luser, lreport)
|
|
||||||
-- A) reset status for learners that had their tries just resetted as indicated by LmsOpen
|
|
||||||
E.update $ \luser -> do
|
|
||||||
E.set luser [ LmsUserStatus E.=. E.nothing
|
|
||||||
, LmsUserResetTries E.=. E.false ]
|
|
||||||
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
|
||||||
E.&&. E.isNothing (luser E.^. LmsUserEnded ) -- must still exist at server
|
|
||||||
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
|
|
||||||
E.&&. luser E.^. LmsUserResetTries
|
|
||||||
E.&&. E.exists (do
|
|
||||||
lreport <- E.from $ E.table @LmsReport
|
|
||||||
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
|
||||||
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
||||||
E.&&. lreport E.^. LmsReportResult E.==. E.val LmsOpen
|
|
||||||
E.&&. lreport E.^. LmsReportLock E.==. E.true
|
|
||||||
)
|
|
||||||
-- B) notify all newly reported users that lms is available
|
|
||||||
let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting
|
|
||||||
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
|
|
||||||
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
|
|
||||||
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit)
|
|
||||||
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
|
|
||||||
procBlock (Entity luid luser, Entity _ lreport) = do
|
|
||||||
let repDay = lmsReportDate lreport <|> Just now
|
|
||||||
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
|
|
||||||
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
|
|
||||||
return $ Sum ok_block
|
|
||||||
in lrepQry lrFltrBlock
|
|
||||||
>>= foldMapM procBlock
|
|
||||||
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
|
|
||||||
-- D) renew qualifications for all successfull learners
|
|
||||||
let lrFltrSuccess luser lreport = (E.isNothing (luser E.^. LmsUserStatus) E.||. luser E.^. LmsUserStatus E.!=. E.justVal LmsSuccess) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed -- LMS WORKAROUND 1: LmsPassed replaces any other status
|
|
||||||
procRenew (Entity luid luser, Entity _ lreport) = do
|
|
||||||
let repDay = lmsReportDate lreport <|> Just now
|
|
||||||
-- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
|
|
||||||
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
|
||||||
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
|
|
||||||
-- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
|
|
||||||
-- END LMS WORKAROUND 2
|
|
||||||
ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
|
|
||||||
update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
|
|
||||||
return $ Sum ok_renew
|
|
||||||
in lrepQry lrFltrSuccess
|
|
||||||
>>= foldMapM procRenew
|
|
||||||
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
|
|
||||||
-- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
|
|
||||||
E.update $ \luser -> do
|
|
||||||
E.set luser [ LmsUserEnded E.=. E.justVal now ]
|
|
||||||
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
|
||||||
E.&&. E.isNothing (luser E.^. LmsUserEnded )
|
|
||||||
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
|
|
||||||
E.&&. E.notExists (do
|
|
||||||
lreport <- E.from $ E.table @LmsReport
|
|
||||||
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
|
||||||
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
||||||
)
|
|
||||||
|
|
||||||
-- F) lock expired learners: happens during JobLmsDequeue only
|
|
||||||
-- G) update lock and received
|
|
||||||
let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice
|
|
||||||
E.set luser [ LmsUserReceived E.=. E.justVal now
|
|
||||||
, LmsUserLocked E.=. E.val lockstatus ]
|
|
||||||
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
|
||||||
E.&&. E.isNothing (luser E.^. LmsUserEnded)
|
|
||||||
E.&&. E.exists (do
|
|
||||||
lreport <- E.from $ E.table @LmsReport
|
|
||||||
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
|
||||||
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
|
||||||
E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
|
|
||||||
)
|
)
|
||||||
-- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet
|
-- B) notify all newly reported users that lms is available
|
||||||
-- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL
|
let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting
|
||||||
-- E.set luser [ LmsUserReceived E.=. E.justVal now
|
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
|
||||||
-- , LmsUserLocked E.=. E.val lockstatus ]
|
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
|
||||||
-- lreport <- E.from $ E.table @LmsReport
|
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
|
||||||
-- E.where_ $ E.isNothing (luser E.^. LmsUserEnded)
|
let lrFltrBlock luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsFailed
|
||||||
-- E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
procBlock (Entity luid luser, Entity _ lreport) = do
|
||||||
-- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
let repDay = lmsReportDate lreport <|> Just now
|
||||||
-- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
ok_block <- qualificationUserBlocking qid [lmsUserUser luser] False (lmsReportDate lreport) (Right QualificationBlockFailedELearning) True -- only valid qualifications are blocked; transcribes to audit log
|
||||||
-- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
|
update luid [LmsUserStatus =. Just LmsBlocked, LmsUserStatusDay =. repDay]
|
||||||
updateReceivedLocked False
|
return $ Sum ok_block
|
||||||
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
|
in lrepQry lrFltrBlock
|
||||||
updateReceivedLocked True
|
>>= foldMapM procBlock
|
||||||
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
|
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " status set to blocked for qualification " <> tshow qid -- debug, remove later
|
||||||
-- G) Truncate LmsReport for qid and log
|
-- D) renew qualifications for all successfull learners
|
||||||
repProc <- deleteWhereCount [LmsReportQualification ==. qid]
|
let lrFltrSuccess luser lreport = E.isNothing (luser E.^. LmsUserStatus) E.&&. lreport E.^. LmsReportResult E.==. E.val LmsPassed
|
||||||
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
|
procRenew (Entity luid luser, Entity _ lreport) = do
|
||||||
|
let repDay = lmsReportDate lreport <|> Just now
|
||||||
|
-- LMS WORKAROUND 2: [supposedly fixed now] sometimes we receive success and failure simultaneously; success is correct, hence we must unblock if the reason was e-learning
|
||||||
|
-- let reason_undo = Left $ "LMS Workaround undoing: " <> qualificationBlockedReasonText QualificationBlockFailedELearning
|
||||||
|
-- ok_unblock <- qualificationUserUnblockByReason qid [lmsUserUser luser] repTime (Right QualificationBlockFailedELearning) reason_undo False -- affects audit log
|
||||||
|
-- when (ok_unblock > 0) ($logWarnS "LMS" [st|LMS Result: workaround triggered, unblocking #{tshow ok_unblock} e-learners for #{tshow qid} having success reported after initially failed e-learning|])
|
||||||
|
-- END LMS WORKAROUND 2
|
||||||
|
ok_renew <- renewValidQualificationUsers qid repDay [lmsUserUser luser]-- only valid qualifications are truly renewed; transcribes to audit log
|
||||||
|
update luid [LmsUserStatus =. Just LmsSuccess, LmsUserStatusDay =. repDay]
|
||||||
|
return $ Sum ok_renew
|
||||||
|
in lrepQry lrFltrSuccess
|
||||||
|
>>= foldMapM procRenew
|
||||||
|
>>= \s -> $logInfoS "LMS" $ "Report processing: " <> tshow (getSum s) <> " renewed and status set to success for qualification " <> tshow qid -- debug, remove later
|
||||||
|
-- E) mark all previuosly reported, but now unreported users as ended (LMS deleted them as expected)
|
||||||
|
E.update $ \luser -> do
|
||||||
|
E.set luser [ LmsUserEnded E.=. E.justVal now ]
|
||||||
|
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
||||||
|
E.&&. E.isNothing (luser E.^. LmsUserEnded )
|
||||||
|
E.&&. E.isJust (luser E.^. LmsUserStatus ) -- status is decided
|
||||||
|
E.&&. E.isJust (luser E.^. LmsUserReceived) -- seen before, for otherwise it might not have been started yet
|
||||||
|
E.&&. E.notExists (do
|
||||||
|
lreport <- E.from $ E.table @LmsReport
|
||||||
|
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
||||||
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
||||||
|
)
|
||||||
|
|
||||||
|
-- F) lock expired learners: happens during JobLmsDequeue only
|
||||||
|
-- G) update lock and received
|
||||||
|
let updateReceivedLocked lockstatus = E.updateCount $ \luser -> do -- due to the absence of UPDATE..FROM in esqueleto, we call update twice
|
||||||
|
E.set luser [ LmsUserReceived E.=. E.justVal now
|
||||||
|
, LmsUserLocked E.=. E.val lockstatus ]
|
||||||
|
E.where_ $ E.val qid E.==. luser E.^. LmsUserQualification
|
||||||
|
-- E.&&. E.isNothing (luser E.^. LmsUserEnded) -- should always be true, but maybe there is a bug?
|
||||||
|
E.&&. E.exists (do
|
||||||
|
lreport <- E.from $ E.table @LmsReport
|
||||||
|
E.where_ $ lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
||||||
|
E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
||||||
|
E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
|
||||||
|
)
|
||||||
|
-- NOTE: this code leads to a runtime errror; apparently from-clauses are not allowed in updates yet
|
||||||
|
-- let updateReceivedLocked lockstatus = E.update $ \luser -> do -- attempt to use 'from'-clause in update as per PostgreSQL
|
||||||
|
-- E.set luser [ LmsUserReceived E.=. E.justVal now
|
||||||
|
-- , LmsUserLocked E.=. E.val lockstatus ]
|
||||||
|
-- lreport <- E.from $ E.table @LmsReport
|
||||||
|
-- E.where_ $ E.isNothing (luser E.^. LmsUserEnded)
|
||||||
|
-- E.&&. luser E.^. LmsUserQualification E.==. E.val qid
|
||||||
|
-- E.&&. lreport E.^. LmsReportQualification E.==. E.val qid
|
||||||
|
-- E.&&. lreport E.^. LmsReportIdent E.==. luser E.^. LmsUserIdent
|
||||||
|
-- E.&&. lreport E.^. LmsReportLock E.==. E.val lockstatus -- Maybe more efficient, but less readable: bool E.not_ id lockstatus (lreport E.^. LmsReport Lock)
|
||||||
|
updateReceivedLocked False
|
||||||
|
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as unlocked and received for qualification " <> tshow qid -- debug, remove later
|
||||||
|
updateReceivedLocked True
|
||||||
|
>>= \nr -> $logInfoS "LMS" $ "Report processing marked " <> tshow nr <> " rows as locked and received for qualification " <> tshow qid -- debug, remove later
|
||||||
|
-- G) Truncate LmsReport for qid and log
|
||||||
|
repProc <- deleteWhereCount [LmsReportQualification ==. qid]
|
||||||
|
$logInfoS "LMS" [st|Processed #{tshow repProc} e-learning status reports for qualification #{tshow qid}.|]
|
||||||
|
|
||||||
|
|
||||||
-- DEPRECATED processes received results and lengthen qualifications, if applicable
|
-- DEPRECATED processes received results and lengthen qualifications, if applicable
|
||||||
|
|||||||
@ -47,7 +47,7 @@ dispatchJobPrintAck = JobHandlerException act
|
|||||||
return True
|
return True
|
||||||
_ -> return False
|
_ -> return False
|
||||||
procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} =
|
procOneId oks Entity{entityKey=paid, entityVal=PrintAcknowledge{printAcknowledgeApcIdent=Text.strip -> apci, printAcknowledgeTimestamp=ackt}} =
|
||||||
andM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case
|
orM [ackOneId ackt $ ftrans apci | ftrans <- ftransAliases] >>= \case
|
||||||
True -> delete paid >> return (succ oks)
|
True -> delete paid >> return (succ oks)
|
||||||
False -> update paid [PrintAcknowledgeProcessed =. True] >> return oks
|
False -> update paid [PrintAcknowledgeProcessed =. True] >> return oks
|
||||||
apcis <- selectList [PrintAcknowledgeProcessed ==. False] [Asc PrintAcknowledgeTimestamp, LimitTo jobPrintAckChunkSize]
|
apcis <- selectList [PrintAcknowledgeProcessed ==. False] [Asc PrintAcknowledgeTimestamp, LimitTo jobPrintAckChunkSize]
|
||||||
|
|||||||
@ -60,7 +60,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
|
|||||||
let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block
|
let expDay = maybe qualificationUserValidUntil (min qualificationUserValidUntil . utctDay . qualificationUserBlockFrom) block
|
||||||
qname = CI.original qualificationName
|
qname = CI.original qualificationName
|
||||||
qshort = CI.original qualificationShorthand
|
qshort = CI.original qualificationShorthand
|
||||||
letter = LetterExpireQualification
|
letter = LetterExpireQualification
|
||||||
{ leqHolderCFN = encRecShort
|
{ leqHolderCFN = encRecShort
|
||||||
, leqHolderID = jRecipient
|
, leqHolderID = jRecipient
|
||||||
, leqHolderDN = userDisplayName
|
, leqHolderDN = userDisplayName
|
||||||
@ -72,14 +72,14 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
|
|||||||
, leqSchool = qualificationSchool
|
, leqSchool = qualificationSchool
|
||||||
, leqUrl = pure . urender $ ForProfileDataR encRecipient
|
, leqUrl = pure . urender $ ForProfileDataR encRecipient
|
||||||
}
|
}
|
||||||
if expDay > utctDay qualificationUserLastNotified
|
if expDay > utctDay qualificationUserLastNotified
|
||||||
then do
|
then do
|
||||||
notifyOk <- sendEmailOrLetter jRecipient letter
|
notifyOk <- sendEmailOrLetter jRecipient letter
|
||||||
if notifyOk
|
if notifyOk
|
||||||
then do
|
then do
|
||||||
runDB $ update quId [QualificationUserLastNotified =. now]
|
runDB $ update quId [QualificationUserLastNotified =. now]
|
||||||
$logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
|
$logInfoS "LMS" $ "Notified " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||||
else
|
else
|
||||||
$logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
|
$logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||||
else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
|
else $logErrorS "LMS" $ "Suppressed repeated notification " <> tshow encRecipient <> " about expired qualification " <> qname
|
||||||
_ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
|
_ -> $logErrorS "LMS" $ "Failed to notify " <> tshow encRecipient <> " about expired qualification " <> tshow nQualification
|
||||||
@ -89,7 +89,7 @@ dispatchNotificationQualificationExpired nQualification jRecipient = do
|
|||||||
dispatchNotificationQualificationRenewal :: QualificationId -> Bool -> UserId -> Handler ()
|
dispatchNotificationQualificationRenewal :: QualificationId -> Bool -> UserId -> Handler ()
|
||||||
dispatchNotificationQualificationRenewal nQualification nReminder jRecipient = do
|
dispatchNotificationQualificationRenewal nQualification nReminder jRecipient = do
|
||||||
encRecipient :: CryptoUUIDUser <- encrypt jRecipient
|
encRecipient :: CryptoUUIDUser <- encrypt jRecipient
|
||||||
query <- runDB $ (,,,)
|
query <- runDB $ (,,,)
|
||||||
<$> get jRecipient
|
<$> get jRecipient
|
||||||
<*> get nQualification
|
<*> get nQualification
|
||||||
<*> getBy (UniqueQualificationUser nQualification jRecipient)
|
<*> getBy (UniqueQualificationUser nQualification jRecipient)
|
||||||
|
|||||||
@ -59,11 +59,13 @@ instance Csv.ToField LmsStatus where
|
|||||||
data QualificationBlockStandardReason
|
data QualificationBlockStandardReason
|
||||||
= QualificationBlockFailedELearning
|
= QualificationBlockFailedELearning
|
||||||
| QualificationBlockReturnedByCompany
|
| QualificationBlockReturnedByCompany
|
||||||
|
| QualificationBlockExpired
|
||||||
deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
|
deriving (Eq, Ord, Enum, Bounded, Universe, Finite)
|
||||||
|
|
||||||
instance Show QualificationBlockStandardReason where
|
instance Show QualificationBlockStandardReason where
|
||||||
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
|
show QualificationBlockFailedELearning = "E-Learning durchgefallen"
|
||||||
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
|
show QualificationBlockReturnedByCompany = "Rückgabe Firma"
|
||||||
|
show QualificationBlockExpired = "Abgelaufen"
|
||||||
|
|
||||||
qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
|
qualificationBlockedReasonText :: QualificationBlockStandardReason -> Text
|
||||||
qualificationBlockedReasonText =
|
qualificationBlockedReasonText =
|
||||||
|
|||||||
21
src/Utils.hs
21
src/Utils.hs
@ -1,4 +1,4 @@
|
|||||||
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||||
--
|
--
|
||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
@ -305,6 +305,10 @@ tshowCrop = cropText . tshow
|
|||||||
stripCI :: Text -> CI Text
|
stripCI :: Text -> CI Text
|
||||||
stripCI = CI.mk . Text.strip
|
stripCI = CI.mk . Text.strip
|
||||||
|
|
||||||
|
-- | just to avoid adding an import for this
|
||||||
|
ciOriginal :: CI Text -> Text
|
||||||
|
ciOriginal = CI.original
|
||||||
|
|
||||||
citext2lower :: CI Text -> Text
|
citext2lower :: CI Text -> Text
|
||||||
citext2lower = Text.toLower . CI.original
|
citext2lower = Text.toLower . CI.original
|
||||||
|
|
||||||
@ -312,6 +316,9 @@ citext2lower = Text.toLower . CI.original
|
|||||||
citext2string :: CI Text -> String
|
citext2string :: CI Text -> String
|
||||||
citext2string = Text.unpack . CI.original
|
citext2string = Text.unpack . CI.original
|
||||||
|
|
||||||
|
string2citext :: String -> CI Text
|
||||||
|
string2citext = CI.mk . Text.pack
|
||||||
|
|
||||||
-- | Convert or remove all non-ascii characters, e.g. for filenames
|
-- | Convert or remove all non-ascii characters, e.g. for filenames
|
||||||
text2asciiAlphaNum :: Text -> Text
|
text2asciiAlphaNum :: Text -> Text
|
||||||
text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
|
text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
|
||||||
@ -357,6 +364,9 @@ text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c)
|
|||||||
text2Html :: Text -> Html
|
text2Html :: Text -> Html
|
||||||
text2Html = toHtml
|
text2Html = toHtml
|
||||||
|
|
||||||
|
citext2Html :: CI Text -> Html
|
||||||
|
citext2Html = toHtml . CI.original
|
||||||
|
|
||||||
char2Text :: Char -> Text
|
char2Text :: Char -> Text
|
||||||
char2Text c
|
char2Text c
|
||||||
| isSpace c = "<Space>"
|
| isSpace c = "<Space>"
|
||||||
@ -665,6 +675,11 @@ lastMaybe' l = fmap snd $ l ^? _Snoc
|
|||||||
minimumMaybe :: (MonoFoldable mono, Ord (Element mono)) => mono -> Maybe (Element mono)
|
minimumMaybe :: (MonoFoldable mono, Ord (Element mono)) => mono -> Maybe (Element mono)
|
||||||
minimumMaybe = fmap minimum . fromNullable
|
minimumMaybe = fmap minimum . fromNullable
|
||||||
|
|
||||||
|
zipMaybes :: [Maybe a] -> [Maybe b] -> [(a,b)]
|
||||||
|
zipMaybes (Just x:xs) (Just y:ys) = (x,y) : zipMaybes xs ys
|
||||||
|
zipMaybes (_:xs) (_:ys) = zipMaybes xs ys
|
||||||
|
zipMaybes _ _ = []
|
||||||
|
|
||||||
-- | Merge/Add any attribute-value pair to an existing list of such pairs.
|
-- | Merge/Add any attribute-value pair to an existing list of such pairs.
|
||||||
-- If the attribute exists, the new valu will be prepended, separated by a single empty space
|
-- If the attribute exists, the new valu will be prepended, separated by a single empty space
|
||||||
insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
|
insertAttr :: Text -> Text -> [(Text,Text)] -> [(Text,Text)]
|
||||||
@ -1161,9 +1176,7 @@ guardMOnM b x = guardM b *> x
|
|||||||
-- Some Utility Functions from Agda.Utils.Monad
|
-- Some Utility Functions from Agda.Utils.Monad
|
||||||
-- | Monadic if-then-else.
|
-- | Monadic if-then-else.
|
||||||
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
ifM :: Monad m => m Bool -> m a -> m a -> m a
|
||||||
ifM c m m' =
|
ifM c x y = c >>= bool y x
|
||||||
do b <- c
|
|
||||||
if b then m else m'
|
|
||||||
|
|
||||||
-- | @ifNotM mc = ifM (not <$> mc)@ from Agda.Utils.Monad
|
-- | @ifNotM mc = ifM (not <$> mc)@ from Agda.Utils.Monad
|
||||||
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
|
ifNotM :: Monad m => m Bool -> m a -> m a -> m a
|
||||||
|
|||||||
@ -114,6 +114,7 @@ data Icon
|
|||||||
| IconLocked
|
| IconLocked
|
||||||
| IconUnlocked
|
| IconUnlocked
|
||||||
| IconResetTries -- also see IconReset
|
| IconResetTries -- also see IconReset
|
||||||
|
| IconCompany
|
||||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||||
deriving anyclass (Universe, Finite, NFData)
|
deriving anyclass (Universe, Finite, NFData)
|
||||||
|
|
||||||
@ -205,6 +206,7 @@ iconText = \case
|
|||||||
IconLocked -> "lock"
|
IconLocked -> "lock"
|
||||||
IconUnlocked -> "lock-open-alt"
|
IconUnlocked -> "lock-open-alt"
|
||||||
IconResetTries -> "trash-undo"
|
IconResetTries -> "trash-undo"
|
||||||
|
IconCompany -> "building"
|
||||||
|
|
||||||
nullaryPathPiece ''Icon $ camelToPathPiece' 1
|
nullaryPathPiece ''Icon $ camelToPathPiece' 1
|
||||||
deriveLift ''Icon
|
deriveLift ''Icon
|
||||||
|
|||||||
@ -2,12 +2,12 @@
|
|||||||
#
|
#
|
||||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
{ ghc, nixpkgs ? import ./nixpkgs.nix }:
|
{ ghc, nixpkgs ? import <nixpkgs> {} }:
|
||||||
|
|
||||||
let
|
let
|
||||||
# haskellPackages = import ./stackage.nix { inherit nixpkgs; };
|
# haskellPackages = import ./stackage.nix { inherit nixpkgs; };
|
||||||
haskellPackages = pkgs.haskellPackages;
|
haskellPackages = pkgs.haskellPackages;
|
||||||
inherit (nixpkgs {}) pkgs;
|
inherit (nixpkgs) pkgs;
|
||||||
in pkgs.haskell.lib.buildStackProject {
|
in pkgs.haskell.lib.buildStackProject {
|
||||||
inherit ghc;
|
inherit ghc;
|
||||||
inherit (haskellPackages) stack;
|
inherit (haskellPackages) stack;
|
||||||
|
|||||||
@ -43,7 +43,7 @@ $else
|
|||||||
<dd .deflist__dd>^{formatTimeW SelFormatDateTime (lmsUserStarted lmsUsr)}
|
<dd .deflist__dd>^{formatTimeW SelFormatDateTime (lmsUserStarted lmsUsr)}
|
||||||
$maybe _ <- lmsUserStatus lmsUsr
|
$maybe _ <- lmsUserStatus lmsUsr
|
||||||
<dt .deflist__dt>_{MsgTableLmsStatus}
|
<dt .deflist__dt>_{MsgTableLmsStatus}
|
||||||
<dd .deflist__dd>^{lmsUserStatusWidget True lmsUsr}
|
<dd .deflist__dd>^{lmsUserStatusWidget True Nothing lmsUsr}
|
||||||
<dt .deflist__dt>_{MsgTableLmsIdent}
|
<dt .deflist__dt>_{MsgTableLmsIdent}
|
||||||
<dd .deflist__dd>
|
<dd .deflist__dd>
|
||||||
<a href=@{LmsIdentR (qualificationSchool quali) (qualificationShorthand quali) (lmsUserIdent lmsUsr)}>
|
<a href=@{LmsIdentR (qualificationSchool quali) (qualificationShorthand quali) (lmsUserIdent lmsUsr)}>
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
$newline never
|
$newline never
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
$# SPDX-FileCopyrightText: 2022-23 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||||
$#
|
$#
|
||||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
@ -15,11 +15,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
|||||||
<dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}
|
<dd .deflist__dd>_{MsgMonths (fromIntegral dvalid)}
|
||||||
|
|
||||||
$maybe daudit <- qualificationAuditDuration quali
|
$maybe daudit <- qualificationAuditDuration quali
|
||||||
<dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget MsgQualificationAuditDurationTooltip) Nothing True}
|
<dt .deflist__dt>_{MsgQualificationAuditDuration} ^{iconTooltip (msg2widget (MsgQualificationAuditDurationTooltip lmsDeletionDays)) Nothing True}
|
||||||
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
|
<dd .deflist__dd>_{MsgMonths (fromIntegral daudit)}
|
||||||
|
|
||||||
$maybe drefresh <- qualificationRefreshWithin quali
|
$maybe drefresh <- qualificationRefreshWithin quali
|
||||||
<dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
|
<dt .deflist__dt>_{MsgQualificationRefreshWithin} ^{iconTooltip (msg2widget MsgQualificationRefreshWithinTooltip) Nothing True}
|
||||||
<dd .deflist__dd>
|
<dd .deflist__dd>
|
||||||
$with drm <- cdMonths drefresh
|
$with drm <- cdMonths drefresh
|
||||||
$with drd <- cdDays drefresh
|
$with drd <- cdDays drefresh
|
||||||
|
|||||||
@ -569,7 +569,7 @@ fillDb = do
|
|||||||
userDisplayEmail' = CI.mk $ case userSurname of
|
userDisplayEmail' = CI.mk $ case userSurname of
|
||||||
"Walker" -> "AVSNO:" <> userMatrikelnummer'
|
"Walker" -> "AVSNO:" <> userMatrikelnummer'
|
||||||
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
|
"Clark" -> "E" <> userMatrikelnummer' <> "@fraport.de"
|
||||||
"Elizabeth" -> ""
|
"Jackson" -> ""
|
||||||
_ -> userIdent
|
_ -> userIdent
|
||||||
|
|
||||||
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
|
matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
|
||||||
@ -636,6 +636,11 @@ fillDb = do
|
|||||||
void . insert' $ UserCompany fhamann bpol False False
|
void . insert' $ UserCompany fhamann bpol False False
|
||||||
void . insert' $ UserCompany fhamann ffacil True True
|
void . insert' $ UserCompany fhamann ffacil True True
|
||||||
void . insert' $ UserCompany fhamann nice False False
|
void . insert' $ UserCompany fhamann nice False False
|
||||||
|
-- need more tests
|
||||||
|
insertMany_ [UserCompany uid fraGround False False| Entity uid User{userFirstName = "John"} <- matUsers]
|
||||||
|
insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
|
||||||
|
insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
|
||||||
|
insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers]
|
||||||
-- void . insert' $ UserSupervisor jost gkleen True
|
-- void . insert' $ UserSupervisor jost gkleen True
|
||||||
-- void . insert' $ UserSupervisor jost svaupel False
|
-- void . insert' $ UserSupervisor jost svaupel False
|
||||||
-- void . insert' $ UserSupervisor jost sbarth False
|
-- void . insert' $ UserSupervisor jost sbarth False
|
||||||
@ -647,13 +652,17 @@ fillDb = do
|
|||||||
, UserSupervisor jost svaupel False
|
, UserSupervisor jost svaupel False
|
||||||
, UserSupervisor jost sbarth False
|
, UserSupervisor jost sbarth False
|
||||||
, UserSupervisor jost tinaTester True
|
, UserSupervisor jost tinaTester True
|
||||||
|
, UserSupervisor jost jost True
|
||||||
, UserSupervisor svaupel gkleen False
|
, UserSupervisor svaupel gkleen False
|
||||||
, UserSupervisor svaupel fhamann True
|
, UserSupervisor svaupel fhamann True
|
||||||
, UserSupervisor sbarth tinaTester True
|
, UserSupervisor sbarth tinaTester True
|
||||||
, UserSupervisor gkleen fhamann False
|
, UserSupervisor gkleen fhamann False
|
||||||
|
, UserSupervisor gkleen gkleen True
|
||||||
|
, UserSupervisor tinaTester tinaTester False
|
||||||
]
|
]
|
||||||
++ take 333 [ UserSupervisor fhamann uid False | Entity uid _ <- matUsers ]
|
++ take 333 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers ]
|
||||||
++ take 111 [ UserSupervisor gkleen uid False | Entity uid _ <- drop 300 matUsers ]
|
++ take 111 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 300 matUsers ]
|
||||||
|
++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 401 matUsers ]
|
||||||
upsertManyWhere supvs [] [] []
|
upsertManyWhere supvs [] [] []
|
||||||
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
|
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
|
||||||
-- insertMany_ supvs -- NOTE: multiple calls like this throw an error!
|
-- insertMany_ supvs -- NOTE: multiple calls like this throw an error!
|
||||||
@ -726,16 +735,18 @@ fillDb = do
|
|||||||
|
|
||||||
qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal)
|
qidfUsers <- Set.fromAscList . fmap (qualificationUserUser . entityVal)
|
||||||
<$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser]
|
<$> selectList [QualificationUserQualification ==. qid_f] [Asc QualificationUserUser]
|
||||||
insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11)| Entity uid User{userDisplayName=udn} <- take 200 matUsers, uid `Set.notMember` qidfUsers]
|
insertMany_ [QualificationUser uid qid_f (n_day (fromIntegral (length udn) - 12)) (n_day $ -42) (n_day $ -365) True (n_day' $ -11) | Entity uid User{userDisplayName=udn} <- take 200 $ drop 2 matUsers, uid `Set.notMember` qidfUsers]
|
||||||
void . insert' $ LmsResult qid_f (LmsIdent "hijklmn") (n_day (-1)) now
|
insertMany_ [LmsUser qid_f uid (LmsIdent udn) "123456" False now astatus astatusDay now (Just now) (Just now) Nothing False False | Entity uid User{userDisplayName=udn} <- take 200 $ drop 22 matUsers, uid `Set.notMember` qidfUsers
|
||||||
|
, let selsome = odd $ length udn, let astatus = bool Nothing (Just LmsBlocked) selsome, let astatusDay = bool Nothing (Just now) selsome]
|
||||||
|
void . insert' $ LmsResult qid_f (LmsIdent "hijklm" ) (n_day (-1)) now
|
||||||
void . insert' $ LmsResult qid_f (LmsIdent "opqgrs" ) (n_day (-2)) 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' $ LmsResult qid_f (LmsIdent "pqgrst" ) (n_day (-3)) now
|
||||||
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklmn") False now
|
void . insert' $ LmsUserlist qid_f (LmsIdent "hijklm") False now
|
||||||
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdefg") True now
|
void . insert' $ LmsUserlist qid_f (LmsIdent "abcdef") True now
|
||||||
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
|
void . insert' $ LmsUserlist qid_f (LmsIdent "ijk" ) False now
|
||||||
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
|
void . insert' $ LmsUser qid_f jost (LmsIdent "ijk" ) "123" False now Nothing Nothing now Nothing (Just $ n_day' (-7)) (Just $ n_day' (-5)) False False
|
||||||
void . insert' $ LmsUser qid_f svaupel (LmsIdent "abcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
|
void . insert' $ LmsUser qid_f svaupel (LmsIdent "bcdefg") "abc" False now (Just LmsSuccess) (Just $ n_day' 1) (n_day' (-1)) (Just now) (Just $ n_day' 0) Nothing True False
|
||||||
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hijklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
|
void . insert' $ LmsUser qid_f gkleen (LmsIdent "hiklmn") "@#!" True now (Just LmsBlocked) (Just $ now) (n_day' (-2)) (Just now) (Just $ n_day' (-4)) Nothing False True
|
||||||
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day' (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True
|
void . insert' $ LmsUser qid_f tinaTester (LmsIdent "qwvu") "45678" True now (Just LmsSuccess) (Just $ n_day' (-22)) (n_day' (-3)) (Just $ n_day' (-1)) (Just $ n_day' (-1)) Nothing True True
|
||||||
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True
|
void . insert' $ LmsUser qid_f maxMuster (LmsIdent "xyz") "a1b2c3" False now (Just LmsBlocked) (Just $ n_day' (-11)) (n_day' (-4)) (Just $ n_day' (-2)) (Just $ n_day' (-2)) Nothing True True
|
||||||
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False
|
void . insert' $ LmsUser qid_f fhamann (LmsIdent "123") "456" False now Nothing Nothing now Nothing Nothing Nothing False False
|
||||||
|
|||||||
127
test/Handler/SAPSpec.hs
Normal file
127
test/Handler/SAPSpec.hs
Normal file
@ -0,0 +1,127 @@
|
|||||||
|
-- SPDX-FileCopyrightText: 2023 Steffen Jost <s.jost@faport.de>
|
||||||
|
--
|
||||||
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
module Handler.SAPSpec where
|
||||||
|
|
||||||
|
import TestImport
|
||||||
|
-- import ModelSpec ()
|
||||||
|
-- import CryptoID
|
||||||
|
|
||||||
|
import Handler.SAP
|
||||||
|
|
||||||
|
{-
|
||||||
|
data BlockIntervalTest = BlockIntervalTest Day Day [(Day,Bool)]
|
||||||
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
|
instance Arbitrary BlockIntervalTest where
|
||||||
|
arbitrary = do
|
||||||
|
blocks <- arbitrary
|
||||||
|
case blocks of
|
||||||
|
[] -> do
|
||||||
|
dFrom <- arbitrary
|
||||||
|
dUntil <- arbitrary `suchThat` (dFrom <)
|
||||||
|
return $ BlockIntervalTest dFrom dUntil []
|
||||||
|
((h,_):t') -> do
|
||||||
|
let ds = ncons h (fst <$> t')
|
||||||
|
dmin = minimum ds
|
||||||
|
dmax = maximum ds
|
||||||
|
dFrom <- arbitrary `suchThat` (<= dmin)
|
||||||
|
dUntil <- arbitrary `suchThat` (>= dmax)
|
||||||
|
return $ BlockIntervalTest dFrom dUntil $ sort blocks
|
||||||
|
|
||||||
|
shrink (BlockIntervalTest dFrom dUntil [])
|
||||||
|
= [BlockIntervalTest dF dU [] | dF <- shrink dFrom, dU <- shrink dUntil, dF < dU]
|
||||||
|
shrink (BlockIntervalTest dFrom dUntil blocks)
|
||||||
|
= [BlockIntervalTest dFrom dUntil b | b <- shrink blocks, all ((dFrom <=) . fst) b]
|
||||||
|
-}
|
||||||
|
|
||||||
|
{- These alternative implementations do NOT meet the specifications and thus cannot be used for testing
|
||||||
|
compileBlocks :: Day -> Day -> [(Day,Bool)] -> [(Day, Day)]
|
||||||
|
compileBlocks dfrom duntil [] = [(dfrom, duntil)]
|
||||||
|
compileBlocks dfrom duntil [(d,False)]
|
||||||
|
| dend <- min duntil d, dfrom < dend = [(dfrom, dend)] -- redundant, but common case
|
||||||
|
| otherwise = []
|
||||||
|
compileBlocks dfrom duntil (p1@(d1,u1):p2@(d2,u2):bs)
|
||||||
|
| u1 == u2 = compileBlocks dfrom duntil (p1:bs) -- superfluous block/unblock
|
||||||
|
| d1 == d2 = compileBlocks dfrom duntil (p2:bs) -- eliminate same day changes
|
||||||
|
| u2, dfrom < d1, d1 < d2, d2 < duntil = (dfrom, d1) : compileBlocks d2 duntil bs -- block and reinstated later
|
||||||
|
compileBlocks dfrom duntil ((_,True ):bs) = compileBlocks dfrom duntil bs -- superfluous unblock
|
||||||
|
compileBlocks dfrom duntil ((d,False):bs)
|
||||||
|
| dfrom >= d = compileBlocks dfrom duntil bs -- should only occur if blocks/unblock happened on same day
|
||||||
|
|
||||||
|
|
||||||
|
cmpBlocks :: BlockIntervalTest -> [(Day,Day)]
|
||||||
|
cmpBlocks (BlockIntervalTest dFrom dUntil blocks) = makePeriods dFrom dUntil $ cleanBlocks $ sort blocks
|
||||||
|
where
|
||||||
|
cleanBlocks ((_,True):r) = cleanBlocks r
|
||||||
|
cleanBlocks (b1@(d1,False):b2@(d2,True):r)
|
||||||
|
| d1 < d1 = b1:b2:cleanBlocks r
|
||||||
|
| otherwise = cleanBlocks r
|
||||||
|
cleanBlocks (b1@(_,False): (_,False):r) = cleanBlocks (b1:r)
|
||||||
|
cleanBlocks r@[(_,False)] = r
|
||||||
|
cleanBlocks [] = []
|
||||||
|
|
||||||
|
makePeriods a b ((d1,False):(d2,True):r)
|
||||||
|
| b > d2 = (a,d1):makePeriods d2 b r
|
||||||
|
| otherwise = [(a,d1)]
|
||||||
|
makePeriods a b [(d,False)] = [(a,min b d)]
|
||||||
|
makePeriods a b _ = [(a,b)]
|
||||||
|
-}
|
||||||
|
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "SAP.compileBlocks" $ do
|
||||||
|
it "works on examples" . example $ do
|
||||||
|
let wA = fromGregorian 2002 1 11
|
||||||
|
wE = fromGregorian 2025 4 30
|
||||||
|
w0 = fromGregorian 2001 9 22
|
||||||
|
w1 = fromGregorian 2023 9 22
|
||||||
|
w2 = fromGregorian 2023 10 16
|
||||||
|
wF = fromGregorian 2023 10 17
|
||||||
|
w3 = fromGregorian 2023 11 17
|
||||||
|
w4 = fromGregorian 2024 01 21
|
||||||
|
compileBlocks wA wE [] `shouldBe` [(wA,wE)]
|
||||||
|
compileBlocks wA wE [(w1,False)] `shouldBe` [(wA,w1)]
|
||||||
|
compileBlocks wA wE [(w1,True)] `shouldBe` [(wA,wE)]
|
||||||
|
compileBlocks wA wE [(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
|
||||||
|
compileBlocks wA wE [(wA,False),(w1,True)] `shouldBe` [(w1,wE)]
|
||||||
|
compileBlocks wA wE [(wA,True),(wA,False),(w1,True)] `shouldBe` [(w1,wE)]
|
||||||
|
compileBlocks wA wE [(wA,False),(wA,True),(w1,True)] `shouldBe` [(wA,wE)]
|
||||||
|
compileBlocks wA wE [(wA,False),(w1,True),(w2,False)] `shouldBe` [(w1,w2)]
|
||||||
|
compileBlocks wA wE [(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)]
|
||||||
|
compileBlocks wA wE [(w1,False),(succ w1,True),(succ w1,False),(w2,True)] `shouldBe` [(wA,succ w1),(w2,wE)]
|
||||||
|
compileBlocks wA wE [(w1,False),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True)] `shouldBe` [(wA,w1),(w2,wE)]
|
||||||
|
compileBlocks wA wE [(w0,True),(w1,True),(w1,False),(w1,True),(w1,False),(w2,True),(w3,True)] `shouldBe` [(wA,w1),(w2,wE)]
|
||||||
|
compileBlocks wA wE [(w0,False),(w1,False),(w2,True),(w3,False),(w4,True)] `shouldBe` [(wA,w1),(w2,w3),(w4,wE)]
|
||||||
|
compileBlocks wA wE [(w1,False),(w2,True),(wF,True ),(w3,False)] `shouldBe` [(wA,w1),(w2,w3)]
|
||||||
|
compileBlocks wA wE [(w1,True),(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
|
||||||
|
compileBlocks wA wE [(w2,False),(wF,False),(w3,True)] `shouldBe` [(wA,w2),(w3,wE)]
|
||||||
|
compileBlocks wA wE [(w2,False),(wF,False)] `shouldBe` [(wA,w2) ]
|
||||||
|
|
||||||
|
it "handles basic intervals" $ do
|
||||||
|
(d1,d2,d3) <- generate $ do
|
||||||
|
d1 <- arbitrary
|
||||||
|
d2 <- arbitrary `suchThat` (d1 <)
|
||||||
|
d3 <- arbitrary `suchThat` (d1 <)
|
||||||
|
return (d1,d2,d3)
|
||||||
|
b <- generate arbitrary
|
||||||
|
let test = compileBlocks d1 d2 [(d3,b)]
|
||||||
|
test `shouldBe` bool [(d1,min d2 d3)] [(d1,d2)] b
|
||||||
|
|
||||||
|
it "identifies two correct intervals" $ do
|
||||||
|
(d1,d2,d3,d4) <- generate $ do
|
||||||
|
d1 <- arbitrary
|
||||||
|
d2 <- arbitrary `suchThat` (d1 <)
|
||||||
|
d3 <- arbitrary `suchThat` (d1 <)
|
||||||
|
d4 <- arbitrary `suchThat` (d3 <)
|
||||||
|
return (d1,d2,d3,d4)
|
||||||
|
b3 <- generate arbitrary
|
||||||
|
b4 <- generate arbitrary
|
||||||
|
let test = compileBlocks d1 d2 [(d3,b3),(d4,b4)]
|
||||||
|
result | b3, b4 = [(d1, d2)]
|
||||||
|
| b3 = [(d1, min d2 d4)]
|
||||||
|
| b4, d2 > d4 = [(d1,d3),(d4,d2)]
|
||||||
|
| otherwise = [(d1, min d2 d3)]
|
||||||
|
test `shouldBe` result
|
||||||
Reference in New Issue
Block a user