Merge branch 'test' into oauth2
This commit is contained in:
commit
3119dff6fe
24
CHANGELOG.md
24
CHANGELOG.md
@ -2,6 +2,30 @@
|
|||||||
|
|
||||||
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.59](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.58...v27.4.59) (2024-02-13)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **sql:** remove potential bug in relation to missing parenthesis after not_ ([42695cf](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/42695cf5ef9f21691dc027f1ec97d57eec72f03e))
|
||||||
|
|
||||||
|
## [27.4.58](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.57...v27.4.58) (2024-02-08)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **health:** negative interface routes working as intended now ([3303c4e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3303c4eebf928e527d2f9c1eb6e2495c10b94b13))
|
||||||
|
* **lms:** previouly failed notifications will be sent again ([263894b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/263894b05899ce55635d790f5334729fbc655ecc))
|
||||||
|
|
||||||
|
## [27.4.57](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.56...v27.4.57) (2024-02-06)
|
||||||
|
|
||||||
|
|
||||||
|
### Bug Fixes
|
||||||
|
|
||||||
|
* **course:** fix [#147](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/147) abort addd participant aborts now ([d332c0c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d332c0c11afd8b1dfe1343659f0b1626c968bbde))
|
||||||
|
* **health:** fix [#151](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/151) by offering route /health/interface/* ([c71814d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c71814d1ef1efc16c278136dfd6ebd86bd1d20db))
|
||||||
|
* **health:** fix [#153](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/153) and offer interface health route matching ([ce3852e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/ce3852e3d365e62b32d181d58b7cbcc749e49373))
|
||||||
|
|
||||||
## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20)
|
## [27.4.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20)
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
@ -1,11 +1,9 @@
|
|||||||
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||||
#
|
#
|
||||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
FAQLoginExpired: Mein Passwort ist abgelaufen und muss erneuert werden
|
||||||
FAQNoCampusAccount: Ich habe keine Fraport AG Kennung (Büko-Login); kann ich trotzdem Zugang zum System erhalten?
|
FAQNoCampusAccount: Ich habe keine Fraport AG Kennung (Büko-Login); kann ich trotzdem Zugang zum System erhalten?
|
||||||
FAQForgottenPassword: Ich habe mein Passwort vergessen
|
FAQForgottenPassword: Ich habe mein Passwort vergessen
|
||||||
FAQCampusCantLogin: Ich kann mich mit meiner Fraport AG Kennung (Büko-Login) nicht anmelden
|
FAQCampusCantLogin: Ich kann mich mit meiner Fraport AG Kennung (Büko-Login) nicht anmelden
|
||||||
FAQCourseCorrectorsTutors: Wie kann ich Ausbilder oder Korrektoren für meine Kursart konfigurieren?
|
FAQNotLecturerHowToCreateCourses: Wie kann ich eine neue Kursart anlegen?
|
||||||
FAQNotLecturerHowToCreateCourses: Wie kann ich eine neue Kursart anlegen?
|
|
||||||
FAQExamPoints: Warum kann ich bei meiner Klausur keine Punkte eintragen?
|
|
||||||
FAQInvalidCredentialsAdAccountDisabled: Ich kann mich nicht anmelden und bekomme die Meldung „Benutzereintrag gesperrt“
|
|
||||||
@ -1,11 +1,9 @@
|
|||||||
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||||
#
|
#
|
||||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
FAQLoginExpired: My password expired
|
||||||
FAQNoCampusAccount: I don't have Fraport AG credentials (Büko login); can I still get access?
|
FAQNoCampusAccount: I don't have Fraport AG credentials (Büko login); can I still get access?
|
||||||
FAQForgottenPassword: I have forgotten my password
|
FAQForgottenPassword: I have forgotten my password
|
||||||
FAQCampusCantLogin: I can't log in using my Fraport AG credentials (Büko login)
|
FAQCampusCantLogin: I can't log in using my Fraport AG credentials (Büko login)
|
||||||
FAQCourseCorrectorsTutors: How can I add instructors or correctors to my course?
|
FAQNotLecturerHowToCreateCourses: How can I create new courses?
|
||||||
FAQNotLecturerHowToCreateCourses: How can I create new courses?
|
|
||||||
FAQExamPoints: Why can't I enter achievements for my exam as points?
|
|
||||||
FAQInvalidCredentialsAdAccountDisabled: I can't log in and am instead given the message “Account disabled”
|
|
||||||
@ -1,4 +1,4 @@
|
|||||||
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
||||||
#
|
#
|
||||||
# SPDX-License-Identifier: AGPL-3.0-or-later
|
# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
@ -121,8 +121,15 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen
|
|||||||
ProblemsAvsErrorHeading: Fehlermeldungen
|
ProblemsAvsErrorHeading: Fehlermeldungen
|
||||||
ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
|
ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
|
||||||
|
|
||||||
|
InterfacesOk: Schnittstellen sind ok.
|
||||||
|
InterfacesFail n@Int: #{pluralDEeN n "Schnittstellenproblem"}!
|
||||||
|
InterfaceStatus !ident-ok: Status
|
||||||
|
InterfaceName: Schnittstelle
|
||||||
InterfaceLastSynch: Zuletzt
|
InterfaceLastSynch: Zuletzt
|
||||||
InterfaceSubtype: Betreffend
|
InterfaceSubtype: Betreffend
|
||||||
InterfaceWrite: Schreibend
|
InterfaceWrite: Schreibend
|
||||||
|
|
||||||
AdminUserPassword: Passwort
|
AdminUserPassword: Passwort
|
||||||
|
InterfaceSuccess: Rückmeldung
|
||||||
|
InterfaceInfo: Nachricht
|
||||||
|
InterfaceFreshness: Prüfungszeitraum (h)
|
||||||
|
|||||||
@ -121,8 +121,15 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences
|
|||||||
ProblemsAvsErrorHeading: Error Log
|
ProblemsAvsErrorHeading: Error Log
|
||||||
ProblemsInterfaceSince: Only considering successes and errors since
|
ProblemsInterfaceSince: Only considering successes and errors since
|
||||||
|
|
||||||
|
InterfacesOk: Interfaces are ok.
|
||||||
|
InterfacesFail n: #{pluralENsN n "interface problem"}!
|
||||||
|
InterfaceStatus: Status
|
||||||
|
InterfaceName: Interface
|
||||||
InterfaceLastSynch: Last
|
InterfaceLastSynch: Last
|
||||||
InterfaceSubtype: Affecting
|
InterfaceSubtype: Affecting
|
||||||
InterfaceWrite: Write
|
InterfaceWrite: Write
|
||||||
|
|
||||||
AdminUserPassword: Password
|
AdminUserPassword: Password
|
||||||
|
InterfaceSuccess: Returned
|
||||||
|
InterfaceInfo: Message
|
||||||
|
InterfaceFreshness: Check hours
|
||||||
|
|||||||
@ -95,7 +95,7 @@ CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} pe
|
|||||||
CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits zur Kursart angemeldet
|
CourseParticipantsAlreadyRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits zur Kursart angemeldet
|
||||||
CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits in dieser Kurs angemeldet
|
CourseParticipantsAlreadyTutorialMember n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} #{pluralDE n "ist" "sind"} bereits in dieser Kurs angemeldet
|
||||||
CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kursart angemeldet
|
CourseParticipantsRegistered n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kursart angemeldet
|
||||||
CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur Kurs angemeldet
|
CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zum Kurs angemeldet
|
||||||
CourseParticipantsRegisterConfirmationHeading: Teilnehmer:innen hinzufügen
|
CourseParticipantsRegisterConfirmationHeading: Teilnehmer:innen hinzufügen
|
||||||
CourseParticipantsRegisterUnnecessary: Alle angeforderten Anmeldungen sind bereits vorhanden. Es wurden keine Änderungen vorgenommen.
|
CourseParticipantsRegisterUnnecessary: Alle angeforderten Anmeldungen sind bereits vorhanden. Es wurden keine Änderungen vorgenommen.
|
||||||
CourseParticipantsRegisterConfirmInvalid: Ungültiges Bestätigungsformular!
|
CourseParticipantsRegisterConfirmInvalid: Ungültiges Bestätigungsformular!
|
||||||
|
|||||||
@ -23,6 +23,7 @@ MenuPayments: Zahlungsbedingungen
|
|||||||
|
|
||||||
MenuInstance: Instanz-Identifikation
|
MenuInstance: Instanz-Identifikation
|
||||||
MenuHealth: Instanz-Zustand
|
MenuHealth: Instanz-Zustand
|
||||||
|
MenuHealthInterface: Schnittstellen Zustand
|
||||||
MenuHelp: Hilfe
|
MenuHelp: Hilfe
|
||||||
MenuAccount: Konto
|
MenuAccount: Konto
|
||||||
MenuProfile: Anpassen
|
MenuProfile: Anpassen
|
||||||
@ -146,6 +147,8 @@ MenuExternalUser: Externe Benutzer
|
|||||||
MenuApc: Druckerei
|
MenuApc: Druckerei
|
||||||
MenuPrintSend: Manueller Briefversand
|
MenuPrintSend: Manueller Briefversand
|
||||||
MenuPrintDownload: Brief herunterladen
|
MenuPrintDownload: Brief herunterladen
|
||||||
|
MenuPrintLog: LPR Schnittstelle
|
||||||
|
MenuPrintAck: Druckbestätigung
|
||||||
|
|
||||||
MenuApiDocs: API-Dokumentation (Englisch)
|
MenuApiDocs: API-Dokumentation (Englisch)
|
||||||
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
|
MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger)
|
||||||
|
|||||||
@ -23,6 +23,7 @@ MenuPayments: Payment Terms
|
|||||||
|
|
||||||
MenuInstance: Instance identification
|
MenuInstance: Instance identification
|
||||||
MenuHealth: Instance health
|
MenuHealth: Instance health
|
||||||
|
MenuHealthInterface: Interface health
|
||||||
MenuHelp: Support
|
MenuHelp: Support
|
||||||
MenuAccount: Account
|
MenuAccount: Account
|
||||||
MenuProfile: Settings
|
MenuProfile: Settings
|
||||||
@ -146,6 +147,8 @@ MenuExternalUser: External users
|
|||||||
MenuApc: Printing
|
MenuApc: Printing
|
||||||
MenuPrintSend: Send Letter
|
MenuPrintSend: Send Letter
|
||||||
MenuPrintDownload: Download Letter
|
MenuPrintDownload: Download Letter
|
||||||
|
MenuPrintLog: LPR Interface
|
||||||
|
MenuPrintAck: Acknowledge Printing
|
||||||
|
|
||||||
MenuApiDocs: API documentation
|
MenuApiDocs: API documentation
|
||||||
MenuSwagger: OpenAPI 2.0 (Swagger)
|
MenuSwagger: OpenAPI 2.0 (Swagger)
|
||||||
|
|||||||
@ -14,9 +14,18 @@ TransactionLog
|
|||||||
InterfaceLog
|
InterfaceLog
|
||||||
interface Text
|
interface Text
|
||||||
subtype Text
|
subtype Text
|
||||||
write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive
|
write Bool -- requestMethod /= GET, i.e. True implies a write to FRADrive
|
||||||
time UTCTime
|
time UTCTime
|
||||||
rows Int Maybe -- number of datasets transmitted
|
rows Int Maybe -- number of datasets transmitted
|
||||||
info Text -- addtional status information
|
info Text -- addtional status information
|
||||||
|
success Bool default=true -- false logs a failure; but it will be overwritten by next transaction, but logged in TransactionLog
|
||||||
UniqueInterfaceSubtypeWrite interface subtype write
|
UniqueInterfaceSubtypeWrite interface subtype write
|
||||||
deriving Eq Read Show Generic
|
deriving Eq Read Show Generic
|
||||||
|
|
||||||
|
InterfaceHealth
|
||||||
|
interface Text
|
||||||
|
subtype Text Maybe
|
||||||
|
write Bool Maybe
|
||||||
|
hours Int
|
||||||
|
UniqueInterfaceHealth interface subtype write !force -- Note that nullable fields must be either empty or unique
|
||||||
|
deriving Eq Read Show Generic
|
||||||
|
|||||||
@ -20,7 +20,7 @@ Qualification
|
|||||||
SchoolQualificationShort school shorthand -- must be unique per school and shorthand
|
SchoolQualificationShort school shorthand -- must be unique per school and shorthand
|
||||||
SchoolQualificationName school name -- must be unique per school and name
|
SchoolQualificationName school name -- must be unique per school and name
|
||||||
-- across all schools, only one qualification may be a driving licence:
|
-- across all schools, only one qualification may be a driving licence:
|
||||||
UniqueQualificationAvsLicence avsLicence !force
|
UniqueQualificationAvsLicence avsLicence !force -- either empty or unique
|
||||||
-- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
|
-- NOTE: two NULL values are not equal for the purpose of Uniqueness constraints!
|
||||||
deriving Eq Generic
|
deriving Eq Generic
|
||||||
|
|
||||||
@ -40,21 +40,22 @@ Qualification
|
|||||||
-- - PinReset==1 mit bestehendem Passwort kann problemlos erneut gesendet werden
|
-- - PinReset==1 mit bestehendem Passwort kann problemlos erneut gesendet werden
|
||||||
-- - Flag "interner Mitarbeiter" wird von Know-How ignoriert / nicht ausgewertet (legacy)
|
-- - Flag "interner Mitarbeiter" wird von Know-How ignoriert / nicht ausgewertet (legacy)
|
||||||
|
|
||||||
QualificationPrecondition -- NOTE: this can only be enforced through a background job adding or removing qualifications
|
-- QualificationPrecondition -- NOTE: this can only be enforced through a background job adding or removing qualifications
|
||||||
qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
|
-- qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions
|
||||||
required [QualificationId] -- OR : alternatives, any one will suffice
|
-- required [QualificationId] -- OR : alternatives, any one will suffice
|
||||||
continuous Bool -- expiring precondition blocks qualification
|
-- continuous Bool -- expiring precondition blocks qualification
|
||||||
deriving Generic
|
-- deriving Generic
|
||||||
|
|
||||||
-- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version)
|
-- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version)
|
||||||
-- QualificationRequirement
|
--QualificationRequirement
|
||||||
-- qualification QualificationId OnDeleteCascade OnUpdateCascade
|
-- qualification QualificationId OnDeleteCascade OnUpdateCascade
|
||||||
-- requirement QualificationId OnDeleteCascade OnUpdateCascade
|
-- requirement QualificationId OnDeleteCascade OnUpdateCascade
|
||||||
-- group Text -- OR: several requirements within the same group are considered equivalent
|
-- group Text -- OR: several requirements within the same group are considered equivalent
|
||||||
-- UniqueQualificationRequirement qualification requirement
|
-- UniqueQualificationRequirement qualification requirement
|
||||||
|
-- deriving Generic
|
||||||
--
|
--
|
||||||
|
|
||||||
-- TODO: connect Qualification with Exams!
|
-- TODO: connect Qualifications with Exams!?
|
||||||
|
|
||||||
QualificationEdit
|
QualificationEdit
|
||||||
user UserId
|
user UserId
|
||||||
@ -81,6 +82,7 @@ QualificationUserBlock
|
|||||||
from UTCTime
|
from UTCTime
|
||||||
reason Text
|
reason Text
|
||||||
blocker UserId Maybe
|
blocker UserId Maybe
|
||||||
|
-- precondition Bool default=false -- if true, this was due to a precondition
|
||||||
deriving Eq Ord Read Show Generic
|
deriving Eq Ord Read Show Generic
|
||||||
|
|
||||||
-- LMS Interface Tables, need regular processing by background jobs, per QualificationId:
|
-- LMS Interface Tables, need regular processing by background jobs, per QualificationId:
|
||||||
|
|||||||
@ -1,3 +1,3 @@
|
|||||||
{
|
{
|
||||||
"version": "27.4.56"
|
"version": "27.4.59"
|
||||||
}
|
}
|
||||||
|
|||||||
2
package-lock.json
generated
2
package-lock.json
generated
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"name": "uni2work",
|
"name": "uni2work",
|
||||||
"version": "27.4.56",
|
"version": "27.4.59",
|
||||||
"lockfileVersion": 1,
|
"lockfileVersion": 1,
|
||||||
"requires": true,
|
"requires": true,
|
||||||
"dependencies": {
|
"dependencies": {
|
||||||
|
|||||||
@ -1,6 +1,6 @@
|
|||||||
{
|
{
|
||||||
"name": "uni2work",
|
"name": "uni2work",
|
||||||
"version": "27.4.56",
|
"version": "27.4.59",
|
||||||
"description": "",
|
"description": "",
|
||||||
"keywords": [],
|
"keywords": [],
|
||||||
"author": "",
|
"author": "",
|
||||||
|
|||||||
@ -1,5 +1,5 @@
|
|||||||
name: uniworx
|
name: uniworx
|
||||||
version: 27.4.56
|
version: 27.4.59
|
||||||
dependencies:
|
dependencies:
|
||||||
- base
|
- base
|
||||||
- yesod
|
- yesod
|
||||||
|
|||||||
32
routes
32
routes
@ -82,24 +82,26 @@
|
|||||||
|
|
||||||
/print PrintCenterR GET POST !system-printer
|
/print PrintCenterR GET POST !system-printer
|
||||||
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
|
/print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer
|
||||||
/print/acknowledge/direct PrintAckDirectR POST !system-printer
|
/print/acknowledge/direct PrintAckDirectR GET POST !system-printer
|
||||||
/print/send PrintSendR GET POST
|
/print/send PrintSendR GET POST
|
||||||
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer
|
/print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer
|
||||||
|
/print/log PrintLogR GET !system-printer
|
||||||
|
|
||||||
/health HealthR GET !free
|
/health HealthR GET !free
|
||||||
/instance InstanceR GET !free
|
/health/interface/+Texts HealthInterfaceR GET !free
|
||||||
/info InfoR GET !free
|
/instance InstanceR GET !free
|
||||||
/info/lecturer InfoLecturerR GET !free
|
/info InfoR GET !free
|
||||||
/info/supervisor InfoSupervisorR GET !free
|
/info/lecturer InfoLecturerR GET !free
|
||||||
/info/legal LegalR GET !free
|
/info/supervisor InfoSupervisorR GET !free
|
||||||
/info/glossary GlossaryR GET !free
|
/info/legal LegalR GET !free
|
||||||
/info/faq FaqR GET !free
|
/info/glossary GlossaryR GET !free
|
||||||
/info/terms-of-use TermsOfUseR GET !free
|
/info/faq FaqR GET !free
|
||||||
/info/payments PaymentsR GET !free
|
/info/terms-of-use TermsOfUseR GET !free
|
||||||
/imprint ImprintR GET !free
|
/info/payments PaymentsR GET !free
|
||||||
/data-protection DataProtectionR GET !free
|
/imprint ImprintR GET !free
|
||||||
/version VersionR GET !free
|
/data-protection DataProtectionR GET !free
|
||||||
/status StatusR GET !free
|
/version VersionR GET !free
|
||||||
|
/status StatusR GET !free
|
||||||
|
|
||||||
/help HelpR GET POST !free
|
/help HelpR GET POST !free
|
||||||
|
|
||||||
|
|||||||
@ -148,6 +148,7 @@ import Handler.Material
|
|||||||
import Handler.CryptoIDDispatch
|
import Handler.CryptoIDDispatch
|
||||||
import Handler.SystemMessage
|
import Handler.SystemMessage
|
||||||
import Handler.Health
|
import Handler.Health
|
||||||
|
import Handler.Health.Interface
|
||||||
import Handler.Exam
|
import Handler.Exam
|
||||||
import Handler.ExamOffice
|
import Handler.ExamOffice
|
||||||
import Handler.Metrics
|
import Handler.Metrics
|
||||||
|
|||||||
40
src/Audit.hs
40
src/Audit.hs
@ -8,7 +8,7 @@ module Audit
|
|||||||
, audit
|
, audit
|
||||||
, AuditRemoteException(..)
|
, AuditRemoteException(..)
|
||||||
, getRemote
|
, getRemote
|
||||||
, logInterface
|
, logInterface, logInterface'
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
|
||||||
@ -123,19 +123,49 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User
|
|||||||
)
|
)
|
||||||
=> Text -- ^ Interface that is used
|
=> Text -- ^ Interface that is used
|
||||||
-> Text -- ^ Subtype of the interface, if any
|
-> Text -- ^ Subtype of the interface, if any
|
||||||
|
-> Bool -- ^ Success=True, Failure=False
|
||||||
-> Maybe Int -- ^ Number of transmitted datasets
|
-> Maybe Int -- ^ Number of transmitted datasets
|
||||||
-> Text -- ^ Any additional information
|
-> Text -- ^ Any additional information
|
||||||
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||||
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
|
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
|
||||||
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogRows interfaceLogInfo = do
|
logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do
|
||||||
interfaceLogTime <- liftIO getCurrentTime
|
|
||||||
interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
|
interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest
|
||||||
deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest
|
logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo
|
||||||
insert_ InterfaceLog{..}
|
|
||||||
|
logInterface' :: ( AuthId (HandlerSite m) ~ Key User
|
||||||
|
, IsSqlBackend (YesodPersistBackend (HandlerSite m))
|
||||||
|
, SqlBackendCanWrite (YesodPersistBackend (HandlerSite m))
|
||||||
|
, HasInstanceID (HandlerSite m) InstanceId
|
||||||
|
, YesodAuthPersist (HandlerSite m)
|
||||||
|
, MonadHandler m
|
||||||
|
, MonadCatch m
|
||||||
|
, HasAppSettings (HandlerSite m)
|
||||||
|
, HasCallStack
|
||||||
|
)
|
||||||
|
=> Text -- ^ Interface that is used
|
||||||
|
-> Text -- ^ Subtype of the interface, if any
|
||||||
|
-> Bool -- ^ True indicates Write Access to FRADrive
|
||||||
|
-> Bool -- ^ Success=True, Failure=False
|
||||||
|
-> Maybe Int -- ^ Number of transmitted datasets
|
||||||
|
-> Text -- ^ Any additional information
|
||||||
|
-> ReaderT (YesodPersistBackend (HandlerSite m)) m ()
|
||||||
|
-- ^ Log a transaction using information available from `HandlerT`, also calls `audit`
|
||||||
|
logInterface' (Text.strip -> interfaceLogInterface) (Text.strip -> interfaceLogSubtype) interfaceLogWrite interfaceLogSuccess interfaceLogRows (Text.strip -> interfaceLogInfo) = do
|
||||||
|
interfaceLogTime <- liftIO getCurrentTime
|
||||||
|
-- deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace: deleteBy & insert seems to be safest and fastest
|
||||||
|
-- insert_ InterfaceLog{..}
|
||||||
|
void $ upsertBy (UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite)
|
||||||
|
( InterfaceLog{..} )
|
||||||
|
[ InterfaceLogTime =. interfaceLogTime
|
||||||
|
, InterfaceLogRows =. interfaceLogRows
|
||||||
|
, InterfaceLogInfo =. interfaceLogInfo
|
||||||
|
, InterfaceLogSuccess =. interfaceLogSuccess
|
||||||
|
]
|
||||||
audit TransactionInterface
|
audit TransactionInterface
|
||||||
{ transactionInterfaceName = interfaceLogInterface
|
{ transactionInterfaceName = interfaceLogInterface
|
||||||
, transactionInterfaceSubtype = interfaceLogSubtype
|
, transactionInterfaceSubtype = interfaceLogSubtype
|
||||||
, transactionInterfaceWrite = interfaceLogWrite
|
, transactionInterfaceWrite = interfaceLogWrite
|
||||||
, transactionInterfaceRows = interfaceLogRows
|
, transactionInterfaceRows = interfaceLogRows
|
||||||
, transactionInterfaceInfo = interfaceLogInfo
|
, transactionInterfaceInfo = interfaceLogInfo
|
||||||
|
, transactionInterfaceSuccess = Just interfaceLogSuccess
|
||||||
}
|
}
|
||||||
|
|||||||
@ -240,6 +240,7 @@ data Transaction
|
|||||||
, transactionInterfaceWrite :: Bool -- True implies a write to FRADrive
|
, transactionInterfaceWrite :: Bool -- True implies a write to FRADrive
|
||||||
, transactionInterfaceRows :: Maybe Int
|
, transactionInterfaceRows :: Maybe Int
|
||||||
, transactionInterfaceInfo :: Text
|
, transactionInterfaceInfo :: Text
|
||||||
|
, transactionInterfaceSuccess :: Maybe Bool -- Just False implies a failure; Maybe used to achieve backwards compatibility
|
||||||
}
|
}
|
||||||
deriving (Eq, Ord, Read, Show, Generic)
|
deriving (Eq, Ord, Read, Show, Generic)
|
||||||
|
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||||
--
|
--
|
||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
@ -17,6 +17,7 @@ module Database.Esqueleto.Utils
|
|||||||
, (>~.), (<~.)
|
, (>~.), (<~.)
|
||||||
, or, and
|
, or, and
|
||||||
, any, all
|
, any, all
|
||||||
|
, not__, parens
|
||||||
, subSelectAnd, subSelectOr
|
, subSelectAnd, subSelectOr
|
||||||
, mkExactFilter, mkExactFilterWith, mkExactFilterWithComma
|
, mkExactFilter, mkExactFilterWith, mkExactFilterWithComma
|
||||||
, mkExactFilterLast, mkExactFilterLastWith
|
, mkExactFilterLast, mkExactFilterLastWith
|
||||||
@ -252,6 +253,9 @@ subSelectOr q = parens . E.subSelectUnsafe $ flip (E.unsafeSqlAggregateFunction
|
|||||||
parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
|
parens :: E.SqlExpr (E.Value a) -> E.SqlExpr (E.Value a)
|
||||||
parens = E.unsafeSqlFunction ""
|
parens = E.unsafeSqlFunction ""
|
||||||
|
|
||||||
|
-- | Workaround for Esqueleto-Bug not placing parenthesis after NOT, see #155
|
||||||
|
not__ :: E.SqlExpr (E.Value Bool) -> E.SqlExpr (E.Value Bool)
|
||||||
|
not__ = E.not_ . parens
|
||||||
|
|
||||||
-- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
|
-- Allow usage of Tuples as DbtRowKey, i.e. SqlIn instances for tuples
|
||||||
$(sqlInTuples [2..16])
|
$(sqlInTuples [2..16])
|
||||||
@ -705,7 +709,6 @@ interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text
|
|||||||
singleQuote = Text.Builder.singleton '\''
|
singleQuote = Text.Builder.singleton '\''
|
||||||
wrapSqlString b = singleQuote <> b <> singleQuote
|
wrapSqlString b = singleQuote <> b <> singleQuote
|
||||||
|
|
||||||
|
|
||||||
infixl 6 `diffDays`, `diffTimes`
|
infixl 6 `diffDays`, `diffTimes`
|
||||||
|
|
||||||
diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)
|
diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int)
|
||||||
|
|||||||
@ -129,13 +129,14 @@ breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing
|
|||||||
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
|
breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR
|
||||||
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR
|
breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR
|
||||||
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh
|
breadcrumb (FirmSupersR fsh)= i18nCrumb MsgMenuFirmSupervisors $ Just $ FirmUsersR fsh
|
||||||
breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh
|
breadcrumb (FirmCommR fsh)= i18nCrumb MsgMenuFirmsComm $ Just $ FirmUsersR fsh
|
||||||
|
|
||||||
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
|
||||||
breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
|
breadcrumb PrintAckR{} = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
|
||||||
breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintSend $ Just PrintCenterR -- never displayed
|
breadcrumb PrintAckDirectR{}= i18nCrumb MsgMenuPrintAck $ Just PrintCenterR
|
||||||
|
breadcrumb PrintLogR = i18nCrumb MsgMenuPrintLog $ Just PrintCenterR
|
||||||
|
|
||||||
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
breadcrumb SchoolListR = i18nCrumb MsgMenuSchoolList $ Just AdminR
|
||||||
breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
breadcrumb (SchoolR ssh sRoute) = case sRoute of
|
||||||
@ -166,9 +167,10 @@ breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR
|
|||||||
breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing
|
breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing
|
||||||
|
|
||||||
|
|
||||||
breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
|
breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing
|
||||||
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
|
breadcrumb (HealthInterfaceR _) = i18nCrumb MsgMenuHealthInterface (Just HealthR)
|
||||||
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
|
breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing
|
||||||
|
breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed
|
||||||
|
|
||||||
breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing
|
breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing
|
||||||
breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
|
breadcrumb (QualificationSchoolR ssh ) = useRunDB . maybeT (i18nCrumb MsgBreadcrumbSchool . Just $ SchoolListR) $ do -- redirect only, used in other breadcrumbs
|
||||||
@ -193,7 +195,7 @@ breadcrumb (LmsLearnersDirectR ssh qsh) = i18nCrumb MsgMenuLmsLearners $ Jus
|
|||||||
breadcrumb (LmsReportR ssh qsh) = i18nCrumb MsgMenuLmsReport $ Just $ LmsR ssh qsh
|
breadcrumb (LmsReportR ssh qsh) = i18nCrumb MsgMenuLmsReport $ Just $ LmsR ssh qsh
|
||||||
breadcrumb (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh
|
breadcrumb (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh
|
||||||
breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed
|
breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed
|
||||||
--
|
--
|
||||||
breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
|
breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect
|
||||||
breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh
|
breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh
|
||||||
breadcrumb (LmsUserSchoolR u _ ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u
|
breadcrumb (LmsUserSchoolR u _ ) = i18nCrumb MsgMenuLmsUserSchool $ Just $ LmsUserAllR u
|
||||||
@ -294,7 +296,7 @@ breadcrumb (CourseR tid ssh csh (TutorialR tutn sRoute)) = case sRoute of
|
|||||||
TUsersR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
|
TUsersR -> useRunDB . maybeT (i18nCrumb MsgBreadcrumbTutorial . Just $ CourseR tid ssh csh CTutorialListR) $ do
|
||||||
guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
|
guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR
|
||||||
return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
return (CI.original tutn, Just $ CourseR tid ssh csh CTutorialListR)
|
||||||
TAddUserR -> i18nCrumb MsgMenuTutorialAddMembers . Just $ CTutorialR tid ssh csh tutn TUsersR
|
TAddUserR -> i18nCrumb MsgMenuTutorialAddMembers . Just $ CTutorialR tid ssh csh tutn TUsersR
|
||||||
TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
|
TEditR -> i18nCrumb MsgMenuTutorialEdit . Just $ CTutorialR tid ssh csh tutn TUsersR
|
||||||
TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR
|
TDeleteR -> i18nCrumb MsgMenuTutorialDelete . Just $ CTutorialR tid ssh csh tutn TUsersR
|
||||||
TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR
|
TCommR -> i18nCrumb MsgMenuTutorialComm . Just $ CTutorialR tid ssh csh tutn TUsersR
|
||||||
@ -1330,6 +1332,17 @@ pageActions HealthR = return
|
|||||||
}
|
}
|
||||||
, navChildren = []
|
, navChildren = []
|
||||||
}
|
}
|
||||||
|
, NavPageActionPrimary
|
||||||
|
{ navLink = NavLink
|
||||||
|
{ navLabel = MsgMenuHealthInterface
|
||||||
|
, navRoute = HealthInterfaceR []
|
||||||
|
, navAccess' = NavAccessTrue
|
||||||
|
, navType = NavTypeLink { navModal = False }
|
||||||
|
, navQuick' = mempty
|
||||||
|
, navForceActive = False
|
||||||
|
}
|
||||||
|
, navChildren = []
|
||||||
|
}
|
||||||
]
|
]
|
||||||
pageActions InstanceR = return
|
pageActions InstanceR = return
|
||||||
[ NavPageActionPrimary
|
[ NavPageActionPrimary
|
||||||
@ -2364,7 +2377,7 @@ pageActions (LmsR sid qsh) = return
|
|||||||
[ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh
|
[ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh
|
||||||
, defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh
|
, defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh
|
||||||
]
|
]
|
||||||
}
|
}
|
||||||
, NavPageActionSecondary {
|
, NavPageActionSecondary {
|
||||||
navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
|
navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh
|
||||||
}
|
}
|
||||||
@ -2389,7 +2402,7 @@ pageActions (FirmUsersR fsh) = return
|
|||||||
[ NavPageActionPrimary
|
[ NavPageActionPrimary
|
||||||
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
|
{ navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh
|
||||||
, navChildren = []
|
, navChildren = []
|
||||||
}
|
}
|
||||||
]
|
]
|
||||||
pageActions (FirmSupersR fsh) = return
|
pageActions (FirmSupersR fsh) = return
|
||||||
[ NavPageActionPrimary
|
[ NavPageActionPrimary
|
||||||
@ -2432,10 +2445,30 @@ pageActions PrintCenterR = do
|
|||||||
, navForceActive = False
|
, navForceActive = False
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
printLog = NavPageActionSecondary
|
||||||
|
{ navLink = NavLink
|
||||||
|
{ navLabel = MsgMenuPrintLog
|
||||||
|
, navRoute = PrintLogR
|
||||||
|
, navAccess' = NavAccessTrue
|
||||||
|
, navType = NavTypeLink { navModal = False }
|
||||||
|
, navQuick' = mempty
|
||||||
|
, navForceActive = False
|
||||||
|
}
|
||||||
|
}
|
||||||
|
printAck = NavPageActionSecondary
|
||||||
|
{ navLink = NavLink
|
||||||
|
{ navLabel = MsgMenuPrintAck
|
||||||
|
, navRoute = PrintAckDirectR
|
||||||
|
, navAccess' = NavAccessTrue
|
||||||
|
, navType = NavTypeLink { navModal = False }
|
||||||
|
, navQuick' = mempty
|
||||||
|
, navForceActive = False
|
||||||
|
}
|
||||||
|
}
|
||||||
dayLinks <- mapM toDayAck $ Map.toAscList dayMap
|
dayLinks <- mapM toDayAck $ Map.toAscList dayMap
|
||||||
return $ manualSend : take 9 dayLinks
|
return $ manualSend : printLog : printAck : take 9 dayLinks
|
||||||
|
|
||||||
pageActions AdminCrontabR = return
|
pageActions AdminCrontabR = return
|
||||||
[ NavPageActionPrimary
|
[ NavPageActionPrimary
|
||||||
{ navLink = defNavLink MsgMenuAdminJobs AdminJobsR
|
{ navLink = defNavLink MsgMenuAdminJobs AdminJobsR
|
||||||
, navChildren = []
|
, navChildren = []
|
||||||
|
|||||||
@ -24,6 +24,7 @@ import qualified Database.Esqueleto.Utils as E
|
|||||||
import Handler.Utils
|
import Handler.Utils
|
||||||
import Handler.Utils.Avs
|
import Handler.Utils.Avs
|
||||||
import Handler.Utils.Users
|
import Handler.Utils.Users
|
||||||
|
import Handler.Health.Interface
|
||||||
|
|
||||||
import Handler.Admin.Test as Handler.Admin
|
import Handler.Admin.Test as Handler.Admin
|
||||||
import Handler.Admin.ErrorMessage as Handler.Admin
|
import Handler.Admin.ErrorMessage as Handler.Admin
|
||||||
@ -54,13 +55,15 @@ getAdminProblemsR = do
|
|||||||
flagNonZero n | n <= 0 = flagError True
|
flagNonZero n | n <= 0 = flagError True
|
||||||
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
|
| otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n))
|
||||||
|
|
||||||
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,)
|
(usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,)
|
||||||
<$> areAllUsersReachable
|
<$> areAllUsersReachable
|
||||||
<*> allDriversHaveAvsId now
|
<*> allDriversHaveAvsId now
|
||||||
<*> allRDriversHaveFs now
|
<*> allRDriversHaveFs now
|
||||||
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
|
<*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime])
|
||||||
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
|
<*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
|
||||||
<*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime)
|
<*> mkInterfaceLogTable flagError mempty
|
||||||
|
let interfacesBadNr = length $ filter (not . snd) interfaceOks
|
||||||
|
-- interfacesOk = all snd interfaceOks
|
||||||
diffLics <- try retrieveDifferingLicences >>= \case
|
diffLics <- try retrieveDifferingLicences >>= \case
|
||||||
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
|
-- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received"
|
||||||
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
|
(Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException)
|
||||||
@ -235,76 +238,3 @@ retrieveDriversRWithoutF now = do
|
|||||||
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
|
E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld)
|
||||||
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
|
E.&&. E.notExists (hasValidQual AvsLicenceVorfeld)
|
||||||
return usr
|
return usr
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
mkInterfaceLogTable :: (Bool -> Widget) -> UTCTime -> DB (Any, Widget)
|
|
||||||
mkInterfaceLogTable flagError cutOffOldTime = do
|
|
||||||
avsSynchStats <- E.select $ do
|
|
||||||
uavs <- E.from $ E.table @UserAvs
|
|
||||||
E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
|
|
||||||
let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
|
|
||||||
E.groupBy isOk
|
|
||||||
E.orderBy [E.descNullsLast isOk]
|
|
||||||
return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
|
|
||||||
let
|
|
||||||
mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
|
|
||||||
fmtCut <- formatTime SelFormatDate cutOffOldTime
|
|
||||||
fmtBad <- formatTime SelFormatDateTime badTime
|
|
||||||
return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
|
|
||||||
mkBadInfo _ _ = return mempty
|
|
||||||
writeAvsSynchStats okRows (fromMaybe cutOffOldTime -> okTime) badInfo =
|
|
||||||
void $ upsertBy (UniqueInterfaceSubtypeWrite "AVS" "Synch" True)
|
|
||||||
(InterfaceLog "AVS" "Synch" True okTime okRows badInfo)
|
|
||||||
[InterfaceLogTime =. okTime, InterfaceLogRows =. okRows, InterfaceLogInfo =. badInfo]
|
|
||||||
--case $(unValueN 3) <$> avsSynchStats of
|
|
||||||
case avsSynchStats of
|
|
||||||
((E.Value True , E.Value okRows, E.Value okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
|
|
||||||
writeAvsSynchStats (Just okRows) okTime =<< mkBadInfo badRows badTime
|
|
||||||
((E.Value True , E.Value okRows, E.Value okTime):_) ->
|
|
||||||
writeAvsSynchStats (Just okRows) okTime mempty
|
|
||||||
((E.Value False, E.Value badRows, E.Value badTime):_) -> do
|
|
||||||
lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
|
||||||
writeAvsSynchStats Nothing lastOk =<< mkBadInfo badRows badTime
|
|
||||||
_ -> return ()
|
|
||||||
|
|
||||||
let
|
|
||||||
flagOld = flagError . (cutOffOldTime <)
|
|
||||||
resultDBTable = DBTable{..}
|
|
||||||
where
|
|
||||||
resultILog :: Lens' (DBRow (Entity InterfaceLog)) InterfaceLog
|
|
||||||
resultILog = _dbrOutput . _entityVal
|
|
||||||
dbtSQLQuery = return
|
|
||||||
dbtRowKey = (E.^. InterfaceLogId)
|
|
||||||
dbtProj = dbtProjId
|
|
||||||
dbtColonnade = dbColonnade $ mconcat
|
|
||||||
[ sortable Nothing (textCell "Status" ) $ wgtCell . flagOld . view (resultILog . _interfaceLogTime)
|
|
||||||
, sortable (Just "interface") (textCell "Interface" ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
|
|
||||||
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype)
|
|
||||||
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
|
|
||||||
, sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
|
|
||||||
, sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
|
|
||||||
, sortable Nothing (textCell "Info" ) $ \(view resultILog -> ilt) -> case ilt of
|
|
||||||
InterfaceLog "AVS" "Synch" True _ _ i -> anchorCell ProblemAvsErrorR $ toWgt i
|
|
||||||
InterfaceLog _ _ _ _ _ i -> textCell i
|
|
||||||
]
|
|
||||||
dbtSorting = mconcat
|
|
||||||
[ singletonMap "interface" $ SortColumn (E.^. InterfaceLogInterface)
|
|
||||||
, singletonMap "subtype" $ SortColumn (E.^. InterfaceLogSubtype)
|
|
||||||
, singletonMap "write" $ SortColumn (E.^. InterfaceLogWrite)
|
|
||||||
, singletonMap "time" $ SortColumn (E.^. InterfaceLogTime)
|
|
||||||
, singletonMap "rows" $ SortColumn (E.^. InterfaceLogRows)
|
|
||||||
]
|
|
||||||
dbtFilter = mempty
|
|
||||||
dbtFilterUI = mempty
|
|
||||||
dbtStyle = def
|
|
||||||
dbtIdent = "interface-log" :: Text
|
|
||||||
dbtParams = def
|
|
||||||
dbtCsvEncode = noCsvEncode
|
|
||||||
dbtCsvDecode = Nothing
|
|
||||||
dbtExtraReps = []
|
|
||||||
resultDBTableValidator = def
|
|
||||||
& defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
|
|
||||||
dbTable resultDBTableValidator resultDBTable
|
|
||||||
@ -279,8 +279,8 @@ getCourseNewR = do
|
|||||||
, E.desc $ courseCreated course] -- most recent created course
|
, E.desc $ courseCreated course] -- most recent created course
|
||||||
E.limit 1
|
E.limit 1
|
||||||
return course
|
return course
|
||||||
template <- case listToMaybe oldCourses of
|
template <- case oldCourses of
|
||||||
(Just oldTemplate) ->
|
(oldTemplate:_) ->
|
||||||
let newTemplate = courseToForm oldTemplate mempty mempty in
|
let newTemplate = courseToForm oldTemplate mempty mempty in
|
||||||
return $ Just $ newTemplate
|
return $ Just $ newTemplate
|
||||||
{ cfCourseId = Nothing
|
{ cfCourseId = Nothing
|
||||||
@ -289,7 +289,7 @@ getCourseNewR = do
|
|||||||
, cfRegTo = Nothing
|
, cfRegTo = Nothing
|
||||||
, cfDeRegUntil = Nothing
|
, cfDeRegUntil = Nothing
|
||||||
}
|
}
|
||||||
Nothing -> do
|
[] -> do
|
||||||
(tidOk,sshOk,cshOk) <- runDB $ (,,)
|
(tidOk,sshOk,cshOk) <- runDB $ (,,)
|
||||||
<$> ifMaybeM mbTid True existsKey
|
<$> ifMaybeM mbTid True existsKey
|
||||||
<*> ifMaybeM mbSsh True existsKey
|
<*> ifMaybeM mbSsh True existsKey
|
||||||
|
|||||||
@ -226,7 +226,16 @@ getCourseListR = do
|
|||||||
]
|
]
|
||||||
validator = def
|
validator = def
|
||||||
& defaultSorting [SortDescBy "term",SortAscBy "course"]
|
& defaultSorting [SortDescBy "term",SortAscBy "course"]
|
||||||
coursesTable <- runDB $ makeCourseTable colonnade validator
|
now <- liftIO getCurrentTime
|
||||||
|
coursesTable <- runDB $ do
|
||||||
|
activeTs <- selectList [TermActiveFrom <=. now
|
||||||
|
, FilterOr [TermActiveTo >. Just now, TermActiveTo ==. Nothing]
|
||||||
|
, FilterOr [TermActiveFor ==. muid, TermActiveFor ==. Nothing] -- TermActiveFor <-. [Nothing, muid] did not work as intended
|
||||||
|
] [Desc TermActiveTerm]
|
||||||
|
let addTermFilter = if null activeTs
|
||||||
|
then id
|
||||||
|
else defaultFilter $ singletonMap "term" [toPathPiece termActiveTerm | Entity _ TermActive{termActiveTerm} <- activeTs]
|
||||||
|
makeCourseTable colonnade (validator & addTermFilter)
|
||||||
defaultLayout $ do
|
defaultLayout $ do
|
||||||
setTitleI MsgCourseListTitle
|
setTitleI MsgCourseListTitle
|
||||||
$(widgetFile "courses")
|
$(widgetFile "courses")
|
||||||
|
|||||||
@ -192,26 +192,37 @@ handleAddUserR tid ssh csh tdesc ttyp = do
|
|||||||
|
|
||||||
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
|
currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute
|
||||||
|
|
||||||
confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
|
(_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm
|
||||||
-- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
|
-- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult
|
||||||
unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
|
prefillUsers <- case registerConfirmResult of
|
||||||
let
|
Nothing -> return mempty
|
||||||
users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
|
(Just BtnCourseRegisterAbort) -> do
|
||||||
tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
|
addMessageI Warning MsgAborted
|
||||||
actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!
|
-- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome
|
||||||
registeredUsers <- registerUsers cid users
|
confirmedActs :: [CourseRegisterActionData] <- exceptT (const $ return mempty) return . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction -- ignore any exception, since it is only used to prefill a form field for convenience
|
||||||
whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
|
return $ Just $ Set.fromList $ fmap crActIdent confirmedActs
|
||||||
whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
|
(Just BtnCourseRegisterConfirm) -> do
|
||||||
tutId <- upsertNewTutorial cid tName tutType tutDay
|
confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction
|
||||||
registerTutorialMembers tutId registeredUsers
|
-- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs
|
||||||
-- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point
|
unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs
|
||||||
redirect $ CTutorialR tid ssh csh tName TUsersR
|
let
|
||||||
redirect $ CourseR tid ssh csh CUsersR
|
users = Map.fromList . fmap (\act -> (crActIdent act, Just . view _1 $ crActUser act)) $ Set.toList confirmedActs
|
||||||
|
tutActs = Set.filter (is _CourseRegisterActionAddTutorialMemberData) confirmedActs
|
||||||
|
actTutorial = crActTutorial <$> Set.lookupMin tutActs -- tutorial ident must be the same for every added member!
|
||||||
|
registeredUsers <- registerUsers cid users
|
||||||
|
whenIsJust actTutorial $ \(tutName,tutType,tutDay) -> do
|
||||||
|
whenIsJust (tutName <|> fmap (tutorialDefaultName tutType) tutDay) $ \tName -> do
|
||||||
|
tutId <- upsertNewTutorial cid tName tutType tutDay
|
||||||
|
registerTutorialMembers tutId registeredUsers
|
||||||
|
-- when (Set.size tutActs == Set.size confirmedActs) $ -- not sure how this condition might be false at this point
|
||||||
|
redirect $ CTutorialR tid ssh csh tName TUsersR
|
||||||
|
redirect $ CourseR tid ssh csh CUsersR
|
||||||
|
return mempty
|
||||||
|
|
||||||
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . renderWForm FormStandard $ do
|
((usersToAdd :: FormResult AddUserRequest, formWgt), formEncoding) <- runFormPost . identifyForm FIDCourseRegister . renderWForm FormStandard $ do
|
||||||
let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes]
|
let tutTypesMsg = [(SomeMessage tt,tt) | tt <- tutTypes]
|
||||||
tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)
|
tutDefType = ttyp >>= (\ty -> if ty `elem` tutTypes then Just ty else Nothing)
|
||||||
auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) mempty
|
auReqUsers <- wreq (textField & cfAnySeparatedSet) (fslI MsgCourseParticipantsRegisterUsersField & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) prefillUsers
|
||||||
auReqTutorial <- optionalActionW
|
auReqTutorial <- optionalActionW
|
||||||
( (,,)
|
( (,,)
|
||||||
<$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
|
<$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions)
|
||||||
|
|||||||
251
src/Handler/Health/Interface.hs
Normal file
251
src/Handler/Health/Interface.hs
Normal file
@ -0,0 +1,251 @@
|
|||||||
|
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||||
|
--
|
||||||
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
|
||||||
|
module Handler.Health.Interface
|
||||||
|
(
|
||||||
|
getHealthInterfaceR
|
||||||
|
, mkInterfaceLogTable
|
||||||
|
, runInterfaceChecks
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Import
|
||||||
|
|
||||||
|
-- import qualified Data.Set as Set
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import Handler.Utils
|
||||||
|
import Handler.Utils.Concurrent
|
||||||
|
|
||||||
|
-- import Database.Esqueleto.Experimental ((:&)(..))
|
||||||
|
import qualified Database.Esqueleto.Experimental as E
|
||||||
|
import qualified Database.Esqueleto.Utils as E
|
||||||
|
import qualified Database.Esqueleto.Legacy as EL (on)
|
||||||
|
import qualified Database.Persist.Sql as E (deleteWhereCount)
|
||||||
|
|
||||||
|
|
||||||
|
-- | identify a wildcard argument
|
||||||
|
wc2null :: Text -> Maybe Text
|
||||||
|
-- wc2null "." = Nothing -- does not work, since dots are eliminated in URLs
|
||||||
|
-- wc2null "-" = Nothing -- used as wildcard subtype in lpr interface
|
||||||
|
wc2null "_" = Nothing
|
||||||
|
wc2null "*" = Nothing
|
||||||
|
wc2null o = Just o
|
||||||
|
|
||||||
|
-- | sloppily parse a boolean, also see Model.Types.Avs.SloppyBool
|
||||||
|
pbool :: Text -> Maybe Bool
|
||||||
|
pbool (Text.toLower . Text.strip -> w)
|
||||||
|
| w `elem` ["1", "t", "true" ,"wahr", "w"] = Just True
|
||||||
|
| w `elem` ["0", "f", "false","falsch"] = Just False
|
||||||
|
| otherwise = Nothing
|
||||||
|
|
||||||
|
-- | parse UniqueInterfaceHealth with subtype and write arguments being optional for the last interface. Wildcards '_' or '.' are also allowed in all places.
|
||||||
|
identifyInterfaces :: [Text] -> [Unique InterfaceHealth]
|
||||||
|
identifyInterfaces [] = []
|
||||||
|
identifyInterfaces [i] = [UniqueInterfaceHealth i Nothing Nothing]
|
||||||
|
identifyInterfaces [i,s] = [UniqueInterfaceHealth i (wc2null s) Nothing]
|
||||||
|
identifyInterfaces (i:s:w:r) = UniqueInterfaceHealth i (wc2null s) (pbool w) : identifyInterfaces r
|
||||||
|
|
||||||
|
type ReqBanInterfaceHealth = ([Unique InterfaceHealth],[Unique InterfaceHealth])
|
||||||
|
|
||||||
|
-- | Interface names prefixed with '-' are to be excluded from the query
|
||||||
|
splitInterfaces :: [Unique InterfaceHealth] -> ReqBanInterfaceHealth
|
||||||
|
splitInterfaces = foldl' aux mempty
|
||||||
|
where
|
||||||
|
aux (reqs,bans) uih@(UniqueInterfaceHealth i s w)
|
||||||
|
| Just ('-', b) <- Text.uncons i = (reqs, UniqueInterfaceHealth b s w : bans)
|
||||||
|
| otherwise = (uih : reqs, bans)
|
||||||
|
|
||||||
|
-- | check whether the first argument is equal or more specialzed (i.e. more Just) than the second
|
||||||
|
matchesUniqueInterfaceHealth :: Unique InterfaceHealth -> Unique InterfaceHealth -> Bool
|
||||||
|
matchesUniqueInterfaceHealth (UniqueInterfaceHealth ai as aw) (UniqueInterfaceHealth bi bs bw) = ai == bi && eqOrNothing as bs && eqOrNothing aw bw
|
||||||
|
where
|
||||||
|
eqOrNothing _ Nothing = True
|
||||||
|
eqOrNothing a b = a == b
|
||||||
|
|
||||||
|
|
||||||
|
getHealthInterfaceR :: [Text] -> Handler TypedContent
|
||||||
|
getHealthInterfaceR (dropWhile (=="force") -> ris) = do -- for backwards compatibility we ignore leading "force"
|
||||||
|
let interfs = splitInterfaces $ identifyInterfaces ris
|
||||||
|
(missing, allok, res, iltable) <- runInterfaceLogTable interfs
|
||||||
|
when missing notFound -- send 404 if any requested interface was not found
|
||||||
|
let ihstatus = if allok then status200
|
||||||
|
else internalServerError500
|
||||||
|
plainMsg = if allok then "Interfaces are healthy."
|
||||||
|
else "Unhealthy interfaces: " <> Text.intercalate ", " [iface | (iface, False) <- res]
|
||||||
|
sendResponseStatus ihstatus <=< selectRep $ do -- most browsers send accept:text/html, thus text/plain can be default here
|
||||||
|
provideRep . return . RepPlain $ toContent plainMsg -- /?_accept=text/plain
|
||||||
|
provideRep . siteLayoutMsg MsgMenuHealthInterface $ do -- /?_accept=text/html
|
||||||
|
setTitleI MsgMenuHealthInterface
|
||||||
|
[whamlet|
|
||||||
|
<div>
|
||||||
|
#{plainMsg}
|
||||||
|
<div>
|
||||||
|
^{iltable}
|
||||||
|
|]
|
||||||
|
|
||||||
|
|
||||||
|
runInterfaceLogTable :: ReqBanInterfaceHealth -> Handler (Bool, Bool, [(Text,Bool)], Widget)
|
||||||
|
runInterfaceLogTable interfs@(reqIfs,_) = do
|
||||||
|
-- we abuse messageTooltip for colored icons here
|
||||||
|
msgSuccessTooltip <- messageI Success MsgMessageSuccess
|
||||||
|
-- msgWarningTooltip <- messageI Warning MsgMessageWarning
|
||||||
|
msgErrorTooltip <- messageI Error MsgMessageError
|
||||||
|
let flagError = messageTooltip . bool msgErrorTooltip msgSuccessTooltip
|
||||||
|
(res, twgt) <- runDB $ mkInterfaceLogTable flagError interfs
|
||||||
|
let missing = notNull [ifce | (UniqueInterfaceHealth ifce _subt _writ) <- reqIfs, ifce `notElem` (fst <$> res) ]
|
||||||
|
allok = all snd res
|
||||||
|
return (missing, allok, res, twgt)
|
||||||
|
|
||||||
|
-- ihDebugShow :: Unique InterfaceHealth -> Text
|
||||||
|
-- ihDebugShow (UniqueInterfaceHealth i s w) = "(" <> tshow i <> "," <> tshow s <> "," <> tshow w <> ")"
|
||||||
|
|
||||||
|
mkInterfaceLogTable :: (Bool -> Widget) -> ReqBanInterfaceHealth -> DB ([(Text,Bool)], Widget)
|
||||||
|
mkInterfaceLogTable flagError interfs@(reqIfs, banIfs) = do
|
||||||
|
-- $logWarnS "DEBUG" $ tshow ([ihDebugShow x | x<- reqIfs], [ihDebugShow x | x<- banIfs])
|
||||||
|
void $ liftHandler $ timeoutHandler 42000001 $ runDB $ runInterfaceChecks interfs
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
dbTableDB ilvalidator DBTable{dbtColonnade=colonnade now, ..}
|
||||||
|
where
|
||||||
|
sanitize = text2AlphaNumPlus ['+','-','_','Ä','Ö','Ü','ß','ä','ö','ü']
|
||||||
|
dbtIdent = "interface-log" :: Text
|
||||||
|
dbtProj = dbtProjId
|
||||||
|
dbtSQLQuery (ilog `E.LeftOuterJoin` ihealth) = do
|
||||||
|
EL.on ( ilog E.^. InterfaceLogInterface E.=?. ihealth E.?. InterfaceHealthInterface
|
||||||
|
E.&&. ilog E.^. InterfaceLogSubtype E.=~. E.joinV (ihealth E.?. InterfaceHealthSubtype)
|
||||||
|
E.&&. ilog E.^. InterfaceLogWrite E.=~. E.joinV (ihealth E.?. InterfaceHealthWrite )
|
||||||
|
)
|
||||||
|
let matchUIH crits = E.or
|
||||||
|
[ E.and $ catMaybes
|
||||||
|
[ ilog E.^. InterfaceLogInterface E.==. E.val (sanitize ifce) & Just
|
||||||
|
, (ilog E.^. InterfaceLogSubtype E.==.) . E.val . sanitize <$> subt
|
||||||
|
, (ilog E.^. InterfaceLogWrite E.==.) . E.val <$> writ
|
||||||
|
]
|
||||||
|
| (UniqueInterfaceHealth ifce subt writ) <- crits
|
||||||
|
]
|
||||||
|
matchUIHnot crits = E.and
|
||||||
|
[ E.or $ catMaybes
|
||||||
|
[ ilog E.^. InterfaceLogInterface E.!=. E.val (sanitize ifce) & Just
|
||||||
|
, (ilog E.^. InterfaceLogSubtype E.!=.) . E.val . sanitize <$> subt
|
||||||
|
, (ilog E.^. InterfaceLogWrite E.!=.) . E.val <$> writ
|
||||||
|
]
|
||||||
|
| (UniqueInterfaceHealth ifce subt writ) <- crits
|
||||||
|
]
|
||||||
|
unless (null reqIfs) $ E.where_ $ matchUIH reqIfs
|
||||||
|
unless (null banIfs) $ E.where_ $ matchUIHnot banIfs
|
||||||
|
-- unless (null banIfs) $ E.where_ $ E.not_ $ matchUIH banIfs -- !!! DOES NOT WORK !!! Yields strange results, see #155
|
||||||
|
-- unless (null banIfs) $ E.where_ $ E.not_ $ E.parens $ matchUIH banIfs -- WORKS OKAY
|
||||||
|
-- E.where_ $ E.not_ (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- BAD All missing, except for "Printer" "F"
|
||||||
|
-- E.where_ $ E.not_ $ E.parens (ilog E.^. InterfaceLogInterface E.==. E.val "LMS" E.&&. ilog E.^. InterfaceLogSubtype E.==. E.val (sanitize "F")) -- WORKS OKAY
|
||||||
|
-- E.where_ $ ilog E.^. InterfaceLogInterface E.!=. E.val "LMS" E.||. ilog E.^. InterfaceLogSubtype E.!=. E.val (sanitize "F") -- WORKS OKAY
|
||||||
|
let ihour = E.coalesceDefault [ihealth E.?. InterfaceHealthHours] (E.val $ 3 * 24) -- if no default time is set, use 3 days instead
|
||||||
|
return (ilog, ihour)
|
||||||
|
|
||||||
|
queryILog :: (E.SqlExpr (Entity InterfaceLog) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity InterfaceHealth))) -> E.SqlExpr (Entity InterfaceLog)
|
||||||
|
queryILog = $(E.sqlLOJproj 2 1)
|
||||||
|
resultILog :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) InterfaceLog
|
||||||
|
resultILog = _dbrOutput . _1 . _entityVal
|
||||||
|
resultHours :: Lens' (DBRow (Entity InterfaceLog, E.Value Int)) Int
|
||||||
|
resultHours = _dbrOutput . _2 . E._unValue
|
||||||
|
|
||||||
|
dbtRowKey = queryILog >>> (E.^.InterfaceLogId)
|
||||||
|
colonnade now = mconcat
|
||||||
|
[ sortable Nothing (i18nCell MsgInterfaceStatus) $ \row -> -- do
|
||||||
|
let hours = row ^. resultHours
|
||||||
|
-- defmsg = row ^? resultErrMsg
|
||||||
|
logtime = row ^. resultILog . _interfaceLogTime
|
||||||
|
success = row ^. resultILog . _interfaceLogSuccess
|
||||||
|
iface = row ^. resultILog . _interfaceLogInterface
|
||||||
|
status = success && now <= addHours hours logtime
|
||||||
|
in tellCell [(iface,status)] $
|
||||||
|
wgtCell $ flagError status
|
||||||
|
, sortable (Just "interface") (i18nCell MsgInterfaceName ) $ \(view (resultILog . _interfaceLogInterface) -> n) -> textCell n
|
||||||
|
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype ) $ textCell . view (resultILog . _interfaceLogSubtype)
|
||||||
|
, sortable (Just "write") (i18nCell MsgInterfaceWrite ) $ (`ifIconCell` IconEdit) . view (resultILog . _interfaceLogWrite)
|
||||||
|
, sortable (Just "time") (i18nCell MsgInterfaceLastSynch ) $ dateTimeCell . view (resultILog . _interfaceLogTime)
|
||||||
|
, sortable Nothing (i18nCell MsgInterfaceFreshness ) $ numCell . view resultHours
|
||||||
|
, sortable (Just "rows") (i18nCell MsgTableRows ) $ cellMaybe numCell . view (resultILog . _interfaceLogRows)
|
||||||
|
, sortable (Just "success") (i18nCell MsgInterfaceSuccess ) $ \(view (resultILog . _interfaceLogSuccess) -> s) -> iconBoolCell s
|
||||||
|
, sortable Nothing (i18nCell MsgInterfaceInfo ) $ \(view resultILog -> ilt) -> case ilt of
|
||||||
|
InterfaceLog "AVS" "Synch" True _ _ i _ -> anchorCell ProblemAvsErrorR $ toWgt $ bool i "AVS-Log" $ null i
|
||||||
|
InterfaceLog "LPR" _ _ _ _ i _ -> anchorCell PrintLogR $ toWgt $ bool i "LPR-Log" $ null i
|
||||||
|
InterfaceLog _ _ _ _ _ i _ -> textCell i
|
||||||
|
]
|
||||||
|
|
||||||
|
dbtSorting = mconcat
|
||||||
|
[ singletonMap "interface" $ SortColumn $ queryILog >>> (E.^. InterfaceLogInterface)
|
||||||
|
, singletonMap "subtype" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSubtype)
|
||||||
|
, singletonMap "write" $ SortColumn $ queryILog >>> (E.^. InterfaceLogWrite)
|
||||||
|
, singletonMap "time" $ SortColumn $ queryILog >>> (E.^. InterfaceLogTime)
|
||||||
|
, singletonMap "rows" $ SortColumn $ queryILog >>> (E.^. InterfaceLogRows)
|
||||||
|
, singletonMap "success" $ SortColumn $ queryILog >>> (E.^. InterfaceLogSuccess)
|
||||||
|
]
|
||||||
|
ilvalidator = def & defaultSorting [SortAscBy "interface", SortAscBy "subtype", SortAscBy "write"]
|
||||||
|
dbtFilter = mempty
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
dbtStyle = def
|
||||||
|
dbtParams = def
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
dbtExtraReps = []
|
||||||
|
|
||||||
|
|
||||||
|
-- | runs additional checks and logs results within InterfaceLogTable; assumed to executable within a handler call
|
||||||
|
runInterfaceChecks :: ReqBanInterfaceHealth -> DB ()
|
||||||
|
runInterfaceChecks interfs = do
|
||||||
|
avsInterfaceCheck interfs
|
||||||
|
lprAckCheck interfs
|
||||||
|
|
||||||
|
maybeRunCheck :: ReqBanInterfaceHealth -> Unique InterfaceHealth -> (UTCTime -> DB ()) -> DB ()
|
||||||
|
maybeRunCheck (reqIfs,banIfs) uih act
|
||||||
|
| null reqIfs || any (matchesUniqueInterfaceHealth uih) reqIfs
|
||||||
|
, null banIfs || not (any (matchesUniqueInterfaceHealth uih) banIfs) = do
|
||||||
|
mih <- getBy uih
|
||||||
|
whenIsJust mih $ \eih -> do
|
||||||
|
now <- liftIO getCurrentTime
|
||||||
|
act $ addHours (negate $ interfaceHealthHours $ entityVal eih) now
|
||||||
|
| otherwise = return ()
|
||||||
|
|
||||||
|
|
||||||
|
lprAckCheck :: ReqBanInterfaceHealth -> DB ()
|
||||||
|
lprAckCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "Printer" (Just "Acknowledge") (Just True)) $ \cutOffOldTime -> do
|
||||||
|
unproc <- selectList [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. False] []
|
||||||
|
if notNull unproc
|
||||||
|
then mkLog False (Just $ length unproc) "Long unprocessed APC-Idents exist"
|
||||||
|
else do
|
||||||
|
oks <- E.deleteWhereCount [PrintAcknowledgeTimestamp <. cutOffOldTime, PrintAcknowledgeProcessed ==. True]
|
||||||
|
if oks > 0
|
||||||
|
then mkLog True (Just $ fromIntegral oks) "Long processed APC-Idents removed"
|
||||||
|
else mkLog True Nothing mempty
|
||||||
|
where
|
||||||
|
mkLog = logInterface' "Printer" "Acknowledge" True
|
||||||
|
|
||||||
|
|
||||||
|
avsInterfaceCheck :: ReqBanInterfaceHealth -> DB ()
|
||||||
|
avsInterfaceCheck interfs = maybeRunCheck interfs (UniqueInterfaceHealth "AVS" (Just "Synch") (Just True)) $ \cutOffOldTime -> do
|
||||||
|
avsSynchStats <- E.select $ do
|
||||||
|
uavs <- E.from $ E.table @UserAvs
|
||||||
|
E.where_ $ uavs E.^. UserAvsLastSynch E.>. E.val cutOffOldTime
|
||||||
|
let isOk = E.isNothing (uavs E.^. UserAvsLastSynchError)
|
||||||
|
E.groupBy isOk
|
||||||
|
E.orderBy [E.descNullsLast isOk]
|
||||||
|
return (isOk, E.countRows, E.max_ $ uavs E.^. UserAvsLastSynch)
|
||||||
|
let
|
||||||
|
mkBadInfo badRows (fromMaybe cutOffOldTime -> badTime) | badRows > 0 = do
|
||||||
|
fmtCut <- formatTime SelFormatDate cutOffOldTime
|
||||||
|
fmtBad <- formatTime SelFormatDateTime badTime
|
||||||
|
return $ tshow badRows <> " Fehler seit " <> fmtCut <> ", zuletzt um " <> fmtBad
|
||||||
|
mkBadInfo _ _ = return mempty
|
||||||
|
writeAvsSynchStats okRows badInfo =
|
||||||
|
logInterface' "AVS" "Synch" True (null badInfo) okRows badInfo
|
||||||
|
--case $(unValueN 3) <$> avsSynchStats of
|
||||||
|
case avsSynchStats of
|
||||||
|
((E.Value True , E.Value okRows, E.Value _okTime):(E.Value False, E.Value badRows, E.Value badTime):_) ->
|
||||||
|
writeAvsSynchStats (Just okRows) =<< mkBadInfo badRows badTime
|
||||||
|
((E.Value True , E.Value okRows, E.Value _okTime):_) ->
|
||||||
|
writeAvsSynchStats (Just okRows) mempty
|
||||||
|
((E.Value False, E.Value badRows, E.Value badTime):_) ->
|
||||||
|
-- lastOk <- userAvsLastSynch . entityVal <<$>> selectFirst [UserAvsLastSynchError ==. Nothing] [Desc UserAvsLastSynch]
|
||||||
|
writeAvsSynchStats Nothing =<< mkBadInfo badRows badTime
|
||||||
|
_ -> return ()
|
||||||
@ -1,4 +1,4 @@
|
|||||||
-- SPDX-FileCopyrightText: 2022-2023 Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
|
-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@ifi.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
|
||||||
|
|
||||||
@ -13,12 +13,12 @@ import Data.Map ((!))
|
|||||||
import qualified Data.CaseInsensitive as CI
|
import qualified Data.CaseInsensitive as CI
|
||||||
import qualified Data.Set as Set
|
import qualified Data.Set as Set
|
||||||
|
|
||||||
import qualified Database.Esqueleto.Legacy as E
|
-- import qualified Database.Esqueleto.Legacy as E
|
||||||
import qualified Database.Esqueleto.Utils as E
|
-- import qualified Database.Esqueleto.Utils as E
|
||||||
|
|
||||||
import Development.GitRev
|
import Development.GitRev
|
||||||
|
|
||||||
import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..))
|
-- import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..))
|
||||||
|
|
||||||
import Yesod.Auth.Message(AuthMessage(..))
|
import Yesod.Auth.Message(AuthMessage(..))
|
||||||
|
|
||||||
@ -175,6 +175,7 @@ showFAQ :: ( MonadAP m
|
|||||||
, MonadThrow m
|
, MonadThrow m
|
||||||
)
|
)
|
||||||
=> Route UniWorX -> FAQItem -> m Bool
|
=> Route UniWorX -> FAQItem -> m Bool
|
||||||
|
showFAQ _ FAQLoginExpired = return True
|
||||||
showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId
|
showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId
|
||||||
showFAQ (AuthR _) FAQCampusCantLogin = return True
|
showFAQ (AuthR _) FAQCampusCantLogin = return True
|
||||||
showFAQ _ FAQCampusCantLogin = is _Nothing <$> maybeAuthId
|
showFAQ _ FAQCampusCantLogin = is _Nothing <$> maybeAuthId
|
||||||
@ -183,38 +184,20 @@ showFAQ _ FAQForgottenPassword = is _Nothing <$> maybeAuthId
|
|||||||
showFAQ _ FAQNotLecturerHowToCreateCourses
|
showFAQ _ FAQNotLecturerHowToCreateCourses
|
||||||
= and2M (is _Just <$> maybeAuthId)
|
= and2M (is _Just <$> maybeAuthId)
|
||||||
(not <$> hasWriteAccessTo CourseNewR)
|
(not <$> hasWriteAccessTo CourseNewR)
|
||||||
showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors
|
-- showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors
|
||||||
= and2M (is _Just <$> maybeAuthId)
|
-- = and2M (is _Just <$> maybeAuthId)
|
||||||
(or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR)
|
-- (or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR)
|
||||||
(hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR)
|
-- (hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR)
|
||||||
)
|
-- )
|
||||||
showFAQ (CExamR tid ssh csh examn _) FAQExamPoints
|
-- showFAQ _ _ = return False
|
||||||
= and2M (hasWriteAccessTo $ CExamR tid ssh csh examn EEditR)
|
|
||||||
noExamParts
|
|
||||||
where
|
|
||||||
noExamParts = liftHandler . runDB . E.selectNotExists . E.from $ \(examPart `E.InnerJoin` exam `E.InnerJoin` course) -> do
|
|
||||||
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
||||||
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
|
|
||||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
||||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
||||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
||||||
E.&&. exam E.^. ExamName E.==. E.val examn
|
|
||||||
showFAQ _ FAQInvalidCredentialsAdAccountDisabled = maybeT (return False) $ do
|
|
||||||
guardM $ is _Nothing <$> maybeAuthId
|
|
||||||
sessionError <- MaybeT $ lookupSessionJson SessionError
|
|
||||||
guard $ sessionError == PermissionDenied (toPathPiece $ ADInvalidCredentials ADAccountDisabled)
|
|
||||||
return True
|
|
||||||
showFAQ _ _ = return False
|
|
||||||
|
|
||||||
prioFAQ :: Monad m
|
prioFAQ :: Monad m
|
||||||
=> Route UniWorX -> FAQItem -> m Rational
|
=> Route UniWorX -> FAQItem -> m Rational
|
||||||
|
prioFAQ _ FAQLoginExpired = return 2
|
||||||
prioFAQ _ FAQNoCampusAccount = return 1
|
prioFAQ _ FAQNoCampusAccount = return 1
|
||||||
prioFAQ _ FAQCampusCantLogin = return 1
|
prioFAQ _ FAQCampusCantLogin = return 1
|
||||||
prioFAQ _ FAQForgottenPassword = return 1
|
prioFAQ _ FAQForgottenPassword = return 1
|
||||||
prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1
|
prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1
|
||||||
prioFAQ _ FAQCourseCorrectorsTutors = return 1
|
|
||||||
prioFAQ _ FAQExamPoints = return 2
|
|
||||||
prioFAQ _ FAQInvalidCredentialsAdAccountDisabled = return 3
|
|
||||||
|
|
||||||
|
|
||||||
getInfoLecturerR :: Handler Html
|
getInfoLecturerR :: Handler Html
|
||||||
|
|||||||
@ -213,6 +213,6 @@ getLmsLearnersDirectR sid qsh = do
|
|||||||
$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
|
||||||
<* runDB (logInterface "LMS" (ciOriginal qsh) (Just nr) "")
|
<* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "")
|
||||||
-- 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
|
||||||
@ -294,8 +294,7 @@ postLmsReportUploadR sid qsh = do
|
|||||||
setTitleI MsgMenuLmsUpload
|
setTitleI MsgMenuLmsUpload
|
||||||
[whamlet|$newline never
|
[whamlet|$newline never
|
||||||
<form method=post enctype=#{enctype}>
|
<form method=post enctype=#{enctype}>
|
||||||
^{widget}
|
^{widget}
|
||||||
<p>
|
|
||||||
<input type=submit>
|
<input type=submit>
|
||||||
|]
|
|]
|
||||||
|
|
||||||
@ -315,12 +314,13 @@ postLmsReportDirectR sid qsh = do
|
|||||||
case enr of
|
case enr of
|
||||||
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
|
Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error
|
||||||
$logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
|
$logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e
|
||||||
|
logInterface "LMS" (ciOriginal qsh) False Nothing ""
|
||||||
return (badRequest400, "Exception: " <> tshow e)
|
return (badRequest400, "Exception: " <> tshow e)
|
||||||
Right nr -> do
|
Right nr -> do
|
||||||
let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
|
let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". "
|
||||||
$logInfoS "LMS" msg
|
$logInfoS "LMS" msg
|
||||||
when (nr > 0) $ queueDBJob $ JobLmsReports qid
|
when (nr > 0) $ queueDBJob $ JobLmsReports qid
|
||||||
logInterface "LMS" (ciOriginal qsh) (Just nr) ""
|
logInterface "LMS" (ciOriginal qsh) True (Just nr) ""
|
||||||
return (ok200, msg)
|
return (ok200, msg)
|
||||||
[] -> do
|
[] -> do
|
||||||
let msg = "Report upload file missing."
|
let msg = "Report upload file missing."
|
||||||
|
|||||||
@ -7,10 +7,11 @@
|
|||||||
|
|
||||||
module Handler.PrintCenter
|
module Handler.PrintCenter
|
||||||
( getPrintDownloadR
|
( getPrintDownloadR
|
||||||
, getPrintCenterR, postPrintCenterR
|
, getPrintCenterR, postPrintCenterR
|
||||||
, getPrintSendR , postPrintSendR
|
, getPrintSendR , postPrintSendR
|
||||||
, getPrintAckR , postPrintAckR
|
, getPrintAckR , postPrintAckR
|
||||||
, postPrintAckDirectR
|
, getPrintAckDirectR, postPrintAckDirectR
|
||||||
|
, getPrintLogR
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
@ -26,7 +27,7 @@ import Database.Esqueleto.Utils.TH
|
|||||||
|
|
||||||
import Utils.Print
|
import Utils.Print
|
||||||
|
|
||||||
-- import Data.Aeson (encode)
|
import qualified Data.Aeson as Aeson
|
||||||
-- import qualified Data.Text as Text
|
-- import qualified Data.Text as Text
|
||||||
-- import qualified Data.Set as Set
|
-- import qualified Data.Set as Set
|
||||||
|
|
||||||
@ -43,11 +44,11 @@ single :: (k,a) -> Map k a
|
|||||||
single = uncurry Map.singleton
|
single = uncurry Map.singleton
|
||||||
|
|
||||||
|
|
||||||
data LRQF = LRQF
|
data LRQF = LRQF
|
||||||
{ lrqfLetter :: Text
|
{ lrqfLetter :: Text
|
||||||
, lrqfUser :: Either UserEmail UserId
|
, lrqfUser :: Either UserEmail UserId
|
||||||
, lrqfSuper :: Maybe (Either UserEmail UserId)
|
, lrqfSuper :: Maybe (Either UserEmail UserId)
|
||||||
, lrqfQuali :: Entity Qualification
|
, lrqfQuali :: Entity Qualification
|
||||||
, lrqfIdent :: LmsIdent
|
, lrqfIdent :: LmsIdent
|
||||||
, lrqfPin :: Text
|
, lrqfPin :: Text
|
||||||
, lrqfExpiry :: Maybe Day
|
, lrqfExpiry :: Maybe Day
|
||||||
@ -62,12 +63,12 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRe
|
|||||||
<*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
|
<*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl)
|
||||||
<*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
|
<*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> tmpl)
|
||||||
<*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
|
<*> areq qualificationFieldEnt (fslI MsgQualificationName) (lrqfQuali <$> tmpl)
|
||||||
<*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
|
<*> areq lmsField (fslI MsgTableLmsIdent) (lrqfIdent <$> tmpl)
|
||||||
<*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl)
|
<*> areq textField (fslI MsgTableLmsPin) (lrqfPin <$> tmpl)
|
||||||
<*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl)
|
<*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl)
|
||||||
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)
|
<*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant)
|
||||||
(fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl)
|
(fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl)
|
||||||
where
|
where
|
||||||
lmsField = convertField LmsIdent getLmsIdent textField
|
lmsField = convertField LmsIdent getLmsIdent textField
|
||||||
|
|
||||||
validateLetterRenewQualificationF :: FormValidator LRQF Handler ()
|
validateLetterRenewQualificationF :: FormValidator LRQF Handler ()
|
||||||
@ -76,12 +77,12 @@ validateLetterRenewQualificationF = -- do
|
|||||||
return ()
|
return ()
|
||||||
|
|
||||||
lrqf2letter :: LRQF -> DB (Entity User, SomeLetter)
|
lrqf2letter :: LRQF -> DB (Entity User, SomeLetter)
|
||||||
lrqf2letter LRQF{..}
|
lrqf2letter LRQF{..}
|
||||||
| lrqfLetter == "r" = do
|
| lrqfLetter == "r" = do
|
||||||
usr <- getUser lrqfUser
|
usr <- getUser lrqfUser
|
||||||
rcvr <- mapM getUser lrqfSuper
|
rcvr <- mapM getUser lrqfSuper
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
let letter = LetterRenewQualificationF
|
let letter = LetterRenewQualificationF
|
||||||
{ lmsLogin = lrqfIdent
|
{ lmsLogin = lrqfIdent
|
||||||
, lmsPin = lrqfPin
|
, lmsPin = lrqfPin
|
||||||
, qualHolderID = usr ^. _entityKey
|
, qualHolderID = usr ^. _entityKey
|
||||||
@ -96,13 +97,13 @@ lrqf2letter LRQF{..}
|
|||||||
, isReminder = lrqfReminder
|
, isReminder = lrqfReminder
|
||||||
}
|
}
|
||||||
return (fromMaybe usr rcvr, SomeLetter letter)
|
return (fromMaybe usr rcvr, SomeLetter letter)
|
||||||
| lrqfLetter == "e" || lrqfLetter == "E" = do
|
| lrqfLetter == "e" || lrqfLetter == "E" = do
|
||||||
rcvr <- mapM getUser lrqfSuper
|
rcvr <- mapM getUser lrqfSuper
|
||||||
usr <- getUser lrqfUser
|
usr <- getUser lrqfUser
|
||||||
usrShrt <- encrypt $ entityKey usr
|
usrShrt <- encrypt $ entityKey usr
|
||||||
usrUuid <- encrypt $ entityKey usr
|
usrUuid <- encrypt $ entityKey usr
|
||||||
urender <- liftHandler getUrlRender
|
urender <- liftHandler getUrlRender
|
||||||
let letter = LetterExpireQualification
|
let letter = LetterExpireQualification
|
||||||
{ leqHolderCFN = usrShrt
|
{ leqHolderCFN = usrShrt
|
||||||
, leqHolderID = usr ^. _entityKey
|
, leqHolderID = usr ^. _entityKey
|
||||||
, leqHolderDN = usr ^. _userDisplayName
|
, leqHolderDN = usr ^. _userDisplayName
|
||||||
@ -111,15 +112,15 @@ lrqf2letter LRQF{..}
|
|||||||
, leqId = lrqfQuali ^. _entityKey
|
, leqId = lrqfQuali ^. _entityKey
|
||||||
, leqName = lrqfQuali ^. _qualificationName . _CI
|
, leqName = lrqfQuali ^. _qualificationName . _CI
|
||||||
, leqShort = lrqfQuali ^. _qualificationShorthand . _CI
|
, leqShort = lrqfQuali ^. _qualificationShorthand . _CI
|
||||||
, leqSchool = lrqfQuali ^. _qualificationSchool
|
, leqSchool = lrqfQuali ^. _qualificationSchool
|
||||||
, leqUrl = pure . urender $ ForProfileDataR usrUuid
|
, leqUrl = pure . urender $ ForProfileDataR usrUuid
|
||||||
}
|
}
|
||||||
return (fromMaybe usr rcvr, SomeLetter letter)
|
return (fromMaybe usr rcvr, SomeLetter letter)
|
||||||
| otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only."
|
| otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only."
|
||||||
where
|
where
|
||||||
getUser :: Either UserEmail UserId -> DB (Entity User)
|
getUser :: Either UserEmail UserId -> DB (Entity User)
|
||||||
getUser (Right uid) = getEntity404 uid
|
getUser (Right uid) = getEntity404 uid
|
||||||
getUser (Left mail) = getBy404 $ UniqueEmail mail
|
getUser (Left mail) = getBy404 $ UniqueEmail mail
|
||||||
|
|
||||||
|
|
||||||
data PJTableAction = PJActAcknowledge | PJActReprint
|
data PJTableAction = PJActAcknowledge | PJActReprint
|
||||||
@ -190,7 +191,7 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient
|
|||||||
return (printJob, recipient, sender, course, quali)
|
return (printJob, recipient, sender, course, quali)
|
||||||
|
|
||||||
mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
|
mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget)
|
||||||
mkPJTable = do
|
mkPJTable = do
|
||||||
let
|
let
|
||||||
dbtSQLQuery = pjTableQuery
|
dbtSQLQuery = pjTableQuery
|
||||||
dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
|
dbtRowKey = queryPrintJob >>> (E.^. PrintJobId)
|
||||||
@ -225,7 +226,7 @@ mkPJTable = do
|
|||||||
dbtFilter = mconcat
|
dbtFilter = mconcat
|
||||||
[ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName))
|
[ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName))
|
||||||
, single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent))
|
, single ("apcid" , FilterColumn . E.mkContainsFilterWithComma id $ views (to queryPrintJob) (E.^. PrintJobApcIdent))
|
||||||
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
|
, single ("filename" , FilterColumn . E.mkContainsFilter $ views (to queryPrintJob) (E.^. PrintJobFilename))
|
||||||
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
, single ("created" , FilterColumn . E.mkDayFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||||
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
--, single ("created" , FilterColumn . E.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated))
|
||||||
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
, single ("recipient" , FilterColumn . E.mkContainsFilterWithCommaPlus Just $ views (to queryRecipient) (E.?. UserDisplayName))
|
||||||
@ -233,7 +234,7 @@ mkPJTable = do
|
|||||||
, single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName))
|
, single ("course" , FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryCourse) (E.?. CourseName))
|
||||||
, single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName))
|
, single ("qualification", FilterColumn . E.mkContainsFilterWith (Just . CI.mk) $ views (to queryQualification) (E.?. QualificationName))
|
||||||
, single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
|
, single ("lmsid" , FilterColumn . E.mkContainsFilterWithCommaPlus (Just . LmsIdent) $ views (to queryPrintJob) (E.^. PrintJobLmsUser))
|
||||||
|
|
||||||
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
|
, single ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged)))
|
||||||
]
|
]
|
||||||
dbtFilterUI mPrev = mconcat
|
dbtFilterUI mPrev = mconcat
|
||||||
@ -288,7 +289,7 @@ mkPJTable = do
|
|||||||
|
|
||||||
getPrintCenterR, postPrintCenterR :: Handler Html
|
getPrintCenterR, postPrintCenterR :: Handler Html
|
||||||
getPrintCenterR = postPrintCenterR
|
getPrintCenterR = postPrintCenterR
|
||||||
postPrintCenterR = do
|
postPrintCenterR = do
|
||||||
(pjRes, pjTable) <- runDB mkPJTable
|
(pjRes, pjTable) <- runDB mkPJTable
|
||||||
|
|
||||||
formResult pjRes $ \case
|
formResult pjRes $ \case
|
||||||
@ -298,21 +299,21 @@ postPrintCenterR = do
|
|||||||
addMessageI Success $ MsgPrintJobAcknowledge num
|
addMessageI Success $ MsgPrintJobAcknowledge num
|
||||||
reloadKeepGetParams PrintCenterR
|
reloadKeepGetParams PrintCenterR
|
||||||
(PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do
|
(PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do
|
||||||
let countOk = either (const $ Sum 0) (const $ Sum 1)
|
let countOk = either (const $ Sum 0) (const $ Sum 1)
|
||||||
oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute)
|
oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF (fromMaybe False ignoreReroute)
|
||||||
let nr_oks = getSum $ mconcat oks
|
let nr_oks = getSum $ mconcat oks
|
||||||
nr_tot = length pjIds
|
nr_tot = length pjIds
|
||||||
mstat = bool Warning Success $ nr_oks == nr_tot
|
mstat = bool Warning Success $ nr_oks == nr_tot
|
||||||
addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot
|
addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot
|
||||||
reloadKeepGetParams PrintCenterR
|
reloadKeepGetParams PrintCenterR
|
||||||
siteConf <- getYesod
|
siteConf <- getYesod
|
||||||
let lprConf = siteConf ^. _appLprConf
|
let lprConf = siteConf ^. _appLprConf
|
||||||
reroute = siteConf ^. _appMailRerouteTo
|
reroute = siteConf ^. _appMailRerouteTo
|
||||||
lprWgt = [whamlet|
|
lprWgt = [whamlet|
|
||||||
LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf}
|
LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf}
|
||||||
<div>
|
<div>
|
||||||
$maybe _ <- reroute
|
$maybe _ <- reroute
|
||||||
Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt!
|
Mail-reroute-to ist gesetzt, somit werden alle lpr Kommandos unterdrückt!
|
||||||
|]
|
|]
|
||||||
siteLayoutMsg MsgMenuApc $ do
|
siteLayoutMsg MsgMenuApc $ do
|
||||||
setTitleI MsgMenuApc
|
setTitleI MsgMenuApc
|
||||||
@ -322,7 +323,7 @@ postPrintCenterR = do
|
|||||||
getPrintSendR, postPrintSendR :: Handler Html
|
getPrintSendR, postPrintSendR :: Handler Html
|
||||||
getPrintSendR = postPrintSendR
|
getPrintSendR = postPrintSendR
|
||||||
postPrintSendR = do
|
postPrintSendR = do
|
||||||
usr <- requireAuth -- to determine language and recipient for test
|
usr <- requireAuth -- to determine language and recipient for test
|
||||||
mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand]
|
mbQual <- runDB $ selectFirst [] [Asc QualificationAvsLicence, Asc QualificationShorthand]
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
let nowaday = utctDay now
|
let nowaday = utctDay now
|
||||||
@ -340,7 +341,7 @@ postPrintSendR = do
|
|||||||
def_lrqf = mkLetter <$> mbQual
|
def_lrqf = mkLetter <$> mbQual
|
||||||
|
|
||||||
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
|
((sendResult, sendWidget), sendEnctype) <- runFormPost $ makeRenewalForm def_lrqf
|
||||||
let procFormSend lrqf = case lrqfLetter lrqf of
|
let procFormSend lrqf = case lrqfLetter lrqf of
|
||||||
"E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case
|
"E" -> (runDB (lrqf2letter lrqf) >>= printHtml (Just uid)) >>= \case
|
||||||
Right html -> sendResponse $ toTypedContent html
|
Right html -> sendResponse $ toTypedContent html
|
||||||
Left err -> do
|
Left err -> do
|
||||||
@ -348,7 +349,7 @@ postPrintSendR = do
|
|||||||
$logErrorS "LPR" msg
|
$logErrorS "LPR" msg
|
||||||
addMessage Error $ toHtml msg
|
addMessage Error $ toHtml msg
|
||||||
pure ()
|
pure ()
|
||||||
_ -> do
|
_ -> do
|
||||||
ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case
|
ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case
|
||||||
Left err -> do
|
Left err -> do
|
||||||
let msg = "PDF printing failed with error: " <> err
|
let msg = "PDF printing failed with error: " <> err
|
||||||
@ -399,26 +400,26 @@ postPrintAckR ackDay numAck chksm = do
|
|||||||
, formSubmit = FormNoSubmit
|
, formSubmit = FormNoSubmit
|
||||||
}
|
}
|
||||||
formResult ackRes $ \BtnConfirm -> do
|
formResult ackRes $ \BtnConfirm -> do
|
||||||
numNew <- runDB $ do
|
numNew <- runDB $ do
|
||||||
pjs <- Ex.select $ do
|
pjs <- Ex.select $ do
|
||||||
pj <- Ex.from $ Ex.table @PrintJob
|
pj <- Ex.from $ Ex.table @PrintJob
|
||||||
let pjDay = E.day $ pj Ex.^. PrintJobCreated
|
let pjDay = E.day $ pj Ex.^. PrintJobCreated
|
||||||
Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
||||||
Ex.&&. (pjDay Ex.==. Ex.val ackDay)
|
Ex.&&. (pjDay Ex.==. Ex.val ackDay)
|
||||||
return $ pj Ex.^. PrintJobId
|
return $ pj Ex.^. PrintJobId
|
||||||
let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs))
|
let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs))
|
||||||
if changed
|
if changed
|
||||||
then return (-1)
|
then return (-1)
|
||||||
else do
|
else do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
E.updateCount $ \pj -> do
|
E.updateCount $ \pj -> do
|
||||||
let pjDay = E.day $ pj E.^. PrintJobCreated
|
let pjDay = E.day $ pj E.^. PrintJobCreated
|
||||||
E.set pj [ PrintJobAcknowledged E.=. E.justVal now ]
|
E.set pj [ PrintJobAcknowledged E.=. E.justVal now ]
|
||||||
E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
|
E.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged)
|
||||||
E.&&. (pjDay E.==. E.val ackDay)
|
E.&&. (pjDay E.==. E.val ackDay)
|
||||||
-- Ex.updateCount $ do
|
-- Ex.updateCount $ do
|
||||||
-- pj <- Ex.from $ Ex.table @PrintJob
|
-- pj <- Ex.from $ Ex.table @PrintJob
|
||||||
-- let pjDay = E.day $ pj Ex.^. PrintJobCreated
|
-- let pjDay = E.day $ pj Ex.^. PrintJobCreated
|
||||||
-- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ]
|
-- Ex.set pj [ PrintJobAcknowledged Ex.=. Ex.just (Ex.val now) ]
|
||||||
-- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
-- Ex.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged)
|
||||||
-- Ex.&&. (pjDay Ex.==. Ex.val ackDay)
|
-- Ex.&&. (pjDay Ex.==. Ex.val ackDay)
|
||||||
@ -427,29 +428,44 @@ postPrintAckR ackDay numAck chksm = do
|
|||||||
else addMessageI Error MsgPrintJobAcknowledgeFailed
|
else addMessageI Error MsgPrintJobAcknowledgeFailed
|
||||||
redirect PrintCenterR
|
redirect PrintCenterR
|
||||||
ackDayText <- formatTime SelFormatDate ackDay
|
ackDayText <- formatTime SelFormatDate ackDay
|
||||||
siteLayoutMsg
|
siteLayoutMsg
|
||||||
(MsgPrintJobAcknowledgeQuestion numAck ackDayText)
|
(MsgPrintJobAcknowledgeQuestion numAck ackDayText)
|
||||||
ackForm
|
ackForm
|
||||||
|
|
||||||
-- no header csv, containing a single column of lms identifiers (logins)
|
-- no header csv, containing a single column of lms identifiers (logins)
|
||||||
-- instance Csv.FromRecord LmsIdent -- default suffices
|
-- instance Csv.FromRecord LmsIdent -- default suffices
|
||||||
-- instance Csv.FromRecord Text where
|
-- instance Csv.FromRecord Text where
|
||||||
-- parseRecord v
|
-- parseRecord v
|
||||||
-- | length v >= 1 = v Csv..! 0
|
-- | length v >= 1 = v Csv..! 0
|
||||||
-- | otherwise = pure "ERROR"
|
-- | otherwise = pure "ERROR"
|
||||||
|
|
||||||
saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural
|
saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural
|
||||||
saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i)
|
saveApcident t i apci = insert_ (PrintAcknowledge apci t False) >> return (succ i)
|
||||||
|
|
||||||
|
|
||||||
|
makeAckUploadForm :: Form FileInfo
|
||||||
|
makeAckUploadForm = renderAForm FormStandard $ fileAFormReq "Acknowledge APC-Ident CSV"
|
||||||
|
|
||||||
|
getPrintAckDirectR :: Handler Html
|
||||||
|
getPrintAckDirectR = do
|
||||||
|
(widget, enctype) <- generateFormPost makeAckUploadForm
|
||||||
|
siteLayoutMsg MsgMenuPrintAck $ do
|
||||||
|
setTitleI MsgMenuPrintAck
|
||||||
|
[whamlet|$newline never
|
||||||
|
<form method=post enctype=#{enctype}>
|
||||||
|
^{widget}
|
||||||
|
<input type=submit>
|
||||||
|
|]
|
||||||
|
|
||||||
postPrintAckDirectR :: Handler Html
|
postPrintAckDirectR :: Handler Html
|
||||||
postPrintAckDirectR = do
|
postPrintAckDirectR = do
|
||||||
now <- liftIO getCurrentTime
|
now <- liftIO getCurrentTime
|
||||||
(_params, files) <- runRequestBody
|
(_params, files) <- runRequestBody
|
||||||
(status, msg) <- case files of
|
(status, msg) <- case files of
|
||||||
[(_fhead,file)] -> do
|
[(_fhead,file)] -> do
|
||||||
runDBJobs $ do
|
runDBJobs $ do
|
||||||
enr <- try $ runConduit $ fileSource file
|
enr <- try $ runConduit $ fileSource file
|
||||||
-- .| decodeCsvPositional Csv.NoHeader -- decode by separator position
|
-- .| decodeCsvPositional Csv.NoHeader -- decode by separator position
|
||||||
.| decodeUtf8C -- no CSV, just convert each line to a single text
|
.| decodeUtf8C -- no CSV, just convert each line to a single text
|
||||||
.| linesUnboundedC
|
.| linesUnboundedC
|
||||||
.| foldMC (saveApcident now) 0
|
.| foldMC (saveApcident now) 0
|
||||||
@ -461,7 +477,7 @@ postPrintAckDirectR = do
|
|||||||
let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later."
|
let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later."
|
||||||
$logInfoS "LMS" msg
|
$logInfoS "LMS" msg
|
||||||
when (nr > 0) $ queueDBJob JobPrintAck
|
when (nr > 0) $ queueDBJob JobPrintAck
|
||||||
return (ok200, msg)
|
return (ok200, msg)
|
||||||
[] -> do
|
[] -> do
|
||||||
let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging."
|
let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging."
|
||||||
$logWarnS "APC" msg
|
$logWarnS "APC" msg
|
||||||
@ -471,3 +487,55 @@ postPrintAckDirectR = do
|
|||||||
$logErrorS "APC" msg
|
$logErrorS "APC" msg
|
||||||
return (badRequest400, msg)
|
return (badRequest400, msg)
|
||||||
sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back
|
sendResponseStatus status msg -- must be outside of runDB; otherwise transaction is rolled back
|
||||||
|
|
||||||
|
|
||||||
|
getPrintLogR :: Handler Html
|
||||||
|
getPrintLogR = do
|
||||||
|
let
|
||||||
|
logDBTable = DBTable{..}
|
||||||
|
where
|
||||||
|
resultLog :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) TransactionLog
|
||||||
|
resultLog = _dbrOutput . _1
|
||||||
|
|
||||||
|
resultTrans :: Lens' (DBRow (TransactionLog, Aeson.Result Transaction)) (Aeson.Result Transaction)
|
||||||
|
resultTrans = _dbrOutput . _2
|
||||||
|
|
||||||
|
tCell' err c dbr = case view resultTrans dbr of
|
||||||
|
(Aeson.Error msg) -> err msg -- should not happen, due to query filter
|
||||||
|
(Aeson.Success t) -> c t
|
||||||
|
tCellErr = tCell' stringCell
|
||||||
|
tCell = tCell' $ const mempty
|
||||||
|
|
||||||
|
dbtIdent = "lpr-log" :: Text
|
||||||
|
dbtSQLQuery l = do
|
||||||
|
E.where_ $ E.val "LPR" E.==. l E.^. TransactionLogInfo E.->>. "interface-name"
|
||||||
|
-- E.&&. E.val "interface" E.==. l E.^. TransactionLogInfo E.->>. "transaction" -- not necessary
|
||||||
|
return l
|
||||||
|
dbtRowKey = (E.^. TransactionLogId)
|
||||||
|
dbtProj = dbtProjSimple $ \(Entity _ l) -> do
|
||||||
|
return (l, Aeson.fromJSON $ transactionLogInfo l)
|
||||||
|
dbtColonnade = dbColonnade $ mconcat
|
||||||
|
[ sortable (Just "time") (i18nCell MsgSystemMessageTimestamp) $ \(view $ resultLog . to transactionLogTime -> t) -> dateTimeCell t
|
||||||
|
, sortable (Just "status") (textCell "Status") $ tCell (cellMaybe iconBoolCell . transactionInterfaceSuccess)
|
||||||
|
, sortable (Just "subtype") (i18nCell MsgInterfaceSubtype) $ tCell ( textCell . transactionInterfaceSubtype)
|
||||||
|
, sortable (Just "info") (i18nCell MsgSystemMessageContent) $ tCellErr ( textCell . transactionInterfaceInfo)
|
||||||
|
]
|
||||||
|
dbtSorting = mconcat
|
||||||
|
[ singletonMap "time" $ SortColumn (E.^. TransactionLogTime)
|
||||||
|
, singletonMap "status" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-success")
|
||||||
|
, singletonMap "subtype" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-subtype")
|
||||||
|
, singletonMap "info" $ SortColumn (\r -> r E.^. TransactionLogTime E.->>. "interface-info" )
|
||||||
|
]
|
||||||
|
dbtFilter = mempty
|
||||||
|
dbtFilterUI = mempty
|
||||||
|
|
||||||
|
dbtStyle = def
|
||||||
|
dbtParams = def
|
||||||
|
dbtCsvEncode = noCsvEncode
|
||||||
|
dbtCsvDecode = Nothing
|
||||||
|
dbtExtraReps = []
|
||||||
|
validator = def & defaultSorting [ SortDescBy "time" ]
|
||||||
|
tbl <- runDB $ dbTableDB' validator logDBTable
|
||||||
|
siteLayoutMsg MsgMenuPrintLog $ do
|
||||||
|
setTitleI MsgMenuPrintLog
|
||||||
|
[whamlet|^{tbl}|]
|
||||||
|
|||||||
@ -150,7 +150,7 @@ getQualificationSAPDirectR = do
|
|||||||
msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
|
msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows"
|
||||||
quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers
|
quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers
|
||||||
$logInfoS "SAP" msg
|
$logInfoS "SAP" msg
|
||||||
let logInt = runDB $ logInterface "SAP" quals (Just nr) ""
|
let logInt = runDB $ logInterface "SAP" quals True (Just nr) ""
|
||||||
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\""
|
||||||
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
|
csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt
|
||||||
|
|
||||||
|
|||||||
@ -35,6 +35,8 @@ import Handler.Utils.Qualification as Handler.Utils
|
|||||||
|
|
||||||
import Handler.Utils.Term as Handler.Utils
|
import Handler.Utils.Term as Handler.Utils
|
||||||
|
|
||||||
|
-- import Handler.Utils.Concurrent as Handler.Utils -- only imported when needed
|
||||||
|
|
||||||
import Control.Monad.Logger
|
import Control.Monad.Logger
|
||||||
|
|
||||||
|
|
||||||
|
|||||||
38
src/Handler/Utils/Concurrent.hs
Normal file
38
src/Handler/Utils/Concurrent.hs
Normal file
@ -0,0 +1,38 @@
|
|||||||
|
-- SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||||
|
--
|
||||||
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
module Handler.Utils.Concurrent
|
||||||
|
( module Handler.Utils.Concurrent
|
||||||
|
) where
|
||||||
|
|
||||||
|
-- NOTE: use `retrySTM` and `checkSTM` instead of `retry` or `check`
|
||||||
|
|
||||||
|
import Import
|
||||||
|
import UnliftIO.Concurrent as Handler.Utils.Concurrent hiding (yield)
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
-- | Run a handler action until it finishes or if it exceeds a given number of microseconds via `registerDelay`
|
||||||
|
timeoutHandler :: Int -> HandlerFor site a -> HandlerFor site (Maybe a)
|
||||||
|
timeoutHandler maxWait act = do
|
||||||
|
innerAct <- handlerToIO
|
||||||
|
(hresult, tid) <- liftIO $ do
|
||||||
|
hresult <- newTVarIO Nothing
|
||||||
|
tid <- forkIO $ do
|
||||||
|
res <- innerAct act
|
||||||
|
atomically $ writeTVar hresult $ Just res
|
||||||
|
return (hresult, tid)
|
||||||
|
res <- liftIO $ do
|
||||||
|
flag <- registerDelay maxWait
|
||||||
|
atomically $ do
|
||||||
|
out <- readTVar flag
|
||||||
|
res <- readTVar hresult
|
||||||
|
checkSTM $ out || isJust res
|
||||||
|
return res
|
||||||
|
case res of
|
||||||
|
Nothing -> liftIO $ do
|
||||||
|
killThread tid
|
||||||
|
readTVarIO hresult -- read once more after kill to ensure that any result is noticed
|
||||||
|
_ -> return res
|
||||||
|
|
||||||
@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0
|
|||||||
toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
|
toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime
|
||||||
toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
|
toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..}
|
||||||
|
|
||||||
addHours :: Integer -> UTCTime -> UTCTime
|
addHours :: Integral n => n -> UTCTime -> UTCTime
|
||||||
addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600)
|
addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600)
|
||||||
|
|
||||||
instance HasLocalTime UTCTime where
|
instance HasLocalTime UTCTime where
|
||||||
toLocalTime = utcToLocalTime
|
toLocalTime = utcToLocalTime
|
||||||
|
|||||||
@ -115,7 +115,7 @@ csvFilenameLmsReport = makeLmsFilename "report"
|
|||||||
makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text
|
makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text
|
||||||
makeLmsFilename ftag (citext2lower -> qsh) = do
|
makeLmsFilename ftag (citext2lower -> qsh) = do
|
||||||
ymth <- getYMTH
|
ymth <- getYMTH
|
||||||
return $ "fradrive_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv"
|
return $ "fradrive_" <> "test" <> "_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv"
|
||||||
|
|
||||||
-- | Return current datetime in YYYYMMDDHH format
|
-- | Return current datetime in YYYYMMDDHH format
|
||||||
getYMTH :: MonadHandler m => m Text
|
getYMTH :: MonadHandler m => m Text
|
||||||
@ -203,8 +203,8 @@ randomText extra n = fmap pack . evalRandTIO . replicateM n $ uniform range
|
|||||||
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
|
-- eopt = Elo.genOptions -- { genCapitals = False, genSpecials = False, genDigitis = True }
|
||||||
|
|
||||||
randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent
|
randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent
|
||||||
randomLMSIdent Nothing = LmsIdent . Text.cons 'j' <$> randomText [] (pred lengthIdent) -- idents must not contain '_' nor '-'
|
randomLMSIdent Nothing = LmsIdent . Text.cons 't' . Text.cons 'j' <$> randomText [] (pred $ pred lengthIdent) -- idents must not contain '_' nor '-'
|
||||||
randomLMSIdent (Just c) = LmsIdent . Text.cons c <$> randomText [] (pred lengthIdent)
|
randomLMSIdent (Just c) = LmsIdent . Text.cons 't' . Text.cons c <$> randomText [] (pred $ pred lengthIdent)
|
||||||
|
|
||||||
randomLMSIdentBut :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent)
|
randomLMSIdentBut :: MonadIO m => Maybe Char -> Set LmsIdent -> m (Maybe LmsIdent)
|
||||||
randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
|
randomLMSIdentBut prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk
|
||||||
|
|||||||
@ -185,7 +185,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
|
|||||||
|
|
||||||
containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
|
containsAsSet x y = E.and . map (\y' -> x `E.hasInfix` E.val y') $ asWords y
|
||||||
|
|
||||||
toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
|
toSql user pl = bool id E.not__ (is _PLNegated pl) $ case pl ^. _plVar of
|
||||||
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
|
GuessUserMatrikelnummer userMatriculation' -> user E.^. UserMatrikelnummer E.==. E.val (Just userMatriculation')
|
||||||
GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName'
|
GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName'
|
||||||
GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname'
|
GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname'
|
||||||
|
|||||||
@ -47,7 +47,7 @@ import qualified Control.Monad.Catch as Exc
|
|||||||
|
|
||||||
import Data.Time.Zones
|
import Data.Time.Zones
|
||||||
|
|
||||||
import Control.Concurrent.STM (stateTVar, retry)
|
import Control.Concurrent.STM (stateTVar)
|
||||||
import Control.Concurrent.STM.Delay
|
import Control.Concurrent.STM.Delay
|
||||||
|
|
||||||
import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay)
|
import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay)
|
||||||
@ -260,7 +260,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc ->
|
|||||||
(nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan
|
(nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan
|
||||||
lift . lift $ writeTVar chan newQueue
|
lift . lift $ writeTVar chan newQueue
|
||||||
jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState
|
jobWorkers' <- lift . lift $ jobWorkers <$> readTMVar appJobState
|
||||||
receiver <- maybe (lift $ lift retry) return =<< uniformMay jobWorkers'
|
receiver <- maybe (lift $ lift retrySTM) return =<< uniformMay jobWorkers'
|
||||||
return (nextVal, receiver)
|
return (nextVal, receiver)
|
||||||
whenIsJust next $ \(nextVal, receiver) -> do
|
whenIsJust next $ \(nextVal, receiver) -> do
|
||||||
atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!)
|
atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!)
|
||||||
@ -373,8 +373,8 @@ execCrontab = do
|
|||||||
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
|
State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab
|
||||||
prevExec <- State.get
|
prevExec <- State.get
|
||||||
case earliestJob settings prevExec crontab refT of
|
case earliestJob settings prevExec crontab refT of
|
||||||
Nothing -> liftBase retry
|
Nothing -> liftBase retrySTM
|
||||||
Just (_, MatchNone) -> liftBase retry
|
Just (_, MatchNone) -> liftBase retrySTM
|
||||||
Just x -> return (crontab, x, prevExec)
|
Just x -> return (crontab, x, prevExec)
|
||||||
|
|
||||||
do
|
do
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
-- SPDX-FileCopyrightText: 2022-24 Steffen Jost <s.jost@fraport.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
|
||||||
--
|
--
|
||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
@ -117,7 +117,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act
|
|||||||
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
NotificationQualificationExpiry { nQualification = qid, nExpiry = uex }
|
||||||
}
|
}
|
||||||
forM_ renewalUsers (queueDBJob . usr_job)
|
forM_ renewalUsers (queueDBJob . usr_job)
|
||||||
logInterface "LMS" (qshort <> "-enq") (Just $ length renewalUsers) ""
|
logInterface "LMS" (qshort <> "-enq") True (Just $ length renewalUsers) ""
|
||||||
|
|
||||||
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX
|
||||||
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act
|
||||||
@ -202,7 +202,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
|||||||
-- 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, quser E.^. QualificationUserUser)
|
pure (luser E.?. LmsUserId, quser E.^. QualificationUserUser)
|
||||||
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
nrBlocked <- qualificationUserBlocking qid (E.unValue . snd <$> expiredUsers) False (Just now) (Right QualificationBlockExpired) True -- essential that blocks occur only once
|
||||||
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
|
let expiredLearners = [ luid | (E.Value (Just luid), _) <- expiredUsers ]
|
||||||
@ -223,7 +223,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
|||||||
`E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
|
`E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId
|
||||||
E.&&. qblock `isLatestBlockBefore` E.val now
|
E.&&. qblock `isLatestBlockBefore` E.val now
|
||||||
)
|
)
|
||||||
E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid
|
E.where_ $ -- E.not__ (validQualification now quser) -- currently invalid
|
||||||
quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
|
quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification
|
||||||
E.&&. quserToNotify now quser qblock -- recently became invalid or blocked
|
E.&&. quserToNotify now quser qblock -- recently became invalid or blocked
|
||||||
pure (quser E.^. QualificationUserUser)
|
pure (quser E.^. QualificationUserUser)
|
||||||
@ -259,7 +259,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act
|
|||||||
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
|
deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers]
|
||||||
-- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
|
-- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers]
|
||||||
deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
|
deleteWhere [LmsReportLogQualification ==. qid, LmsReportLogTimestamp <. auditCutoff ]
|
||||||
logInterface "LMS" (qshort <> "-deq") (Just nrBlocked) (tshow nrExpired <> " expired")
|
logInterface "LMS" (qshort <> "-deq") True (Just nrBlocked) (tshow nrExpired <> " expired")
|
||||||
|
|
||||||
|
|
||||||
dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
|
dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX
|
||||||
@ -313,7 +313,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act
|
|||||||
E.&&. lreport E.^. LmsReportLock E.==. E.true
|
E.&&. lreport E.^. LmsReportLock E.==. E.true
|
||||||
)
|
)
|
||||||
-- B) notify all newly reported users that lms is available
|
-- B) notify all newly reported users that lms is available
|
||||||
let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting
|
let luserFltrNew luser = E.isNothing (luser E.^. LmsUserReceived) -- not seen before, just starting
|
||||||
|
E.||. E.isNothing (luser E.^. LmsUserNotified) -- a previous notification has failed
|
||||||
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
|
notifyNewLearner (E.Value uid) = queueDBJob JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal { nQualification = qid, nReminder = False } }
|
||||||
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
|
in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner
|
||||||
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
|
-- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry
|
||||||
|
|||||||
@ -375,6 +375,8 @@ jobNoQueueSame = \case
|
|||||||
notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
|
notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame
|
||||||
notifyNoQueueSame = \case
|
notifyNoQueueSame = \case
|
||||||
NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged
|
NotificationQualificationRenewal{} -> Just JobNoQueueSame -- send one at once; safe, since the job is rescheduled if sending was not acknowledged
|
||||||
|
NotificationQualificationExpiry{} -> Just JobNoQueueSame -- do not send multiple expiry messages to the same person at once
|
||||||
|
NotificationQualificationExpired{} -> Just JobNoQueueSame
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
|
|
||||||
jobMovable :: JobCtl -> Bool
|
jobMovable :: JobCtl -> Bool
|
||||||
|
|||||||
@ -1,4 +1,4 @@
|
|||||||
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||||
--
|
--
|
||||||
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
@ -49,6 +49,7 @@ import qualified Data.Time.Zones as TZ
|
|||||||
data ManualMigration
|
data ManualMigration
|
||||||
= Migration20230524QualificationUserBlock
|
= Migration20230524QualificationUserBlock
|
||||||
| Migration20230703LmsUserStatus
|
| Migration20230703LmsUserStatus
|
||||||
|
| Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values
|
||||||
| Migration20240312OAuth2
|
| Migration20240312OAuth2
|
||||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
|
||||||
deriving anyclass (Universe, Finite)
|
deriving anyclass (Universe, Finite)
|
||||||
@ -178,6 +179,25 @@ customMigrations = mapF $ \case
|
|||||||
;
|
;
|
||||||
|]
|
|]
|
||||||
|
|
||||||
|
Migration20240212InitInterfaceHealth ->
|
||||||
|
unlessM (tableExists "interface_health") $ do -- fill health table with some defaults
|
||||||
|
[executeQQ|
|
||||||
|
CREATE TABLE "interface_health"
|
||||||
|
( id BIGSERIAL NOT NULL
|
||||||
|
, interface CHARACTER VARYING NOT NULL
|
||||||
|
, subtype CHARACTER VARYING
|
||||||
|
, write BOOLEAN
|
||||||
|
, hours BIGINT NOT NULL
|
||||||
|
, PRIMARY KEY(id)
|
||||||
|
, CONSTRAINT unique_interface_health UNIQUE(interface, subtype, write)
|
||||||
|
);
|
||||||
|
INSERT INTO "interface_health" ("interface", "subtype", "write", "hours")
|
||||||
|
VALUES
|
||||||
|
('Printer', 'Acknowledge', True, 168)
|
||||||
|
, ('AVS' , 'Synch' , True , 96)
|
||||||
|
ON CONFLICT DO NOTHING;
|
||||||
|
|]
|
||||||
|
|
||||||
Migration20240312OAuth2 -> whenM (andM [ columnNotExists "user" "password_hash", columnExists "user" "authentication", columnExists "user" "last_ldap_synchronisation", columnNotExists "user" "last_sync", columnExists "user" "ldap_primary_key" ]) $ do
|
Migration20240312OAuth2 -> whenM (andM [ columnNotExists "user" "password_hash", columnExists "user" "authentication", columnExists "user" "last_ldap_synchronisation", columnNotExists "user" "last_sync", columnExists "user" "ldap_primary_key" ]) $ do
|
||||||
[executeQQ|
|
[executeQQ|
|
||||||
ALTER TABLE "user" ADD COLUMN "password_hash" VARCHAR NULL;
|
ALTER TABLE "user" ADD COLUMN "password_hash" VARCHAR NULL;
|
||||||
|
|||||||
11
src/Utils.hs
11
src/Utils.hs
@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI
|
|||||||
|
|
||||||
import qualified Data.ByteString as BS
|
import qualified Data.ByteString as BS
|
||||||
import qualified Data.ByteString.Char8 as CBS
|
import qualified Data.ByteString.Char8 as CBS
|
||||||
import qualified Data.Char as Char
|
-- import qualified Data.Char as Char
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.Text.Encoding as Text
|
import qualified Data.Text.Encoding as Text
|
||||||
|
|
||||||
@ -319,9 +319,16 @@ citext2string = Text.unpack . CI.original
|
|||||||
string2citext :: String -> CI Text
|
string2citext :: String -> CI Text
|
||||||
string2citext = CI.mk . Text.pack
|
string2citext = CI.mk . Text.pack
|
||||||
|
|
||||||
|
text2AlphaNumPlus :: [Char] -> Text -> Text
|
||||||
|
text2AlphaNumPlus =
|
||||||
|
let alphaNum = Set.fromAscList $ ['0'..'9'] <> ['A'..'Z'] <> ['a'..'z']
|
||||||
|
in \oks ->
|
||||||
|
let aNumPlus = Set.fromList oks <> alphaNum
|
||||||
|
in Text.filter (`Set.member` aNumPlus)
|
||||||
|
|
||||||
-- | 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 = text2AlphaNumPlus ['-','_']
|
||||||
. Text.replace "ä" "ae"
|
. Text.replace "ä" "ae"
|
||||||
. Text.replace "Ä" "Ae"
|
. Text.replace "Ä" "Ae"
|
||||||
. Text.replace "Æ" "ae"
|
. Text.replace "Æ" "ae"
|
||||||
|
|||||||
@ -382,6 +382,8 @@ identifyForm = identifyForm' id
|
|||||||
-- Buttons (new version ) --
|
-- Buttons (new version ) --
|
||||||
----------------------------
|
----------------------------
|
||||||
|
|
||||||
|
-- Bemerke: Back Button Widget implementierbar durch <button onclick="history.back()">_{MsgGenericBack}
|
||||||
|
|
||||||
data family ButtonClass site :: Type
|
data family ButtonClass site :: Type
|
||||||
|
|
||||||
class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
|
class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
|
||||||
@ -391,7 +393,7 @@ class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessa
|
|||||||
btnLabel = toWidget <=< ap getMessageRender . return
|
btnLabel = toWidget <=< ap getMessageRender . return
|
||||||
|
|
||||||
btnValidate :: forall p. p site -> a -> Bool
|
btnValidate :: forall p. p site -> a -> Bool
|
||||||
btnValidate _ _ = True
|
btnValidate _ _ = True -- False will attach html attribute "formnovalidate", so that browsers do not validate the form data
|
||||||
|
|
||||||
btnClasses :: a -> [ButtonClass site]
|
btnClasses :: a -> [ButtonClass site]
|
||||||
btnClasses _ = []
|
btnClasses _ = []
|
||||||
|
|||||||
@ -308,6 +308,7 @@ makeLenses_ ''AuthorshipStatementDefinition
|
|||||||
makeLenses_ ''PrintJob
|
makeLenses_ ''PrintJob
|
||||||
|
|
||||||
makeLenses_ ''InterfaceLog
|
makeLenses_ ''InterfaceLog
|
||||||
|
-- makeLenses_ ''InterfaceLog -- not needed
|
||||||
|
|
||||||
--------------------------
|
--------------------------
|
||||||
-- Fields for `UniWorX` --
|
-- Fields for `UniWorX` --
|
||||||
|
|||||||
@ -269,13 +269,17 @@ printLetter' pji pdf = do
|
|||||||
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
|
-- printJobFile <- sinkFileDB True $ yield $ LBS.toStrict pdf -- for PrintJobFile :: FileContentReference use this code
|
||||||
printJobFile = LBS.toStrict pdf
|
printJobFile = LBS.toStrict pdf
|
||||||
printJobAcknowledged = Nothing
|
printJobAcknowledged = Nothing
|
||||||
|
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
|
||||||
|
let logInter = flip (logInterface "Printer" qshort) (Just 1)
|
||||||
lprPDF printJobFilename pdf >>= \case
|
lprPDF printJobFilename pdf >>= \case
|
||||||
Left err -> do
|
Left err -> do
|
||||||
|
logInter False err
|
||||||
return $ Left err
|
return $ Left err
|
||||||
Right ok -> do
|
Right ok -> do
|
||||||
printJobCreated <- liftIO getCurrentTime
|
printJobCreated <- liftIO getCurrentTime
|
||||||
-- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
|
-- updateWhere [PrintJobLmsUser ==. printJobLmsUser] [PrintJobLmsUser =. Nothing] -- only one printJob per LmsUser is allowed, since otherwise the qualification table contains double rows
|
||||||
insert_ PrintJob {..}
|
insert_ PrintJob{..}
|
||||||
|
logInter True ok
|
||||||
return $ Right (ok, printJobFilename)
|
return $ Right (ok, printJobFilename)
|
||||||
|
|
||||||
reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text)
|
reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text)
|
||||||
@ -283,13 +287,19 @@ reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown."
|
|||||||
where
|
where
|
||||||
reprint :: PrintJob -> DB (Either Text Text)
|
reprint :: PrintJob -> DB (Either Text Text)
|
||||||
reprint pj@PrintJob{..} = do
|
reprint pj@PrintJob{..} = do
|
||||||
|
qshort <- ifMaybeM printJobQualification "-" $ fmap (maybe "_" $ CI.original . qualificationShorthand ) . get
|
||||||
|
let logInter = flip (logInterface "Printer" qshort) (Just 1)
|
||||||
result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile
|
result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile
|
||||||
whenIsRight result $ const $ do
|
case result of
|
||||||
now <- liftIO getCurrentTime
|
Left err ->
|
||||||
insert_ pj{ printJobAcknowledged = Nothing
|
logInter False err
|
||||||
, printJobCreated = now
|
Right m -> do
|
||||||
-- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF
|
logInter True m
|
||||||
}
|
now <- liftIO getCurrentTime
|
||||||
|
insert_ pj{ printJobAcknowledged = Nothing
|
||||||
|
, printJobCreated = now
|
||||||
|
-- , printJobApcIdent = ??? cannot be modified here, since it is included inside the PDF
|
||||||
|
}
|
||||||
return result
|
return result
|
||||||
|
|
||||||
{-
|
{-
|
||||||
|
|||||||
@ -56,8 +56,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
|||||||
<h2>
|
<h2>
|
||||||
_{MsgMenuInterfaces}
|
_{MsgMenuInterfaces}
|
||||||
<div>
|
<div>
|
||||||
<p>
|
<p>
|
||||||
_{MsgProblemsInterfaceSince} ^{formatTimeW SelFormatDate cutOffOldTime}
|
$if interfacesBadNr > 0
|
||||||
|
_{MsgInterfacesFail interfacesBadNr}
|
||||||
|
$else
|
||||||
|
_{MsgInterfacesOk}
|
||||||
^{interfaceTable}
|
^{interfaceTable}
|
||||||
|
|
||||||
<!-- section h2 {MsgProblemsHeadingMisc} -->
|
<!-- section h2 {MsgProblemsHeadingMisc} -->
|
||||||
|
|||||||
@ -8,19 +8,27 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
|||||||
<p>
|
<p>
|
||||||
Können sie sich mit <i>exakt identischen</i> (idealerweise #
|
Können sie sich mit <i>exakt identischen</i> (idealerweise #
|
||||||
copy&paste) Daten #
|
copy&paste) Daten #
|
||||||
im <a href="https://www.portal.uni-muenchen.de">Campus-Portal</a> #
|
im <a href="https://myapps.microsoft.com/">myapps.microsoft.com</a> #
|
||||||
anmelden?
|
anmelden?
|
||||||
|
|
||||||
|
<br>
|
||||||
|
Falls sie die Fehlermeldung „Passwort abgelaufen“ oder "password-expired" erhalten, #
|
||||||
|
dann befolgen Sie bitte #
|
||||||
|
<a href=^{faqLink FAQLoginExpired}>
|
||||||
|
diese Anleitung zum erneuern Ihres Passworts.
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
|
|
||||||
Falls nicht („_{InvalidLogin}“), ist davon auszugehen, dass Sie #
|
Falls nicht („_{InvalidLogin}“), ist davon auszugehen, dass Sie #
|
||||||
Ihre Anmeldedaten falsch eingeben oder #
|
Ihre Anmeldedaten falsch eingeben oder #
|
||||||
<a href=^{faqLink FAQNoCampusAccount}>keine LMU-Benutzerkennung #
|
<a href=^{faqLink FAQNoCampusAccount}>keine gültige Fraport AG #
|
||||||
(ehem. Campus-Kennung) besitzen</a>.
|
Benutzerkennung besitzen</a>. #
|
||||||
|
Rufen Sie in diesem Fall den allgemeinen Fraport IT-Helpdesk #
|
||||||
|
an unter <a href="tel:+49-69-690127">+49-69-690127</a>
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
Beachten Sie dabei auch, dass Uni2work Leerzeichen sowohl im #
|
Beachten Sie, dass Leerzeichen sowohl im #
|
||||||
Passwort als auch bei der Kennung berücksichtigt.
|
Passwort als auch bei der Kennung berücksichtigt werden.
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
|
|
||||||
@ -33,34 +41,27 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
|||||||
aktiviertem JavaScript), dass Sie Ihr Passwort korrekt eingeben.
|
aktiviertem JavaScript), dass Sie Ihr Passwort korrekt eingeben.
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
Uni2work bietet zwei Login-Formulare.
|
Uni2work bietet mehrere Login-Formulare.
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
|
|
||||||
Für die Anmeldung mit der LMU-Benutzerkennung (ehem. Campus-Kennung) #
|
Für die Anmeldung mit Ihren Fraport AG Konto #
|
||||||
müssen Sie das Formular „_{MsgLDAPLoginTitle}“ verwenden.
|
müssen Sie das Formular „_{MsgLDAPLoginTitle}“ verwenden.
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
|
|
||||||
Geben Sie unter „_{MsgCampusIdent}“ ihre vollständige #
|
|
||||||
LMU-Benutzerkennung an. #
|
|
||||||
|
|
||||||
Diese ist identisch mit ihrer <code>@campus.lmu.de</code> E-Mail #
|
|
||||||
Adresse.
|
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
Falls Sie seit Ihrem letzten Login in Uni2work ihr Passwort geändert #
|
Falls Sie Ihr Passwort kürzlich geändert #
|
||||||
haben, kann es sein, dass die Änderung des Passworts (noch) nicht #
|
haben, kann es sein, dass die Änderung des Passworts (noch) nicht #
|
||||||
korrekt propagiert wurde.
|
korrekt propagiert wurde. Warten Sie einfach ein paar Minuten oder #
|
||||||
|
versuchen Sie, Ihr altes Passwort zu verwenden.
|
||||||
|
|
||||||
<br>
|
|
||||||
|
|
||||||
In diesem Fall können Sie versuchen Ihr Passwort erneut zu ändern.
|
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
Sobald Sie die obigen Hinweise befolgt haben, wenden Sie sich bitte #
|
Sobald Sie die obigen Hinweise befolgt haben, wenden Sie sich bitte #
|
||||||
(erneut) über das <a href=@{HelpR}>Hilfe-Formular</a>, oben rechts #
|
(erneut) über das <a href=@{HelpR}>Hilfe-Formular</a>, oben rechts #
|
||||||
auf jeder Seite, an die Uni2work-Administration.
|
auf jeder Seite, an die FRADrive-Administration.
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
|
|
||||||
|
|||||||
@ -7,18 +7,29 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
|||||||
|
|
||||||
<p>
|
<p>
|
||||||
Can you log in to #
|
Can you log in to #
|
||||||
the <a href="https://www.portal.uni-muenchen.de">Campus-Portal</a> #
|
the <a href="https://myapps.microsoft.com/">myapps.microsoft.com</a> #
|
||||||
using the <i>exact same</i> (ideally copied & pasted) login data?
|
using the <i>exact same</i> (ideally copied & pasted) login data?
|
||||||
|
|
||||||
|
<br>
|
||||||
|
If you received the error message „Passwort abgelaufen“ or "password-expired" #
|
||||||
|
then please follow #
|
||||||
|
<a href=^{faqLink FAQLoginExpired}>
|
||||||
|
these instructions for password renewal.
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
|
|
||||||
If you cannot (“_{InvalidLogin}”), this means that you are #
|
If you cannot (“_{InvalidLogin}”), this means that you are #
|
||||||
entering your login data wrong or that you #
|
entering your login data wrong or that you #
|
||||||
<a href=^{faqLink FAQNoCampusAccount}>do not have a LMU user ID #
|
<a href=^{faqLink FAQNoCampusAccount}>
|
||||||
(formerly Campus-ID)</a>.
|
do not have a valid Fraport AG credentials.
|
||||||
|
|
||||||
|
<br>
|
||||||
|
|
||||||
|
In this case please call the general Fraport IT-Servicedesk
|
||||||
|
at <a href="tel:+49-69-690127">+49-69-690127</a>
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
Please consider that for Uni2work both your user ID and password are #
|
Please consider that for FRADrive both your user ID and password are #
|
||||||
sensitive to whitespace characters.
|
sensitive to whitespace characters.
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
@ -37,31 +48,22 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
|||||||
password manager instead of typing it manually.
|
password manager instead of typing it manually.
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
Uni2work offers two login forms.
|
Furthermore, FRADrive offers several login forms.
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
|
|
||||||
To log in using your LMU user ID (formerly Campus-ID) you need to #
|
To log in using your Fraport AG credentials you need to #
|
||||||
use the form titled “_{MsgLDAPLoginTitle}”.
|
use the form titled “_{MsgLDAPLoginTitle}”.
|
||||||
|
|
||||||
<br>
|
|
||||||
|
|
||||||
Under “_{MsgCampusIdent}” please enter your entire LMU user ID, #
|
|
||||||
which is identical to your <code>@campus.lmu.de</code> email #
|
|
||||||
address.
|
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
If you have changed your password since last you logged into #
|
If you have changed your password since last you logged into #
|
||||||
Uni2work, it may be the case that your password change was not #
|
FRADrive, it may be the case that your password change was not #
|
||||||
propagated properly.
|
propagated properly. Please wait a few minutes and try again,
|
||||||
|
or try changing your password again.
|
||||||
<br>
|
|
||||||
|
|
||||||
If so, please try changing your password again.
|
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
Once you have followed the suggestions above, please contact a #
|
Once you have followed the suggestions above, please contact a #
|
||||||
Uni2work-administrator using the <a href=@{HelpR}>Support form</a> #
|
FRADrive-administrator using the <a href=@{HelpR}>Support form</a> #
|
||||||
(at the top right of every page).
|
(at the top right of every page).
|
||||||
|
|
||||||
<br>
|
<br>
|
||||||
@ -73,4 +75,4 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
|
|||||||
|
|
||||||
Never disclose your password to third parties! #
|
Never disclose your password to third parties! #
|
||||||
|
|
||||||
Not even to an Uni2work-administrator or the IT-Servicedesk!
|
Not even to a FRADrive-administrator or the IT-Servicedesk!
|
||||||
|
|||||||
@ -1,10 +0,0 @@
|
|||||||
$newline never
|
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
|
||||||
$#
|
|
||||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
||||||
|
|
||||||
<p>
|
|
||||||
Ausbilder:innen und Korrektor:innen werden beim Anlegen oder Editieren des #
|
|
||||||
jeweiligen Kurses bzw. Übungsblattes angegeben.
|
|
||||||
|
|
||||||
@ -1,9 +0,0 @@
|
|||||||
$newline never
|
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
||||||
$#
|
|
||||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
||||||
|
|
||||||
<p>
|
|
||||||
Instructors and correctors are assigned when creating or editing the #
|
|
||||||
respective course or exercise sheet.
|
|
||||||
@ -1,14 +0,0 @@
|
|||||||
$newline never
|
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
||||||
$#
|
|
||||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
||||||
|
|
||||||
|
|
||||||
<p>
|
|
||||||
Klausurpunkte werden in Uni2work pro Teilaufgabe verwaltet.
|
|
||||||
|
|
||||||
<p>
|
|
||||||
Um Klausurleistungen als Punkte anzugeben (und optional automatisch #
|
|
||||||
eine Note daraus zu berechnen), müssen Sie mindestens eine #
|
|
||||||
Teilprüfung/Aufgabe anlegen.
|
|
||||||
@ -1,14 +0,0 @@
|
|||||||
$newline never
|
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
||||||
$#
|
|
||||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
||||||
|
|
||||||
|
|
||||||
<p>
|
|
||||||
Exam points are managed in Uni2work on a per-exam-part basis.
|
|
||||||
|
|
||||||
<p>
|
|
||||||
To store exam achievements in the form of points (and optionally #
|
|
||||||
automatically compute grades), you need to create at least one #
|
|
||||||
exam part/question.
|
|
||||||
@ -1,27 +1,16 @@
|
|||||||
$newline never
|
$newline never
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
|
$# SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@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
|
||||||
|
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
Wenn Sie sich gewöhnlicherweise mit Ihrer LMU-Benutzerkennug #
|
Wenn Sie Ihr Passwort vergessen haben, wenden Sie sich bitte an #
|
||||||
(ehem. Campus-Kennung) anmelden, wenden Sie sich bitte an #
|
den allgemeinen Fraport IT-Helpdesk unter
|
||||||
den <a href="https://www.it-servicedesk.uni-muenchen.de/faq/index.html#campuskennung-passwort-vergessen">IT-Servicedesk</a> #
|
<a href="tel:+49-69-690127">
|
||||||
um Ihr Passwort zurücksetzen zu lassen.
|
+49-69-690127
|
||||||
|
|
||||||
<p>
|
|
||||||
Wenn Sie sich mit einer Uni2work-internen Kennung anmelden wenden #
|
|
||||||
Sie sich dafür bitte über das <a href=@{HelpR}>Hilfe-Formular</a> #
|
|
||||||
(oben rechts auf jeder Seite) an die Uni2work-Administration.
|
|
||||||
<br>
|
<br>
|
||||||
Tragen sie dabei unter „Antworten an“ die Adresse ein, an die #
|
Die FRADrive Administratoren können bei Login Problemen leider #
|
||||||
Uni2work gewöhnlicherweise Mitteilungen verschickt.
|
nicht helfen, da diese keinen Zugriff auf Ihren Fraport AG Account haben.
|
||||||
<br>
|
|
||||||
Bitte geben Sie zusätzlich mind. eine nicht-öffentliche #
|
|
||||||
personenbezogene Information an, um den Administrator:innen zu helfen #
|
|
||||||
die Anfrage zu authorisieren. #
|
|
||||||
|
|
||||||
Geeignet ist z.B. die Matrikelnummer oder der ungefähre Zeitpunkt #
|
|
||||||
des letzten Logins.
|
|
||||||
|
|||||||
@ -1,26 +1,17 @@
|
|||||||
$newline never
|
$newline never
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
$# SPDX-FileCopyrightText: 2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
|
||||||
$#
|
$#
|
||||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
|
||||||
<p>
|
<p>
|
||||||
If you usually log in using your LMU user ID (formerly Campus-ID) #
|
If you have forgotten your password #
|
||||||
please contact #
|
please contact the general Fraport IT-servicedesk at #
|
||||||
the <a href="https://www.it-servicedesk.uni-muenchen.de/faq/index.html#campuskennung-passwort-vergessen">IT #
|
<a href="tel:+49-69-690127">
|
||||||
servicedesk (german)</a> to reset your password.
|
+49-69-690127
|
||||||
|
to reset your password.
|
||||||
|
|
||||||
<p>
|
|
||||||
If you log in using a Uni2work-internal account please use #
|
|
||||||
the <a href=@{HelpR}>Support form</a> (at the top right of every #
|
|
||||||
page) to contact a Uni2work-administrator.
|
|
||||||
<br>
|
<br>
|
||||||
Specify the email to which Uni2work usually sends notifications #
|
FRADrive administrators have no access to your Frapot AG account #
|
||||||
under “Send answers to”.
|
and thus cannot help you with this problem.
|
||||||
<br>
|
|
||||||
|
|
||||||
Please also include at least one non-public piece of information to #
|
|
||||||
help authorise your request. #
|
|
||||||
We suggest your Matriculation number or the approximate time of your #
|
|
||||||
last successful login.
|
|
||||||
|
|||||||
@ -1,22 +0,0 @@
|
|||||||
$newline never
|
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
||||||
$#
|
|
||||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
||||||
|
|
||||||
|
|
||||||
<p>
|
|
||||||
Gewöhnlicherweise wird Ihr Benutzereintrag gesperrt, wenn sie #
|
|
||||||
exmatrikuliert werden bzw. Ihr Beschäftigungsverhältnis endet. #
|
|
||||||
|
|
||||||
Es kommt gelegentlich vor, dass Ihr Benutzereintrag nicht korrekt #
|
|
||||||
entsperrt wird, wenn Sie wieder immatrikuliert bzw. eingestellt #
|
|
||||||
werden.
|
|
||||||
|
|
||||||
<p>
|
|
||||||
Falls Sie aktuell immatrikuliert bzw. eingestellt sind, oder Sie #
|
|
||||||
einen anderen triftigen Grund vorweisen können, warum Sie Zugang zu #
|
|
||||||
Uni2work brauchen, wenden Sie sich bitte über #
|
|
||||||
das <a href=@{HelpR}>Hilfe-Formular</a>, oben rechts auf jeder #
|
|
||||||
Seite, an die Uni2work-Administration und schildern Sie Ihre #
|
|
||||||
Situation.
|
|
||||||
@ -1,19 +0,0 @@
|
|||||||
$newline never
|
|
||||||
|
|
||||||
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
||||||
$#
|
|
||||||
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
|
||||||
|
|
||||||
|
|
||||||
<p>
|
|
||||||
Usually your account is disabled once you are no longer matriculated #
|
|
||||||
(i.e. registered as a student) or employed. #
|
|
||||||
|
|
||||||
Occasionally accounts are not correctly re-enabled once you are #
|
|
||||||
matriculated or employed, again.
|
|
||||||
|
|
||||||
<p>
|
|
||||||
If you are currently matriculated, employed, or have another good #
|
|
||||||
reason why you should have access to Uni2work, please contact a #
|
|
||||||
Uni2work-Administrator using the <a href=@{HelpR}>Support form</a> #
|
|
||||||
(at the top right of every page) and describe your situation.
|
|
||||||
47
templates/i18n/faq/login-expired.de-de-formal.hamlet
Normal file
47
templates/i18n/faq/login-expired.de-de-formal.hamlet
Normal file
@ -0,0 +1,47 @@
|
|||||||
|
$newline never
|
||||||
|
|
||||||
|
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||||
|
$#
|
||||||
|
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Der Zugang zu FRADrive erfolgt über Ihren Fraport AG Login. #
|
||||||
|
Das Passwort für Ihren Fraport AG Login muss alle 90 Tage geändert werden. #
|
||||||
|
Tun Sie dies nicht, so können Sie sich nicht mehr einloggen. #
|
||||||
|
Dies besagen die Richtlininen der Fraport AG IT Abteilung.
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Bevor oder auch nachdem Ihr Passwort abgelaufen ist, #
|
||||||
|
können Sie das Passwort ganze leicht selbst mit einer #
|
||||||
|
der folgenden Methoden ändern: #
|
||||||
|
|
||||||
|
<ol>
|
||||||
|
<li>
|
||||||
|
Über #
|
||||||
|
<a href="https://account.activedirectory.windowsazure.com/ChangePassword.aspx">
|
||||||
|
das Azure Portal
|
||||||
|
.
|
||||||
|
<li>
|
||||||
|
Über Ihre #
|
||||||
|
<a href="https://myaccount.microsoft.com/?ref=MeControl">
|
||||||
|
Microsoft Kontoseite
|
||||||
|
. Verwenden Sie dort die Funktion "Kennwort ändern".
|
||||||
|
<li>
|
||||||
|
Über Ihre Profil-Einstellungen "Konto-Anzeigen" auf #
|
||||||
|
<a href="https://myapps.microsoft.com/">
|
||||||
|
Ihre Microsoft My-Apps Seite
|
||||||
|
.
|
||||||
|
|
||||||
|
<p>
|
||||||
|
<b>
|
||||||
|
Hinweis: #
|
||||||
|
|
||||||
|
Wenden Sie sich bei Problemen mit dem Passwortwechsel #
|
||||||
|
bitte direkt an den allgemeinen Fraport IT-Helpdesk unter #
|
||||||
|
<a href="tel:+49-69-690127">
|
||||||
|
+49-69-690127
|
||||||
|
|
||||||
|
<br>
|
||||||
|
Die FRADrive Administratoren können bei diesem Login Problem leider #
|
||||||
|
nicht helfen, da diese keinen Zugriff auf Ihren Fraport AG Account haben.
|
||||||
46
templates/i18n/faq/login-expired.en-eu.hamlet
Normal file
46
templates/i18n/faq/login-expired.en-eu.hamlet
Normal file
@ -0,0 +1,46 @@
|
|||||||
|
$newline never
|
||||||
|
|
||||||
|
$# SPDX-FileCopyrightText: 2024 Steffen Jost <s.jost@fraport.de>
|
||||||
|
$#
|
||||||
|
$# SPDX-License-Identifier: AGPL-3.0-or-later
|
||||||
|
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Using FRADrive required a Fraport AG account. #
|
||||||
|
The password for your Fraport AG account must be changed every 90 days. #
|
||||||
|
Following the general IT safety guidelines of Fraport AG, #
|
||||||
|
your login will be temporarily disabled otherwise.
|
||||||
|
|
||||||
|
<p>
|
||||||
|
Regardless of whether your password has already expired or not, #
|
||||||
|
you may easily change your password with any one of the following methods: #
|
||||||
|
|
||||||
|
<ol>
|
||||||
|
<li>
|
||||||
|
Via #
|
||||||
|
<a href="https://account.activedirectory.windowsazure.com/ChangePassword.aspx">
|
||||||
|
the azure portal
|
||||||
|
.
|
||||||
|
<li>
|
||||||
|
Using you #
|
||||||
|
<a href="https://myaccount.microsoft.com/?ref=MeControl">
|
||||||
|
Microsoft account page
|
||||||
|
, then using the function "change password" there.
|
||||||
|
<li>
|
||||||
|
By accessing your profile settings on #
|
||||||
|
<a href="https://myapps.microsoft.com/">
|
||||||
|
your Microsoft My-Apps page
|
||||||
|
.
|
||||||
|
|
||||||
|
<p>
|
||||||
|
<b>
|
||||||
|
Please note: #
|
||||||
|
|
||||||
|
If you have any problem changing your password #
|
||||||
|
please call the general Fraport IT-servicedesk at #
|
||||||
|
<a href="tel:+49-69-690127">
|
||||||
|
+49-69-690127
|
||||||
|
|
||||||
|
<br>
|
||||||
|
FRADrive administrators have no access to your Frapot AG account #
|
||||||
|
and thus cannot help you with this problem.
|
||||||
@ -684,9 +684,22 @@ fillDb = do
|
|||||||
++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost]
|
++ take 444 [ UserSupervisor fhamann uid True | Entity uid _ <- matUsers, uid /= jost]
|
||||||
++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ]
|
++ take 123 [ UserSupervisor gkleen uid True | Entity uid _ <- drop 369 matUsers ]
|
||||||
++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ]
|
++ take 11 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ]
|
||||||
upsertManyWhere supvs [] [] []
|
upsertManyWhere supvs [] [] []
|
||||||
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
|
-- insertMany_ supvs -- NOTE: multiple calls like this throw a runtime error!
|
||||||
-- insertMany_ supvs -- NOTE: multiple calls like this throw an error!
|
-- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok
|
||||||
|
-- upsertManyWhere (supvs ++ take 5 (drop 12 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ])) -- no duplicates within first argument allowed! (runtime error: ON CONFLICT DO UPDATE command cannot affect row a second time)
|
||||||
|
-- [copyField UserSupervisorRerouteNotifications] [UserSupervisorRerouteNotifications =. True] [UserSupervisorSupervisor ==. jost, UserSupervisorUser <-. [uid | Entity uid _ <- take 3 $ drop 504 matUsers ]] -- does not work!
|
||||||
|
-- let changeSome usr@(UserSupervisor s u _)
|
||||||
|
-- | s == jost, u `elem` take 14 [ uid | Entity uid _ <- drop 501 matUsers ] = UserSupervisor s u True
|
||||||
|
-- | otherwise = usr
|
||||||
|
-- upsertManyWhere (changeSome <$> (supvs ++ take 5 (drop 12 [ UserSupervisor jost uid False | Entity uid _ <- drop 501 matUsers ]))) -- no duplicates within first argument allowed! (runtime error: ON CONFLICT DO UPDATE command cannot affect row a second time)
|
||||||
|
-- [copyField UserSupervisorRerouteNotifications] [] [UserSupervisorSupervisor ==. jost, UserSupervisorUser <-. [uid | Entity uid _ <- take 3 $ drop 504 matUsers ]] -- probably does the same as the above
|
||||||
|
-- OBSERVATIONS:
|
||||||
|
-- - use the 2. argument with `copyField` to overwrite an existing field with the new record value provided in the 1. argument in case of an update
|
||||||
|
-- - use the 3. argument to update a field indepently from the provided records or for computations involving previous values, eg. +=.
|
||||||
|
-- - use the 4. argument to filter both the application of the 2. and 3. argument
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False
|
ifi <- insert' $ School "Institut für Informatik" "IfI" (Just $ 14 * nominalDay) (Just $ 10 * nominalDay) True (ExamModeDNF predDNFFalse) (ExamCloseOnFinished True) SchoolAuthorshipStatementModeOptional (Just ifiAuthorshipStatement) True SchoolAuthorshipStatementModeRequired (Just ifiAuthorshipStatement) False
|
||||||
mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
|
mi <- insert' $ School "Institut für Mathematik" "MI" Nothing Nothing False (ExamModeDNF predDNFFalse) (ExamCloseOnFinished False) SchoolAuthorshipStatementModeNone Nothing True SchoolAuthorshipStatementModeOptional Nothing True
|
||||||
|
|||||||
Reference in New Issue
Block a user