diff --git a/CHANGELOG.md b/CHANGELOG.md index d99bd198d..bb7fd8e96 100644 --- a/CHANGELOG.md +++ b/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. +## [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) diff --git a/messages/faq/de-de-formal.msg b/messages/faq/de-de-formal.msg index 221b1f5b1..a568617e6 100644 --- a/messages/faq/de-de-formal.msg +++ b/messages/faq/de-de-formal.msg @@ -1,11 +1,9 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost # # 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? FAQForgottenPassword: Ich habe mein Passwort vergessen 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? -FAQExamPoints: Warum kann ich bei meiner Klausur keine Punkte eintragen? -FAQInvalidCredentialsAdAccountDisabled: Ich kann mich nicht anmelden und bekomme die Meldung „Benutzereintrag gesperrt“ \ No newline at end of file +FAQNotLecturerHowToCreateCourses: Wie kann ich eine neue Kursart anlegen? \ No newline at end of file diff --git a/messages/faq/en-eu.msg b/messages/faq/en-eu.msg index 0686713bb..5d1ed4913 100644 --- a/messages/faq/en-eu.msg +++ b/messages/faq/en-eu.msg @@ -1,11 +1,9 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +# SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost # # 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? FAQForgottenPassword: I have forgotten my password 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? -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” \ No newline at end of file +FAQNotLecturerHowToCreateCourses: How can I create new courses? \ No newline at end of file diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index bc618283d..8aa72be6e 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -121,8 +121,15 @@ ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen ProblemsAvsErrorHeading: Fehlermeldungen 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 InterfaceSubtype: Betreffend InterfaceWrite: Schreibend -AdminUserPassword: Passwort \ No newline at end of file +AdminUserPassword: Passwort +InterfaceSuccess: Rückmeldung +InterfaceInfo: Nachricht +InterfaceFreshness: Prüfungszeitraum (h) diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 3a2526fc0..d59341441 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -121,8 +121,15 @@ ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences ProblemsAvsErrorHeading: Error Log ProblemsInterfaceSince: Only considering successes and errors since +InterfacesOk: Interfaces are ok. +InterfacesFail n: #{pluralENsN n "interface problem"}! +InterfaceStatus: Status +InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting InterfaceWrite: Write -AdminUserPassword: Password \ No newline at end of file +AdminUserPassword: Password +InterfaceSuccess: Returned +InterfaceInfo: Message +InterfaceFreshness: Check hours diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index a0bf4391e..d8faf2d87 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -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 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 -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 CourseParticipantsRegisterUnnecessary: Alle angeforderten Anmeldungen sind bereits vorhanden. Es wurden keine Änderungen vorgenommen. CourseParticipantsRegisterConfirmInvalid: Ungültiges Bestätigungsformular! diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index 19282706e..e6aa4079d 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -23,6 +23,7 @@ MenuPayments: Zahlungsbedingungen MenuInstance: Instanz-Identifikation MenuHealth: Instanz-Zustand +MenuHealthInterface: Schnittstellen Zustand MenuHelp: Hilfe MenuAccount: Konto MenuProfile: Anpassen @@ -146,6 +147,8 @@ MenuExternalUser: Externe Benutzer MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen +MenuPrintLog: LPR Schnittstelle +MenuPrintAck: Druckbestätigung MenuApiDocs: API-Dokumentation (Englisch) MenuSwagger !ident-ok: OpenAPI 2.0 (Swagger) diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index c091491b5..71c56b8da 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -23,6 +23,7 @@ MenuPayments: Payment Terms MenuInstance: Instance identification MenuHealth: Instance health +MenuHealthInterface: Interface health MenuHelp: Support MenuAccount: Account MenuProfile: Settings @@ -146,6 +147,8 @@ MenuExternalUser: External users MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter +MenuPrintLog: LPR Interface +MenuPrintAck: Acknowledge Printing MenuApiDocs: API documentation MenuSwagger: OpenAPI 2.0 (Swagger) diff --git a/models/audit.model b/models/audit.model index fd0889392..3cd567a13 100644 --- a/models/audit.model +++ b/models/audit.model @@ -14,9 +14,18 @@ TransactionLog InterfaceLog interface 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 - rows Int Maybe -- number of datasets transmitted - info Text -- addtional status information + rows Int Maybe -- number of datasets transmitted + 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 - deriving Eq Read Show Generic \ No newline at end of file + 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 diff --git a/models/lms.model b/models/lms.model index d9f4c1b7e..713b9a57d 100644 --- a/models/lms.model +++ b/models/lms.model @@ -20,7 +20,7 @@ Qualification SchoolQualificationShort school shorthand -- must be unique per school and shorthand SchoolQualificationName school name -- must be unique per school and name -- 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! deriving Eq Generic @@ -40,21 +40,22 @@ Qualification -- - PinReset==1 mit bestehendem Passwort kann problemlos erneut gesendet werden -- - 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 - qualification QualificationId OnDeleteCascade OnUpdateCascade -- AND: not unique, ie. qualification can have multiple required preconditions - required [QualificationId] -- OR : alternatives, any one will suffice - continuous Bool -- expiring precondition blocks qualification - deriving Generic +-- 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 +-- required [QualificationId] -- OR : alternatives, any one will suffice +-- continuous Bool -- expiring precondition blocks qualification +-- deriving Generic -- Maybe an alternative for online qualification validity checking, transitivity through recursive CTEs? (already available in our version) --- QualificationRequirement +--QualificationRequirement -- qualification QualificationId OnDeleteCascade OnUpdateCascade -- requirement QualificationId OnDeleteCascade OnUpdateCascade -- group Text -- OR: several requirements within the same group are considered equivalent -- UniqueQualificationRequirement qualification requirement +-- deriving Generic -- --- TODO: connect Qualification with Exams! +-- TODO: connect Qualifications with Exams!? QualificationEdit user UserId @@ -81,6 +82,7 @@ QualificationUserBlock from UTCTime reason Text blocker UserId Maybe + -- precondition Bool default=false -- if true, this was due to a precondition deriving Eq Ord Read Show Generic -- LMS Interface Tables, need regular processing by background jobs, per QualificationId: diff --git a/nix/docker/version.json b/nix/docker/version.json index be8c9e7d6..450e150fd 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.56" + "version": "27.4.59" } diff --git a/package-lock.json b/package-lock.json index fb4545bc0..8baaeafcc 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.56", + "version": "27.4.59", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 25437a405..8c360c1e7 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.56", + "version": "27.4.59", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 809c0cb4b..c7d59d999 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.56 +version: 27.4.59 dependencies: - base - yesod diff --git a/routes b/routes index bc88f82e2..0e4a83324 100644 --- a/routes +++ b/routes @@ -82,24 +82,26 @@ /print PrintCenterR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer -/print/acknowledge/direct PrintAckDirectR POST !system-printer +/print/acknowledge/direct PrintAckDirectR GET POST !system-printer /print/send PrintSendR GET POST /print/download/#CryptoUUIDPrintJob PrintDownloadR GET !system-printer +/print/log PrintLogR GET !system-printer -/health HealthR GET !free -/instance InstanceR GET !free -/info InfoR GET !free -/info/lecturer InfoLecturerR GET !free -/info/supervisor InfoSupervisorR GET !free -/info/legal LegalR GET !free -/info/glossary GlossaryR GET !free -/info/faq FaqR GET !free -/info/terms-of-use TermsOfUseR GET !free -/info/payments PaymentsR GET !free -/imprint ImprintR GET !free -/data-protection DataProtectionR GET !free -/version VersionR GET !free -/status StatusR GET !free +/health HealthR GET !free +/health/interface/+Texts HealthInterfaceR GET !free +/instance InstanceR GET !free +/info InfoR GET !free +/info/lecturer InfoLecturerR GET !free +/info/supervisor InfoSupervisorR GET !free +/info/legal LegalR GET !free +/info/glossary GlossaryR GET !free +/info/faq FaqR GET !free +/info/terms-of-use TermsOfUseR GET !free +/info/payments PaymentsR GET !free +/imprint ImprintR GET !free +/data-protection DataProtectionR GET !free +/version VersionR GET !free +/status StatusR GET !free /help HelpR GET POST !free diff --git a/src/Application.hs b/src/Application.hs index 837f3a536..bf5889899 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -148,6 +148,7 @@ import Handler.Material import Handler.CryptoIDDispatch import Handler.SystemMessage import Handler.Health +import Handler.Health.Interface import Handler.Exam import Handler.ExamOffice import Handler.Metrics diff --git a/src/Audit.hs b/src/Audit.hs index e13c769b9..40c4a4206 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -8,7 +8,7 @@ module Audit , audit , AuditRemoteException(..) , getRemote - , logInterface + , logInterface, logInterface' ) where @@ -123,19 +123,49 @@ logInterface :: ( AuthId (HandlerSite m) ~ Key User ) => Text -- ^ Interface that is used -> Text -- ^ Subtype of the interface, if any + -> 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 interfaceLogInterface interfaceLogSubtype interfaceLogRows interfaceLogInfo = do - interfaceLogTime <- liftIO getCurrentTime +logInterface interfaceLogInterface interfaceLogSubtype interfaceLogSuccess interfaceLogRows interfaceLogInfo = do interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest - deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest - insert_ InterfaceLog{..} + logInterface' interfaceLogInterface interfaceLogSubtype interfaceLogWrite interfaceLogSuccess interfaceLogRows interfaceLogInfo + +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 { transactionInterfaceName = interfaceLogInterface , transactionInterfaceSubtype = interfaceLogSubtype , transactionInterfaceWrite = interfaceLogWrite , transactionInterfaceRows = interfaceLogRows , transactionInterfaceInfo = interfaceLogInfo + , transactionInterfaceSuccess = Just interfaceLogSuccess } diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index b7ebe8807..976171ec4 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -240,6 +240,7 @@ data Transaction , transactionInterfaceWrite :: Bool -- True implies a write to FRADrive , transactionInterfaceRows :: Maybe Int , transactionInterfaceInfo :: Text + , transactionInterfaceSuccess :: Maybe Bool -- Just False implies a failure; Maybe used to achieve backwards compatibility } deriving (Eq, Ord, Read, Show, Generic) diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 1e8ecfe7e..127e0ed88 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -17,6 +17,7 @@ module Database.Esqueleto.Utils , (>~.), (<~.) , or, and , any, all + , not__, parens , subSelectAnd, subSelectOr , mkExactFilter, mkExactFilterWith, mkExactFilterWithComma , 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.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 $(sqlInTuples [2..16]) @@ -705,7 +709,6 @@ interval = E.unsafeSqlCastAs "interval". E.unsafeSqlValue . wrapSqlString . Text singleQuote = Text.Builder.singleton '\'' wrapSqlString b = singleQuote <> b <> singleQuote - infixl 6 `diffDays`, `diffTimes` diffDays :: E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Day) -> E.SqlExpr (E.Value Int) diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 42eb412ca..c3b3cb1ed 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -129,13 +129,14 @@ breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR breadcrumb FirmUsersR{} = i18nCrumb MsgMenuFirmUsers $ Just FirmAllR 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 PrintSendR = i18nCrumb MsgMenuPrintSend $ Just PrintCenterR breadcrumb PrintDownloadR{} = i18nCrumb MsgMenuPrintDownload $ Just PrintCenterR 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 (SchoolR ssh sRoute) = case sRoute of @@ -166,9 +167,10 @@ breadcrumb FaqR = i18nCrumb MsgBreadcrumbFaq $ Just InfoR breadcrumb HelpR = i18nCrumb MsgMenuHelp Nothing -breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing -breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing -breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed +breadcrumb HealthR = i18nCrumb MsgMenuHealth Nothing +breadcrumb (HealthInterfaceR _) = i18nCrumb MsgMenuHealthInterface (Just HealthR) +breadcrumb InstanceR = i18nCrumb MsgMenuInstance Nothing +breadcrumb StatusR = i18nCrumb MsgMenuHealth Nothing -- never displayed breadcrumb QualificationAllR = i18nCrumb MsgMenuQualifications Nothing 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 (LmsReportUploadR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh breadcrumb (LmsReportDirectR ssh qsh) = i18nCrumb MsgMenuLmsUpload $ Just $ LmsReportR ssh qsh -- never displayed --- +-- breadcrumb (LmsIdentR ssh qsh _ ) = breadcrumb $ LmsR ssh qsh -- just a redirect breadcrumb (LmsUserR ssh _qsh u ) = i18nCrumb MsgMenuLmsUser $ Just $ LmsUserSchoolR u ssh 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 guardM . lift . hasReadAccessTo $ CTutorialR tid ssh csh tutn TUsersR 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 TDeleteR -> i18nCrumb MsgMenuTutorialDelete . 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 = [] } + , NavPageActionPrimary + { navLink = NavLink + { navLabel = MsgMenuHealthInterface + , navRoute = HealthInterfaceR [] + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , navChildren = [] + } ] pageActions InstanceR = return [ NavPageActionPrimary @@ -2364,7 +2377,7 @@ pageActions (LmsR sid qsh) = return [ defNavLink MsgMenuLmsUpload $ LmsReportUploadR sid qsh , defNavLink MsgMenuLmsDirectUpload $ LmsReportDirectR sid qsh ] - } + } , NavPageActionSecondary { navLink = defNavLink MsgMenuLmsEdit $ LmsEditR sid qsh } @@ -2389,7 +2402,7 @@ pageActions (FirmUsersR fsh) = return [ NavPageActionPrimary { navLink = defNavLink MsgTableCompanyNrSupers $ FirmSupersR fsh , navChildren = [] - } + } ] pageActions (FirmSupersR fsh) = return [ NavPageActionPrimary @@ -2432,10 +2445,30 @@ pageActions PrintCenterR = do , 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 - return $ manualSend : take 9 dayLinks + return $ manualSend : printLog : printAck : take 9 dayLinks -pageActions AdminCrontabR = return +pageActions AdminCrontabR = return [ NavPageActionPrimary { navLink = defNavLink MsgMenuAdminJobs AdminJobsR , navChildren = [] diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 34811f1fd..d99be986a 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -24,6 +24,7 @@ import qualified Database.Esqueleto.Utils as E import Handler.Utils import Handler.Utils.Avs import Handler.Utils.Users +import Handler.Health.Interface import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -54,13 +55,15 @@ getAdminProblemsR = do flagNonZero n | n <= 0 = flagError True | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,) + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, (interfaceOks, interfaceTable)) <- runDB $ (,,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) <*> (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 -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) @@ -235,76 +238,3 @@ retrieveDriversRWithoutF now = do E.where_ $ E.exists (hasValidQual AvsLicenceRollfeld) E.&&. E.notExists (hasValidQual AvsLicenceVorfeld) 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 \ No newline at end of file diff --git a/src/Handler/Course/Edit.hs b/src/Handler/Course/Edit.hs index 127056489..ae88bb64c 100644 --- a/src/Handler/Course/Edit.hs +++ b/src/Handler/Course/Edit.hs @@ -279,8 +279,8 @@ getCourseNewR = do , E.desc $ courseCreated course] -- most recent created course E.limit 1 return course - template <- case listToMaybe oldCourses of - (Just oldTemplate) -> + template <- case oldCourses of + (oldTemplate:_) -> let newTemplate = courseToForm oldTemplate mempty mempty in return $ Just $ newTemplate { cfCourseId = Nothing @@ -289,7 +289,7 @@ getCourseNewR = do , cfRegTo = Nothing , cfDeRegUntil = Nothing } - Nothing -> do + [] -> do (tidOk,sshOk,cshOk) <- runDB $ (,,) <$> ifMaybeM mbTid True existsKey <*> ifMaybeM mbSsh True existsKey diff --git a/src/Handler/Course/List.hs b/src/Handler/Course/List.hs index 513e63f87..1a8784748 100644 --- a/src/Handler/Course/List.hs +++ b/src/Handler/Course/List.hs @@ -226,7 +226,16 @@ getCourseListR = do ] validator = def & 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 setTitleI MsgCourseListTitle $(widgetFile "courses") diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 82ebe492f..53eff795d 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -192,26 +192,37 @@ handleAddUserR tid ssh csh tdesc ttyp = do currentRoute <- fromMaybe (error "postCAddUserR called from 404-handler") <$> getCurrentRoute - confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction - -- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs - unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs - let - 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 + (_ , registerConfirmResult) <- runButtonForm FIDCourseRegisterConfirm + -- $logDebugS "***AbortProblem***" $ tshow registerConfirmResult + prefillUsers <- case registerConfirmResult of + Nothing -> return mempty + (Just BtnCourseRegisterAbort) -> do + addMessageI Warning MsgAborted + -- prefill confirmed users for convenience. Note that Browser-Back may also return to the filled form, but history.back() does not in Chrome + 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 + return $ Just $ Set.fromList $ fmap crActIdent confirmedActs + (Just BtnCourseRegisterConfirm) -> do + confirmedActs :: Set CourseRegisterActionData <- fmap Set.fromList . throwExceptT . mapMM encodedSecretBoxOpen . lookupPostParams $ toPathPiece PostCourseUserAddConfirmAction + -- $logDebugS "CAddUserR confirmedActs" . tshow $ Set.map Aeson.encode confirmedActs + unless (Set.null confirmedActs) $ do -- TODO: check that all acts are member of availableActs + let + 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] 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 ( (,,) <$> aopt (textField & cfStrip & cfCI & addDatalist tutNameSuggestions) diff --git a/src/Handler/Health/Interface.hs b/src/Handler/Health/Interface.hs new file mode 100644 index 000000000..7dbc96932 --- /dev/null +++ b/src/Handler/Health/Interface.hs @@ -0,0 +1,251 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- 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| +
+ #{plainMsg} +
+ ^{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 () diff --git a/src/Handler/Info.hs b/src/Handler/Info.hs index 497fcb6c4..f927908d4 100644 --- a/src/Handler/Info.hs +++ b/src/Handler/Info.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2023 Felix Hamann , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Felix Hamann , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -13,12 +13,12 @@ import Data.Map ((!)) import qualified Data.CaseInsensitive as CI import qualified Data.Set as Set -import qualified Database.Esqueleto.Legacy as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Legacy as E +-- import qualified Database.Esqueleto.Utils as E import Development.GitRev -import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..)) +-- import Auth.LDAP (ADError(..), ADInvalidCredentials(..), CampusMessage(..)) import Yesod.Auth.Message(AuthMessage(..)) @@ -175,6 +175,7 @@ showFAQ :: ( MonadAP m , MonadThrow m ) => Route UniWorX -> FAQItem -> m Bool +showFAQ _ FAQLoginExpired = return True showFAQ _ FAQNoCampusAccount = is _Nothing <$> maybeAuthId showFAQ (AuthR _) FAQCampusCantLogin = return True showFAQ _ FAQCampusCantLogin = is _Nothing <$> maybeAuthId @@ -183,38 +184,20 @@ showFAQ _ FAQForgottenPassword = is _Nothing <$> maybeAuthId showFAQ _ FAQNotLecturerHowToCreateCourses = and2M (is _Just <$> maybeAuthId) (not <$> hasWriteAccessTo CourseNewR) -showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors - = and2M (is _Just <$> maybeAuthId) - (or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR) - (hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR) - ) -showFAQ (CExamR tid ssh csh examn _) FAQExamPoints - = 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 +-- showFAQ (CourseR tid ssh csh _) FAQCourseCorrectorsTutors +-- = and2M (is _Just <$> maybeAuthId) +-- (or2M (hasWriteAccessTo $ CourseR tid ssh csh SheetNewR) +-- (hasWriteAccessTo $ CourseR tid ssh csh CTutorialNewR) +-- ) +-- showFAQ _ _ = return False prioFAQ :: Monad m => Route UniWorX -> FAQItem -> m Rational +prioFAQ _ FAQLoginExpired = return 2 prioFAQ _ FAQNoCampusAccount = return 1 prioFAQ _ FAQCampusCantLogin = return 1 prioFAQ _ FAQForgottenPassword = return 1 prioFAQ _ FAQNotLecturerHowToCreateCourses = return 1 -prioFAQ _ FAQCourseCorrectorsTutors = return 1 -prioFAQ _ FAQExamPoints = return 2 -prioFAQ _ FAQInvalidCredentialsAdAccountDisabled = return 3 getInfoLecturerR :: Handler Html diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index 3e4b00b24..1b149b95f 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -213,6 +213,6 @@ getLmsLearnersDirectR sid qsh = do $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered - <* runDB (logInterface "LMS" (ciOriginal qsh) (Just nr) "") + <* runDB (logInterface "LMS" (ciOriginal qsh) True (Just nr) "") -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod \ No newline at end of file diff --git a/src/Handler/LMS/Report.hs b/src/Handler/LMS/Report.hs index 201c2eab4..2e3ffb00b 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -294,8 +294,7 @@ postLmsReportUploadR sid qsh = do setTitleI MsgMenuLmsUpload [whamlet|$newline never
- ^{widget} -

+ ^{widget} |] @@ -315,12 +314,13 @@ postLmsReportDirectR sid qsh = do case enr of Left (e :: SomeException) -> do -- catch all to avoid ok220 in case of any error $logWarnS "LMS" $ "Report upload failed parsing: " <> tshow e + logInterface "LMS" (ciOriginal qsh) False Nothing "" return (badRequest400, "Exception: " <> tshow e) Right nr -> do let msg = "Success. LMS Report upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " $logInfoS "LMS" msg when (nr > 0) $ queueDBJob $ JobLmsReports qid - logInterface "LMS" (ciOriginal qsh) (Just nr) "" + logInterface "LMS" (ciOriginal qsh) True (Just nr) "" return (ok200, msg) [] -> do let msg = "Report upload file missing." diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index 6be31bf20..084cc74d6 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -7,10 +7,11 @@ module Handler.PrintCenter ( getPrintDownloadR - , getPrintCenterR, postPrintCenterR + , getPrintCenterR, postPrintCenterR , getPrintSendR , postPrintSendR , getPrintAckR , postPrintAckR - , postPrintAckDirectR + , getPrintAckDirectR, postPrintAckDirectR + , getPrintLogR ) where import Import @@ -26,7 +27,7 @@ import Database.Esqueleto.Utils.TH import Utils.Print --- import Data.Aeson (encode) +import qualified Data.Aeson as Aeson -- import qualified Data.Text as Text -- import qualified Data.Set as Set @@ -43,11 +44,11 @@ single :: (k,a) -> Map k a single = uncurry Map.singleton -data LRQF = LRQF - { lrqfLetter :: Text +data LRQF = LRQF + { lrqfLetter :: Text , lrqfUser :: Either UserEmail UserId , lrqfSuper :: Maybe (Either UserEmail UserId) - , lrqfQuali :: Entity Qualification + , lrqfQuali :: Entity Qualification , lrqfIdent :: LmsIdent , lrqfPin :: Text , lrqfExpiry :: Maybe Day @@ -62,12 +63,12 @@ makeRenewalForm tmpl = identifyForm FIDLmsLetter . validateForm validateLetterRe <*> areq (userField False Nothing) (fslI MsgLmsUser) (lrqfUser <$> tmpl) <*> aopt (userField False Nothing) (fslI MsgTableSupervisor) (lrqfSuper <$> 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) <*> aopt dayField (fslI MsgLmsQualificationValidUntil) (lrqfExpiry <$> tmpl) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgLmsRenewalReminder) (lrqfReminder <$> tmpl) - where + where lmsField = convertField LmsIdent getLmsIdent textField validateLetterRenewQualificationF :: FormValidator LRQF Handler () @@ -76,12 +77,12 @@ validateLetterRenewQualificationF = -- do return () lrqf2letter :: LRQF -> DB (Entity User, SomeLetter) -lrqf2letter LRQF{..} - | lrqfLetter == "r" = do +lrqf2letter LRQF{..} + | lrqfLetter == "r" = do usr <- getUser lrqfUser rcvr <- mapM getUser lrqfSuper now <- liftIO getCurrentTime - let letter = LetterRenewQualificationF + let letter = LetterRenewQualificationF { lmsLogin = lrqfIdent , lmsPin = lrqfPin , qualHolderID = usr ^. _entityKey @@ -96,13 +97,13 @@ lrqf2letter LRQF{..} , isReminder = lrqfReminder } return (fromMaybe usr rcvr, SomeLetter letter) - | lrqfLetter == "e" || lrqfLetter == "E" = do + | lrqfLetter == "e" || lrqfLetter == "E" = do rcvr <- mapM getUser lrqfSuper usr <- getUser lrqfUser usrShrt <- encrypt $ entityKey usr usrUuid <- encrypt $ entityKey usr urender <- liftHandler getUrlRender - let letter = LetterExpireQualification + let letter = LetterExpireQualification { leqHolderCFN = usrShrt , leqHolderID = usr ^. _entityKey , leqHolderDN = usr ^. _userDisplayName @@ -111,15 +112,15 @@ lrqf2letter LRQF{..} , leqId = lrqfQuali ^. _entityKey , leqName = lrqfQuali ^. _qualificationName . _CI , leqShort = lrqfQuali ^. _qualificationShorthand . _CI - , leqSchool = lrqfQuali ^. _qualificationSchool + , leqSchool = lrqfQuali ^. _qualificationSchool , leqUrl = pure . urender $ ForProfileDataR usrUuid } return (fromMaybe usr rcvr, SomeLetter letter) | otherwise = error "Unknown Letter Type encountered. Use 'e' or 'r' only." - where + where getUser :: Either UserEmail UserId -> DB (Entity User) getUser (Right uid) = getEntity404 uid - getUser (Left mail) = getBy404 $ UniqueEmail mail + getUser (Left mail) = getBy404 $ UniqueEmail mail data PJTableAction = PJActAcknowledge | PJActReprint @@ -190,7 +191,7 @@ pjTableQuery (printJob `E.LeftOuterJoin` recipient return (printJob, recipient, sender, course, quali) mkPJTable :: DB (FormResult (PJTableActionData, Set PrintJobId), Widget) -mkPJTable = do +mkPJTable = do let dbtSQLQuery = pjTableQuery dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) @@ -225,7 +226,7 @@ mkPJTable = do dbtFilter = mconcat [ single ("name" , FilterColumn . E.mkContainsFilterWithCommaPlus id $ views (to queryPrintJob) (E.^. PrintJobName)) , 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.mkDayBetweenFilter $ views (to queryPrintJob) (E.^. PrintJobCreated)) , 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 ("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 ("acknowledged" , FilterColumn . E.mkExactFilterLast $ views (to queryPrintJob) (E.isJust . (E.^. PrintJobAcknowledged))) ] dbtFilterUI mPrev = mconcat @@ -288,7 +289,7 @@ mkPJTable = do getPrintCenterR, postPrintCenterR :: Handler Html getPrintCenterR = postPrintCenterR -postPrintCenterR = do +postPrintCenterR = do (pjRes, pjTable) <- runDB mkPJTable formResult pjRes $ \case @@ -298,21 +299,21 @@ postPrintCenterR = do addMessageI Success $ MsgPrintJobAcknowledge num reloadKeepGetParams PrintCenterR (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) let nr_oks = getSum $ mconcat oks nr_tot = length pjIds mstat = bool Warning Success $ nr_oks == nr_tot addMessageI mstat $ MsgPrintJobReprint nr_oks nr_tot reloadKeepGetParams PrintCenterR - siteConf <- getYesod + siteConf <- getYesod let lprConf = siteConf ^. _appLprConf reroute = siteConf ^. _appMailRerouteTo lprWgt = [whamlet| LPR Konfiguration ist #{lprQueue lprConf}@#{lprHost lprConf}:#{lprPort lprConf}

$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 setTitleI MsgMenuApc @@ -322,7 +323,7 @@ postPrintCenterR = do getPrintSendR, postPrintSendR :: Handler Html getPrintSendR = postPrintSendR 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] now <- liftIO getCurrentTime let nowaday = utctDay now @@ -340,7 +341,7 @@ postPrintSendR = do def_lrqf = mkLetter <$> mbQual ((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 Right html -> sendResponse $ toTypedContent html Left err -> do @@ -348,7 +349,7 @@ postPrintSendR = do $logErrorS "LPR" msg addMessage Error $ toHtml msg pure () - _ -> do + _ -> do ok <- (runDB (lrqf2letter lrqf) >>= printLetter (Just uid)) >>= \case Left err -> do let msg = "PDF printing failed with error: " <> err @@ -399,26 +400,26 @@ postPrintAckR ackDay numAck chksm = do , formSubmit = FormNoSubmit } formResult ackRes $ \BtnConfirm -> do - numNew <- runDB $ do - pjs <- Ex.select $ do + numNew <- runDB $ do + pjs <- Ex.select $ do 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.&&. (pjDay Ex.==. Ex.val ackDay) + Ex.&&. (pjDay Ex.==. Ex.val ackDay) return $ pj Ex.^. PrintJobId let changed = numAck /= length pjs || chksm /= hash (Set.fromList (Ex.unValue <$> pjs)) if changed then return (-1) - else do + else do now <- liftIO getCurrentTime 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.where_ $ E.isNothing (pj E.^. PrintJobAcknowledged) E.&&. (pjDay E.==. E.val ackDay) -- Ex.updateCount $ do -- 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.where_ $ Ex.isNothing (pj Ex.^. PrintJobAcknowledged) -- Ex.&&. (pjDay Ex.==. Ex.val ackDay) @@ -427,29 +428,44 @@ postPrintAckR ackDay numAck chksm = do else addMessageI Error MsgPrintJobAcknowledgeFailed redirect PrintCenterR ackDayText <- formatTime SelFormatDate ackDay - siteLayoutMsg - (MsgPrintJobAcknowledgeQuestion numAck ackDayText) + siteLayoutMsg + (MsgPrintJobAcknowledgeQuestion numAck ackDayText) ackForm -- no header csv, containing a single column of lms identifiers (logins) -- instance Csv.FromRecord LmsIdent -- default suffices --- instance Csv.FromRecord Text where --- parseRecord v +-- instance Csv.FromRecord Text where +-- parseRecord v -- | length v >= 1 = v Csv..! 0 -- | otherwise = pure "ERROR" saveApcident :: UTCTime -> Natural -> Text -> JobDB Natural 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 + + ^{widget} + + |] + postPrintAckDirectR :: Handler Html postPrintAckDirectR = do now <- liftIO getCurrentTime (_params, files) <- runRequestBody (status, msg) <- case files of - [(_fhead,file)] -> do - runDBJobs $ do + [(_fhead,file)] -> do + runDBJobs $ do 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 .| linesUnboundedC .| foldMC (saveApcident now) 0 @@ -461,7 +477,7 @@ postPrintAckDirectR = do let msg = "Success: received " <> tshow nr <> " APC identifiers to be processed later." $logInfoS "LMS" msg when (nr > 0) $ queueDBJob JobPrintAck - return (ok200, msg) + return (ok200, msg) [] -> do let msg = "Error: No file received. A file of lms identifiers must be supplied for print job acknowledging." $logWarnS "APC" msg @@ -471,3 +487,55 @@ postPrintAckDirectR = do $logErrorS "APC" msg return (badRequest400, msg) 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}|] diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 327900b59..bef117074 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -150,7 +150,7 @@ getQualificationSAPDirectR = do msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers $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 <> "\"" csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 715c910a5..4648cf647 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -35,6 +35,8 @@ import Handler.Utils.Qualification 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 diff --git a/src/Handler/Utils/Concurrent.hs b/src/Handler/Utils/Concurrent.hs new file mode 100644 index 000000000..1faaff498 --- /dev/null +++ b/src/Handler/Utils/Concurrent.hs @@ -0,0 +1,38 @@ +-- SPDX-FileCopyrightText: 2024 Steffen Jost +-- +-- 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 + diff --git a/src/Handler/Utils/DateTime.hs b/src/Handler/Utils/DateTime.hs index 49cc6a7ba..2b05f208f 100644 --- a/src/Handler/Utils/DateTime.hs +++ b/src/Handler/Utils/DateTime.hs @@ -93,8 +93,8 @@ toMorning = toTimeOfDay 6 0 0 toTimeOfDay :: Int -> Int -> Pico -> Day -> UTCTime toTimeOfDay todHour todMin todSec d = localTimeToUTCTZ appTZ $ LocalTime d TimeOfDay{..} -addHours :: Integer -> UTCTime -> UTCTime -addHours = addUTCTime . secondsToNominalDiffTime . fromInteger . (* 3600) +addHours :: Integral n => n -> UTCTime -> UTCTime +addHours = addUTCTime . secondsToNominalDiffTime . fromIntegral . (* 3600) instance HasLocalTime UTCTime where toLocalTime = utcToLocalTime diff --git a/src/Handler/Utils/LMS.hs b/src/Handler/Utils/LMS.hs index e6f35e8e9..78d6dfab8 100644 --- a/src/Handler/Utils/LMS.hs +++ b/src/Handler/Utils/LMS.hs @@ -115,7 +115,7 @@ csvFilenameLmsReport = makeLmsFilename "report" makeLmsFilename :: MonadHandler m => Text -> QualificationShorthand -> m Text makeLmsFilename ftag (citext2lower -> qsh) = do ymth <- getYMTH - return $ "fradrive_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv" + return $ "fradrive_" <> "test" <> "_" <> qsh <> "_" <> ftag <> "_" <> ymth <> ".csv" -- | Return current datetime in YYYYMMDDHH format 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 } randomLMSIdent :: MonadIO m => Maybe Char -> m LmsIdent -randomLMSIdent Nothing = LmsIdent . Text.cons 'j' <$> randomText [] (pred lengthIdent) -- idents must not contain '_' nor '-' -randomLMSIdent (Just c) = LmsIdent . Text.cons c <$> randomText [] (pred lengthIdent) +randomLMSIdent Nothing = LmsIdent . Text.cons 't' . Text.cons 'j' <$> randomText [] (pred $ pred lengthIdent) -- idents must not contain '_' nor '-' +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 prefix banList = untilJustMaxM maxLmsUserIdentRetries getIdentOk diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 0e59307d7..82d58fea6 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -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 - 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') GuessUserDisplayName userDisplayName' -> user E.^. UserDisplayName `containsAsSet` userDisplayName' GuessUserSurname userSurname' -> user E.^. UserSurname `containsAsSet` userSurname' diff --git a/src/Jobs.hs b/src/Jobs.hs index dfb16ee5d..d08a6f500 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -47,7 +47,7 @@ import qualified Control.Monad.Catch as Exc import Data.Time.Zones -import Control.Concurrent.STM (stateTVar, retry) +import Control.Concurrent.STM (stateTVar) import Control.Concurrent.STM.Delay import UnliftIO.Concurrent (forkIO, myThreadId, threadDelay) @@ -260,7 +260,7 @@ manageJobPool foundation@UniWorX{..} unmask = shutdownOnException $ \routeExc -> (nextVal, newQueue) <- MaybeT . lift . fmap jqDequeue $ readTVar chan lift . lift $ writeTVar chan newQueue 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) whenIsJust next $ \(nextVal, receiver) -> do atomically $ readTVar receiver >>= jqInsert nextVal >>= (writeTVar receiver $!) @@ -373,8 +373,8 @@ execCrontab = do State.modify . HashMap.filterWithKey $ \k _ -> HashMap.member k crontab prevExec <- State.get case earliestJob settings prevExec crontab refT of - Nothing -> liftBase retry - Just (_, MatchNone) -> liftBase retry + Nothing -> liftBase retrySTM + Just (_, MatchNone) -> liftBase retrySTM Just x -> return (crontab, x, prevExec) do diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 763f46b39..136ea518e 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -117,7 +117,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } 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 qid uid = JobHandlerAtomic act @@ -202,7 +202,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act -- E.&&. luser E.?. LmsUserQualification E.?=. E.val qid -- E.&&. E.isNothing (luser E.^. LmsUserStatus) -- 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) 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 ] @@ -223,7 +223,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act `E.on` (\(quser :& qblock) -> qblock E.?. QualificationUserBlockQualificationUser E.?=. quser E.^. QualificationUserId E.&&. qblock `isLatestBlockBefore` E.val now ) - E.where_ $ -- E.not_ (validQualification now quser) -- currently invalid + E.where_ $ -- E.not__ (validQualification now quser) -- currently invalid quser E.^. QualificationUserQualification E.==. E.val qid -- correct qualification E.&&. quserToNotify now quser qblock -- recently became invalid or blocked pure (quser E.^. QualificationUserUser) @@ -259,7 +259,7 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act deleteWhere [LmsUserQualification ==. qid, LmsUserIdent <-. delusers] -- deleteWhere [LmsAuditQualification ==. qid, LmsAuditIdent <-. delusers] 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 @@ -313,7 +313,8 @@ dispatchJobLmsReports qid = JobHandlerAtomic act E.&&. lreport E.^. LmsReportLock E.==. E.true ) -- B) notify all newly reported users that lms is available - let luserFltrNew luser = E.isNothing $ luser E.^. LmsUserReceived -- not seen before, just starting + 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 } } in luserQry luserFltrNew (const $ const E.true) >>= mapM_ notifyNewLearner -- C) block qualifications for failed learners by calling qualificationUserBlocking [uids] (includes audit), notified during expiry diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 107bf627c..e1545dc89 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -375,6 +375,8 @@ jobNoQueueSame = \case notifyNoQueueSame :: Notification -> Maybe JobNoQueueSame notifyNoQueueSame = \case 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 jobMovable :: JobCtl -> Bool diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index 662178fa1..1f78bbbaf 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Steffen Jost ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -49,6 +49,7 @@ import qualified Data.Time.Zones as TZ data ManualMigration = Migration20230524QualificationUserBlock | Migration20230703LmsUserStatus + | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values | Migration20240312OAuth2 deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) 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 [executeQQ| ALTER TABLE "user" ADD COLUMN "password_hash" VARCHAR NULL; diff --git a/src/Utils.hs b/src/Utils.hs index 2093da8b2..c47f29992 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -23,7 +23,7 @@ import qualified Data.CaseInsensitive as CI import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as CBS -import qualified Data.Char as Char +-- import qualified Data.Char as Char import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -319,9 +319,16 @@ citext2string = Text.unpack . CI.original string2citext :: String -> CI Text 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 text2asciiAlphaNum :: Text -> Text -text2asciiAlphaNum = Text.filter (\c -> Char.isAlphaNum c && Char.isAscii c) +text2asciiAlphaNum = text2AlphaNumPlus ['-','_'] . Text.replace "ä" "ae" . Text.replace "Ä" "Ae" . Text.replace "Æ" "ae" diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index d6cf508f7..8884c221b 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -382,6 +382,8 @@ identifyForm = identifyForm' id -- Buttons (new version ) -- ---------------------------- +-- Bemerke: Back Button Widget implementierbar durch