diff --git a/CHANGELOG.md b/CHANGELOG.md index 2668fd3ca..6c994dfbb 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,34 @@ 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.14](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.13...v27.4.14) (2023-07-14) + + +### Bug Fixes + +* **avs:** eliminate call to undefined in Esqueleto.Internals ([240c6f8](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/240c6f81f81d1872317da01411fa67ec97e3b16d)) +* **job:** fix [#95](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/95) by implementing queued job deletion for admins ([5b9a554](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/5b9a5545457dbe506d20f7362fb6e0d6bae4f7f4)) + +## [27.4.13](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.12...v27.4.13) (2023-07-12) + + +### Bug Fixes + +* **avs:** background avs synch yielding undefined due to wrong monad ([2e59d3c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/2e59d3c2ea4d5017be9b4e578b7da12c4da0e2fa)) +* **lms:** add safeguard to LmsUserlist dispatch running twice, thus ending LMS prematurely ([a8df40d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a8df40d9f8943f2e0c4e219074486dbbf0eaf0fe)) +* **lpr:** fix [#96](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/96) by various minor improvements to PrintCenter ([80c632d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/80c632df1ca4871c10cdac1141d87f92a7646cf7)) +* **tutorial:** fix [#94](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/94) tutorial renaming (de) and template naming ([1ce8f75](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1ce8f75c2d192051929b1a74b17f4e6494961901)) + +## [27.4.12](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.11...v27.4.12) (2023-07-08) + + +### Bug Fixes + +* **avs:** attempt to fix avs background jobs ([bbaa42e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/bbaa42eefaaae88982b091973adb295cdc0e80ff)) +* **avs:** avs background synchs and lms userlist result no longer block handler ([0beb0e4](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/0beb0e4011745ea51906e018c53548bb2f6d978e)) +* **avs:** fix [#7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/7) by sequencing avs background jobs one after another ([6dc3d8d](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/6dc3d8d059e132d19c119c5f1de906342fdf6d2c)) +* **notifications:** direct notifications now respect user triggers ([3e5f271](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3e5f271cacfcc5dbd95aa68a342f56db566f8dee)) + ## [27.4.11](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.10...v27.4.11) (2023-06-20) diff --git a/messages/uniworx/categories/courses/courses/de-de-formal.msg b/messages/uniworx/categories/courses/courses/de-de-formal.msg index f0df8c433..a0bf4391e 100644 --- a/messages/uniworx/categories/courses/courses/de-de-formal.msg +++ b/messages/uniworx/categories/courses/courses/de-de-formal.msg @@ -81,21 +81,21 @@ CourseSubmissionGroup: Feste Abgabegruppe SubmissionGroupEmptyIsUnsetTip: Leer lassen um Benutzer:innen aus den jeweiligen Abgabegruppen ersatzlos zu entfernen CourseParticipantsRegisterHeading: Kursartteilnehmer:innen hinzufügen CourseParticipantsRegisterActionAddParticipants: Personen zur Kursart anmelden -CourseParticipantsRegisterActionAddTutorialMembers: Personen zur Kursart und Kursgruppe anmelden +CourseParticipantsRegisterActionAddTutorialMembers: Personen zur Kursart und Kurs anmelden CourseParticipantsRegisterUsersField: Zur Kursart anzumeldende Personen CourseParticipantsRegisterUsersFieldTip: Bitte Ausweiskartennummer inklusive Punkt, Fraport Personalnummer oder Email angeben. Mehrere Personen bitte mit Komma oder Leerzeichen trennen. -CourseParticipantsRegisterTutorialOption: Kursartteilnehmer:innen zu Kursgruppe anmelden? -CourseParticipantsRegisterTutorialField: Kursgruppe -CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Kursgruppe mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Kursgruppe mit diesem Namen vorhanden, werden die Kursartteilnehmenden dieser hinzugefügt. +CourseParticipantsRegisterTutorialOption: Kursartteilnehmer:innen zu Kurs anmelden? +CourseParticipantsRegisterTutorialField: Kurs +CourseParticipantsRegisterTutorialFieldTip: Ist aktuell keine Kurs mit diesem Namen vorhanden, wird eine neue erstellt. Ist bereits eine Kurs mit diesem Namen vorhanden, werden die Kursartteilnehmenden dieser hinzugefügt. CourseParticipantsRegisterNoneGiven: Es wurden keine anzumeldenden Personen angegeben! CourseParticipantsRegisterNotFoundInAvs n@Int: Zu #{n} #{pluralDE n "Angabe konnte keine übereinstimmende Person" "Angaben konnten keine übereinstimmenden Personen"} im AVS gefunden werden CourseParticipantsRegisterTutorialFirstDayTip: Wenn ein neuer Kurs gemäß einer Vorlage erstellt wird, werden die Zeiten gemäß dem Starttag angepasst CourseParticipantsInvited n@Int: #{n} #{pluralDE n "Einladung" "Einladungen"} per E-Mail verschickt 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 Kursgruppe 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 Kursgruppe angemeldet +CourseParticipantsRegisteredTutorial n@Int: #{n} #{pluralDE n "Teinehmer:in" "Teilnehmer:innen"} erfolgreich zur 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/categories/health/de-de-formal.msg b/messages/uniworx/categories/health/de-de-formal.msg index 34566d000..2c8355493 100644 --- a/messages/uniworx/categories/health/de-de-formal.msg +++ b/messages/uniworx/categories/health/de-de-formal.msg @@ -3,12 +3,13 @@ # SPDX-License-Identifier: AGPL-3.0-or-later HealthReport: Instanz-Zustand -HealthMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell -HealthHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden -HealthLDAPAdmins: Anteil der Administrator:innen mit LDAP Authentifizierung, welche tatsächlich im LDAP-Verzeichnis gefunden werden können -HealthSMTPConnect: SMTP-Server kann erreicht werden -HealthWidgetMemcached: Memcached-Server liefert Widgets korrekt aus -HealthActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen +HealthCheckMatchingClusterConfig: Cluster-geteilte Konfiguration ist aktuell +HealthCheckHTTPReachable: Cluster kann an der erwarteten URL über HTTP erreicht werden +HealthCheckLDAPAdmins: Anteil der Administrator:innen mit LDAP Authentifizierung, welche tatsächlich im LDAP-Verzeichnis gefunden werden können +HealthCheckSMTPConnect: SMTP-Server kann erreicht werden +HealthCheckWidgetMemcached: Memcached-Server liefert Widgets korrekt aus +HealthCheckActiveJobExecutors: Anteil der job-workers, die neue Befehle annehmen +HealthCheckDoesFlush: Abgearbeitete Jobs werden aufgeräumt InstanceIdentification: Instanz-Identifikation InstanceId: Instanz-Nummer ClusterId: Cluster-Nummer \ No newline at end of file diff --git a/messages/uniworx/categories/health/en-eu.msg b/messages/uniworx/categories/health/en-eu.msg index 1bf279300..4e24bd8bb 100644 --- a/messages/uniworx/categories/health/en-eu.msg +++ b/messages/uniworx/categories/health/en-eu.msg @@ -3,12 +3,13 @@ # SPDX-License-Identifier: AGPL-3.0-or-later HealthReport: Health report -HealthMatchingClusterConfig: Cluster config matches -HealthHTTPReachable: Cluster can be reached under the expected URL via HTTP -HealthLDAPAdmins: Proportion of administrators with LDAP authentication that were actually found in the LDAP directory -HealthSMTPConnect: SMTP server is reachable -HealthWidgetMemcached: Memcached server is serving widgets correctly -HealthActiveJobExecutors: Proportion of job workers accepting new jobs +HealthCheckMatchingClusterConfig: Cluster config matches +HealthCheckHTTPReachable: Cluster can be reached under the expected URL via HTTP +HealthCheckLDAPAdmins: Proportion of administrators with LDAP authentication that were actually found in the LDAP directory +HealthCheckSMTPConnect: SMTP server is reachable +HealthCheckWidgetMemcached: Memcached server is serving widgets correctly +HealthCheckActiveJobExecutors: Proportion of job workers accepting new jobs +HealthCheckDoesFlush: Executed jobs are removed InstanceIdentification: Instance identification InstanceId: Instance id ClusterId: Cluster id diff --git a/messages/uniworx/categories/print/de-de-formal.msg b/messages/uniworx/categories/print/de-de-formal.msg index 1eb9eb034..32fe30556 100644 --- a/messages/uniworx/categories/print/de-de-formal.msg +++ b/messages/uniworx/categories/print/de-de-formal.msg @@ -4,6 +4,7 @@ PJActAcknowledge: Druck und Versand bestätigen PJActReprint: Erneut drucken über APC +PJActReprintIgnoreReroute: Drucken auch bei aktiver Mail-Umleitung erzwingen PrintJobName: Bezeichnung PrintJobFilename: Dateiname PrintJobId !ident-ok: Id diff --git a/messages/uniworx/categories/print/en-eu.msg b/messages/uniworx/categories/print/en-eu.msg index a1090de43..053fd1a7e 100644 --- a/messages/uniworx/categories/print/en-eu.msg +++ b/messages/uniworx/categories/print/en-eu.msg @@ -4,6 +4,7 @@ PJActAcknowledge: Acknowledge printing and mailing PJActReprint: Print again via APC +PJActReprintIgnoreReroute: Force printing to APC, even if mail-reroute-to option is active PrintJobName: Description PrintJobFilename: Filename PrintJobId: Id diff --git a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg index 3d083e6e7..9087f1ca0 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/de-de-formal.msg @@ -66,6 +66,7 @@ BreadcrumbFaq !ident-ok: FAQ BreadcrumbSheetPersonalisedFiles: Personalisierte Dateien herunterladen BreadcrumbCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen BreadcrumbAdminCrontab !ident-ok: Crontab +BreadcrumbAdminJobs !ident-ok: Jobs BreadcrumbError: Fehler BreadcrumbUpload !ident-ok: Upload BreadcrumbUserAdd: Benutzer:in anlegen diff --git a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg index deadd76e7..5763051d1 100644 --- a/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg +++ b/messages/uniworx/utils/navigation/breadcrumbs/en-eu.msg @@ -66,6 +66,7 @@ BreadcrumbFaq: FAQ BreadcrumbSheetPersonalisedFiles: Download personalised sheet files BreadcrumbCourseSheetPersonalisedFiles: Download template for personalised sheet files BreadcrumbAdminCrontab: Crontab +BreadcrumbAdminJobs !ident-ok: Jobs BreadcrumbError: Error BreadcrumbUpload: Upload BreadcrumbUserAdd: Add user diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index a253ee93c..06916dd81 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -107,6 +107,7 @@ MenuFaq !ident-ok: FAQ MenuSheetPersonalisedFiles: Personalisierte Dateien herunterladen MenuCourseSheetPersonalisedFiles: Vorlage für personalisierte Übungsblatt-Dateien herunterladen MenuAdminCrontab !ident-ok: Crontab +MenuAdminJobs: Job Warteschlange MenuGlossary: Begriffsverzeichnis MenuVersion: Versionsgeschichte MenuCourseNewsNew: Neue Kursartnachricht diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 798d1468a..0c8086373 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -108,6 +108,7 @@ MenuFaq: FAQ MenuSheetPersonalisedFiles: Download personalised sheet files MenuCourseSheetPersonalisedFiles: Download template for personalised sheet files MenuAdminCrontab: Crontab +MenuAdminJobs: Job queue MenuGlossary: Glossary MenuVersion: Version history MenuCourseNewsNew: Add course type news diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index b9e575dda..16d43de61 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -78,3 +78,11 @@ TableCompany: Firma TableCompanies: Firmen TableCompanyNos: Firmennummern TableSupervisor: Ansprechpartner +TableCreationTime: Erstellungszeit +TableJob !ident-ok: Job +TableJobContent !ident-ok: Parameter +TableJobLockTime: Bearbeitung seit +TableJobLockInstance: Bearbeiter +TableJobCreationInstance: Ersteller +ActJobDelete: Job entfernen +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} Jobs entfernt \ No newline at end of file diff --git a/messages/uniworx/utils/table_column/en-eu.msg b/messages/uniworx/utils/table_column/en-eu.msg index 5187d80dc..17fbfe79a 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -78,3 +78,11 @@ TableCompany: Company TableCompanies: Companies TableCompanyNos: Company numbers TableSupervisor: Supervisor +TableCreationTime: Creation +TableJob !ident-ok: Job +TableJobContent !ident-ok: Parameters +TableJobLockTime: Lock time +TableJobLockInstance: Worker +TableJobCreationInstance: Creator +ActJobDelete: Delete job +TableJobActDeleteFeedback n@Int m@Int: #{n}/#{m} queued jobs deleted \ No newline at end of file diff --git a/nix/docker/demo-version.json b/nix/docker/demo-version.json index afe4fccef..82f0bdba7 100644 --- a/nix/docker/demo-version.json +++ b/nix/docker/demo-version.json @@ -1,3 +1,3 @@ { - "version": "27.4.11" + "version": "27.4.14" } diff --git a/nix/docker/version.json b/nix/docker/version.json index afe4fccef..82f0bdba7 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.11" + "version": "27.4.14" } diff --git a/package-lock.json b/package-lock.json index c2dc210aa..e9fdffe9a 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.11", + "version": "27.4.14", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 6eccdb0b4..9f2805cf4 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.11", + "version": "27.4.14", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 1791191ce..cfe01b928 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.11 +version: 27.4.14 dependencies: - base - yesod diff --git a/routes b/routes index 1932a90ac..675f15ed4 100644 --- a/routes +++ b/routes @@ -66,6 +66,7 @@ /admin/errMsg AdminErrMsgR GET POST /admin/tokens AdminTokensR GET POST /admin/crontab AdminCrontabR GET +/admin/crontab/jobs AdminJobsR GET POST /admin/avs AdminAvsR GET POST /admin/avs/#CryptoUUIDUser AdminAvsUserR GET /admin/ldap AdminLdapR GET POST diff --git a/src/Application.hs b/src/Application.hs index 6592a8342..90d344bfd 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -550,8 +550,8 @@ warpSettings foundation = defaultSettings & Set.filter (is _Just . (foundation ^. _appHealthCheckInterval)) atomically $ do results <- readTVar $ foundation ^. _appHealthReport - guard $ activeChecks == Set.map (classifyHealthReport . snd) results - guard . (== Min HealthSuccess) $ foldMap (Min . healthReportStatus . snd) results + guard $ activeChecks `Set.isSubsetOf` Set.map (classifyHealthReport . snd) results + guard . (/= Min HealthFailure) $ foldMap (Min . healthReportStatus . snd) results notifyReady | otherwise -> notifyReady @@ -679,7 +679,7 @@ appMain = runResourceT $ do interval <- mInterval let lastSuccess = maybeMonoid mResults & Set.filter (\(_, rep) -> classifyHealthReport rep == hc) - & Set.filter (\(_, rep) -> healthReportStatus rep >= HealthSuccess) + & Set.filter (\(_, rep) -> healthReportStatus rep > HealthFailure) & Set.mapMonotonic (view _1) & Set.lookupMax diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index f900b2857..7b30a26a5 100644 --- a/src/Foundation/I18n.hs +++ b/src/Foundation/I18n.hs @@ -319,6 +319,7 @@ appLanguagesOpts = do langOptions = map mkOption $ toList appLanguages return $ mkOptionList langOptions +embedRenderMessage ''UniWorX ''HealthCheck id embedRenderMessage ''UniWorX ''MessageStatus ("Message" <>) embedRenderMessage ''UniWorX ''NotificationTrigger $ ("NotificationTrigger" <>) . concat . drop 1 . splitCamel embedRenderMessage ''UniWorX ''StudyFieldType id diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index cfefd462f..61889afd1 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -112,6 +112,7 @@ breadcrumb AdminTestPdfR = i18nCrumb MsgMenuAdminTest $ Just breadcrumb AdminErrMsgR = i18nCrumb MsgMenuAdminErrMsg $ Just AdminR breadcrumb AdminTokensR = i18nCrumb MsgMenuAdminTokens $ Just AdminR breadcrumb AdminCrontabR = i18nCrumb MsgBreadcrumbAdminCrontab $ Just AdminR +breadcrumb AdminJobsR = i18nCrumb MsgBreadcrumbAdminJobs $ Just AdminCrontabR breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR breadcrumb AdminAvsUserR{} = i18nCrumb MsgAvsPersonInfo $ Just AdminAvsR breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR @@ -2398,6 +2399,13 @@ pageActions PrintCenterR = do dayLinks <- mapM toDayAck $ Map.toAscList dayMap return $ manualSend : take 9 dayLinks +pageActions AdminCrontabR = return + [ NavPageActionPrimary + { navLink = defNavLink MsgMenuAdminJobs AdminJobsR + , navChildren = [] + } + ] + pageActions _ = return [] submissionList :: ( MonadIO m diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 3775b0359..97cc51c45 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -54,9 +54,8 @@ getAdminProblemsR = do -- (Left (UnsupportedContentType "text/html" resp)) -> Left $ text2widget "Html received" (Left e) -> return $ Left $ text2widget $ tshow (e :: SomeException) (Right AvsLicenceDifferences{..}) -> do - let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld - -- mapM_ (queueJob' . flip JobSynchroniseAvsId cutOffAvsSynch) problemIds - runDBJobs . forM_ problemIds $ queueDBJob . flip JobSynchroniseAvsId (Just nowaday) + let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld + forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday) return $ Right ( Set.size avsLicenceDiffRevokeAll , Set.size avsLicenceDiffGrantVorfeld diff --git a/src/Handler/Admin/Crontab.hs b/src/Handler/Admin/Crontab.hs index 12f4349de..5cb000074 100644 --- a/src/Handler/Admin/Crontab.hs +++ b/src/Handler/Admin/Crontab.hs @@ -6,23 +6,35 @@ module Handler.Admin.Crontab ( getAdminCrontabR + , getAdminJobsR + , postAdminJobsR ) where import Import import Jobs -import Handler.Utils.DateTime +import Handler.Utils -import qualified Data.Aeson.Encode.Pretty as Pretty -import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder') +-- import Data.Aeson (fromJSON) +-- import qualified Data.Aeson as Aeson +-- import qualified Data.Aeson.Types as Aeson +import qualified Data.Aeson.Encode.Pretty as Pretty +-- import qualified Data.CaseInsensitive as CI import qualified Data.Text as Text import qualified Data.Text.Lazy.Builder as Text.Builder +import qualified Data.Set as Set +import qualified Data.Map as Map import qualified Data.HashSet as HashSet import qualified Data.HashMap.Strict as HashMap import qualified Data.UUID as UUID +import Database.Persist.Sql (deleteWhereCount) +import qualified Database.Esqueleto.Legacy as E +import qualified Database.Esqueleto.Utils as E +-- import Database.Esqueleto.Utils.TH + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 1 @@ -89,10 +101,125 @@ getAdminCrontabR = do provideJson mCrontab' provideRep . return . Text.Builder.toLazyText $ doEnc mCrontab' where - doEnc :: _ => a -> _ - doEnc = encodePrettyToTextBuilder' Pretty.defConfig + doEnc :: ToJSON a => a -> _ + doEnc = Pretty.encodePrettyToTextBuilder' Pretty.defConfig { Pretty.confIndent = Pretty.Spaces 2 , Pretty.confCompare = comparing $ \t -> ( t `elem` ["instruction", "job", "notification"] , Text.splitOn "-" t ) } + + +data JobTableAction = ActJobDelete + deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) + +instance Universe JobTableAction +instance Finite JobTableAction +nullaryPathPiece ''JobTableAction $ camelToPathPiece' 1 +embedRenderMessage ''UniWorX ''JobTableAction id + +-- Not yet needed, since there is no additional data for now (also, postprocess did not type somehow) +-- data JobTableActionData = ActJobDeleteData +-- deriving (Eq, Ord, Read, Show, Generic) + + +getAdminJobsR, postAdminJobsR :: Handler Html +getAdminJobsR = postAdminJobsR +postAdminJobsR = do + let + jobsDBTable = DBTable{..} + where + resultJob :: Lens' (DBRow (Entity QueuedJob)) (Entity QueuedJob) + resultJob = _dbrOutput + + dbtIdent :: Text + dbtIdent = "queued-jobs" + + dbtSQLQuery = return + dbtRowKey = (E.^. QueuedJobId) + dbtProj = dbtProjId + dbtColonnade = mconcat + [ dbSelect (applying _2) id (return . view (resultJob . _entityKey)) + , sortable (Just "job") (i18nCell MsgTableJob) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe textCell $ getJobName queuedJobContent + , sortable (Just "creation-time") (i18nCell MsgTableCreationTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> dateTimeCell queuedJobCreationTime + , sortable (Just "content") (i18nCell MsgTableJobContent) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cell [whamlet|#{doEnc queuedJobContent}|] & addCellClass ("json"::Text) + , sortable (Just "lock-time") (i18nCell MsgTableJobLockTime) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe dateTimeCell queuedJobLockTime + , sortable (Just "lock-instance") (i18nCell MsgTableJobLockInstance) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> cellMaybe (stringCell . show) queuedJobLockInstance + , sortable (Just "creation-instance") (i18nCell MsgTableJobCreationInstance) $ \(view $ resultJob . _entityVal -> QueuedJob{..}) -> stringCell $ show queuedJobCreationInstance + ] + dbtSorting = Map.fromList + [ ("creation-time" , SortColumnNullsInv (E.^. QueuedJobCreationTime)) + , ("job" , SortColumn (\v -> v E.^. QueuedJobContent E.->>. "job")) + , ("content" , SortColumn (E.^. QueuedJobContent)) + , ("lock-time" , SortColumnNullsInv (E.^. QueuedJobLockTime)) + , ("lock-instance" , SortColumn (E.^. QueuedJobLockInstance)) + , ("creation-instance", SortColumn (E.^. QueuedJobCreationInstance)) + ] + dbtFilter = Map.fromList + [ + ("job", FilterColumn $ E.mkContainsFilter (\v -> v E.^. QueuedJobContent E.->>. "job")) + ] + dbtFilterUI = \mPrev -> mconcat + [ + prismAForm (singletonFilter "job" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift textField) (fslI MsgTableJob) + ] + dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } + acts :: Map JobTableAction (AForm Handler JobTableAction) + acts = Map.singleton ActJobDelete $ pure ActJobDelete + dbtParams = DBParamsForm + { dbParamsFormAdditional = + renderAForm FormStandard + $ (, mempty) . First . Just + <$> multiActionA acts (fslI MsgTableAction) Nothing + , dbParamsFormMethod = POST + , dbParamsFormAction = Nothing -- Just $ SomeRoute currentRoute + , dbParamsFormAttrs = [] + , dbParamsFormSubmit = FormSubmit + , dbParamsFormEvaluate = liftHandler . runFormPost + , dbParamsFormResult = id + , dbParamsFormIdent = def + } + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + dbtExtraReps = [] + -- jobsDBTableValidator :: PSValidator (MForm Handler) (FormResult (First JobTableAction, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob)))) + jobsDBTableValidator = def + & defaultSorting [SortDescBy "creation-time"] + -- postprocess :: FormResult (First JobTableAction, DBFormResult QueuedJobId Bool (DBRow (Entity QueuedJob))) + -- -> FormResult (JobTableAction, Set QueuedJobId) + postprocess inp = do + (First (Just act), jobMap) <- inp + let jobSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) jobMap + return (act, jobSet) + (jobActRes, jobsTable) <- runDB (over _1 postprocess <$> dbTable jobsDBTableValidator jobsDBTable) + + formResult jobActRes $ \case + (ActJobDelete, jobIds) -> do + let jobReq = length jobIds + rmvd <- fromIntegral <$> runDB (deleteWhereCount + [ QueuedJobLockTime ==. Nothing + , QueuedJobLockInstance ==. Nothing + , QueuedJobId <-. Set.toList jobIds + ]) + addMessageI (bool Success Warning $ rmvd < jobReq) (MsgTableJobActDeleteFeedback rmvd jobReq) + reloadKeepGetParams AdminJobsR + + + siteLayoutMsg MsgMenuAdminJobs $ do + setTitleI MsgMenuAdminJobs + [whamlet| + ^{jobsTable} + |] + where + doEnc :: ToJSON a => a -> _ + doEnc = Pretty.encodePrettyToTextBuilder' Pretty.defConfig + { Pretty.confIndent = Pretty.Spaces 2 + , Pretty.confCompare = comparing $ \t -> ( t `elem` ["job", "notification"] + , Text.splitOn "-" t + ) + } + + getJobName :: Value -> Maybe Text + getJobName (Object o) + | Just (String s) <- HashMap.lookup "job" o = Just s -- $ kebabToCamel s + getJobName _ = Nothing \ No newline at end of file diff --git a/src/Handler/Course/ParticipantInvite.hs b/src/Handler/Course/ParticipantInvite.hs index 4b79d8c86..d31cd0d41 100644 --- a/src/Handler/Course/ParticipantInvite.hs +++ b/src/Handler/Course/ParticipantInvite.hs @@ -52,7 +52,7 @@ tutorialDefaultName :: Maybe TutorialType -> Day -> TutorialName tutorialDefaultName Nothing = CI.mk . tshow -- Don't use user date display setting, so that tutorial default names conform to all users tutorialDefaultName (Just ttyp) = let prefix = CI.mk $ snd $ Text.breakOnEnd (CI.original tutorialTypeSeparator) $ CI.original ttyp - in ((prefix <> tutorialTypeSeparator) <>) . tutorialDefaultName Nothing + in (<> (tutorialTypeSeparator <> prefix)) . tutorialDefaultName Nothing data ButtonCourseRegisterMode = BtnCourseRegisterConfirm | BtnCourseRegisterAbort deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) diff --git a/src/Handler/Health.hs b/src/Handler/Health.hs index aad83d566..e06f688ae 100644 --- a/src/Handler/Health.hs +++ b/src/Handler/Health.hs @@ -6,7 +6,7 @@ module Handler.Health where import Import --- import Handler.Utils +import Handler.Utils.DateTime (formatTimeW) import qualified Data.Aeson.Encode.Pretty as Aeson import qualified Data.Text.Lazy.Builder as Builder @@ -34,7 +34,7 @@ getHealthR = do waitResult <- atomically $ maybe (pure $ Left False) (fmap (const $ Left True) . waitDelay) delay <|> (fmap Right . assertM (not. Set.null) $ readTVar reportStore) case waitResult of Left False -> sendResponseStatus noContent204 () - Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text) + Left True -> sendResponseStatus internalServerError500 ("System is not generating HealthReports" :: Text) -- can this ever happen after it was non-null? Right _ -> redirect HealthR Just healthReports -> do let (Max lastUpdated, Min status) = ofoldMap1 (Max *** Min . healthReportStatus) healthReports @@ -48,37 +48,41 @@ getHealthR = do setLastModified lastUpdated let status' - | HealthSuccess <- status - = ok200 - | otherwise + | HealthFailure <- status = internalServerError500 + | otherwise + = ok200 sendResponseStatus status' <=< selectRep $ do provideRep . siteLayoutMsg MsgHealthReport $ do setTitleI MsgHealthReport [whamlet| $newline never +

+ $case status + $of HealthSuccess + _{MsgMessageSuccess} + $of HealthInactive + _{MsgMessageWarning} + $of _ + _{MsgMessageError} +
- $forall (_, report) <- healthReports' - $case report - $of HealthMatchingClusterConfig passed -
_{MsgHealthMatchingClusterConfig} -
#{boolSymbol passed} - $of HealthHTTPReachable (Just passed) -
_{MsgHealthHTTPReachable} -
#{boolSymbol passed} - $of HealthLDAPAdmins (Just found) -
_{MsgHealthLDAPAdmins} -
#{textPercent found 1} - $of HealthSMTPConnect (Just passed) -
_{MsgHealthSMTPConnect} -
#{boolSymbol passed} - $of HealthWidgetMemcached (Just passed) -
_{MsgHealthWidgetMemcached} -
#{boolSymbol passed} - $of HealthActiveJobExecutors (Just active) -
_{MsgHealthActiveJobExecutors} -
#{textPercent active 1} - $of _ + $forall (lUp, report) <- healthReports' + $case healthReportStatus report + $of HealthInactive + $of hcstatus +
+ _{classifyHealthReport report} +
+ #{boolSymbol (healthOk hcstatus)} # + $case report + $of HealthLDAPAdmins (Just found) + #{textPercent found 1} + $of HealthActiveJobExecutors (Just active) + #{textPercent active 1} + $of _ +
+ ^{formatTimeW SelFormatDateTime lUp} |] provideJson healthReports provideRep . return . Builder.toLazyText $ Aeson.encodePrettyToTextBuilder healthReports @@ -105,7 +109,7 @@ getInstanceR = do provideRep . return $ tshow instanceInfo --- Most simple page for simple liveness checks +-- Most simple page for simple liveness checks, but it always delivers 200 getStatusR :: Handler Html getStatusR = do starttime <- getsYesod appStartTime diff --git a/src/Handler/LMS.hs b/src/Handler/LMS.hs index df3004d5a..9eb5a6b57 100644 --- a/src/Handler/LMS.hs +++ b/src/Handler/LMS.hs @@ -348,7 +348,6 @@ instance Finite LmsTableAction nullaryPathPiece ''LmsTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''LmsTableAction id --- Not yet needed, since there is no additional data for now: data LmsTableActionData = LmsActNotifyData | LmsActRenewNotifyData | LmsActRenewPinData -- no longer used @@ -692,14 +691,14 @@ postLmsR sid qsh = do fromIntegral <$> deleteWhereCount [LmsUserQualification ==. qid, LmsUserUser <-. usersList] - runDBJobs $ forM_ selectedUsers $ \uid -> - queueDBJob $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } + forM_ selectedUsers $ \uid -> + queueJob' $ JobLmsEnqueueUser { jQualification = qid, jUser = uid } let mStatus = bool Success Warning $ delUsers < numUsers addMessageI mStatus $ MsgLmsActRestartFeedback delUsers numUsers reloadKeepGetParams $ LmsR sid qsh (action, selectedUsers) | isRenewPinAct action || isNotifyAct action -> do - numExaminees <- runDBJobs $ do + numExaminees <- runDB $ do okUsers <- selectList [ LmsUserQualification ==. qid -- matching qualification , LmsUserEnded ==. Nothing -- not yet deleted , LmsUserStatus ==. Nothing -- not yet decided @@ -710,7 +709,7 @@ postLmsR sid qsh = do newPin <- liftIO randomLMSpw update lid [LmsUserPin =. newPin, LmsUserDatePin =. now, LmsUserResetPin =. True] when (isNotifyAct action) $ - queueDBJob $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False } + queueJob' $ JobUserNotification { jRecipient = uid, jNotification = NotificationQualificationRenewal qid' False } return $ length okUsers let numSelected = length selectedUsers diffSelected = numSelected - numExaminees diff --git a/src/Handler/LMS/Result.hs b/src/Handler/LMS/Result.hs index 6662d7574..aca551ab6 100644 --- a/src/Handler/LMS/Result.hs +++ b/src/Handler/LMS/Result.hs @@ -212,7 +212,7 @@ postLmsResultR sid qsh = do -- Direct File Upload/Download -saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> JobDB Int +saveResultCsv :: QualificationId -> Int -> LmsResultTableCsv -> DB Int saveResultCsv qid i LmsResultTableCsv{..} = do now <- liftIO getCurrentTime void $ upsert @@ -238,12 +238,12 @@ postLmsResultUploadR sid qsh = do FormSuccess file -> do -- content <- fileSourceByteString file -- return $ Just (fileName file, content) - nr <- runDBJobs $ do + nr <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveResultCsv qid) 0 - queueDBJob $ JobLmsResults qid + queueJob' $ JobLmsResults qid return nr addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") redirect $ LmsResultR sid qsh @@ -267,7 +267,7 @@ postLmsResultDirectR sid qsh = do (status, msg) <- case files of [(fhead,file)] -> do lmsDecoder <- getLmsCsvDecoder - runDBJobs $ do + runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file .| lmsDecoder @@ -279,7 +279,7 @@ postLmsResultDirectR sid qsh = do Right nr -> do let msg = "Success. LMS Result upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " $logInfoS "LMS" msg - when (nr > 0) $ queueDBJob $ JobLmsResults qid + when (nr > 0) $ queueJob' $ JobLmsResults qid return (ok200, msg) [] -> do let msg = "Result upload file missing." diff --git a/src/Handler/LMS/Userlist.hs b/src/Handler/LMS/Userlist.hs index 407c7436e..cb8618b6d 100644 --- a/src/Handler/LMS/Userlist.hs +++ b/src/Handler/LMS/Userlist.hs @@ -212,7 +212,7 @@ postLmsUserlistR sid qsh = do -- Direct File Upload/Download -- saveUserlistCsv :: (PersistUniqueWrite backend, MonadIO m, BaseBackend backend ~ SqlBackend, Enum b) => -- Key Qualification -> b -> LmsUserlistTableCsv -> ReaderT backend m b -saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> JobDB Int +saveUserlistCsv :: QualificationId -> Int -> LmsUserlistTableCsv -> DB Int saveUserlistCsv qid i LmsUserlistTableCsv{..} = do now <- liftIO getCurrentTime void $ upsert @@ -236,10 +236,10 @@ postLmsUserlistUploadR sid qsh = do ((result,widget), enctype) <- runFormPost makeUserlistUploadForm case result of FormSuccess file -> do - nr <- runDBJobs $ do + nr <- runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh nr <- runConduit $ fileSource file .| decodeCsv .| foldMC (saveUserlistCsv qid) 0 - queueDBJob $ JobLmsUserlist qid + queueJob' $ JobLmsUserlist qid return nr addMessage Success $ toHtml $ pack "Erfolgreicher Upload der Datei " <> fileName file <> pack (" mit " <> show nr <> " Zeilen") redirect $ LmsUserlistR sid qsh @@ -263,7 +263,7 @@ postLmsUserlistDirectR sid qsh = do (status, msg) <- case files of [(fhead,file)] -> do lmsDecoder <- getLmsCsvDecoder - runDBJobs $ do + runDB $ do qid <- getKeyBy404 $ SchoolQualificationShort sid qsh enr <- try $ runConduit $ fileSource file .| lmsDecoder @@ -275,7 +275,7 @@ postLmsUserlistDirectR sid qsh = do Right nr -> do let msg = "Success. LMS Userlist upload file " <> fileName file <> " containing " <> tshow nr <> " rows for " <> fhead <> ". " $logInfoS "LMS" msg - when (nr > 0) $ queueDBJob $ JobLmsUserlist qid + when (nr > 0) $ queueJob' $ JobLmsUserlist qid return (ok200, msg) [] -> do let msg = "Userlist upload file missing." diff --git a/src/Handler/PrintCenter.hs b/src/Handler/PrintCenter.hs index da0a8ecdb..0f7d5257a 100644 --- a/src/Handler/PrintCenter.hs +++ b/src/Handler/PrintCenter.hs @@ -127,7 +127,7 @@ nullaryPathPiece ''PJTableAction $ camelToPathPiece' 2 embedRenderMessage ''UniWorX ''PJTableAction id -- Not yet needed, since there is no additional data for now: -data PJTableActionData = PJActAcknowledgeData | PJActReprintData +data PJTableActionData = PJActAcknowledgeData | PJActReprintData { ignoreReroute :: Maybe Bool } deriving (Eq, Ord, Read, Show, Generic) type PJTableExpr = ( E.SqlExpr (Entity PrintJob) @@ -192,7 +192,7 @@ mkPJTable = do dbtRowKey = queryPrintJob >>> (E.^. PrintJobId) dbtProj = dbtProjId dbtColonnade = mconcat - [ dbSelectIf (applying _2) id (return . view (resultPrintJob . _entityKey)) (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) + [ dbSelect (applying _2) id (return . view (resultPrintJob . _entityKey)) -- condition for dbSelectIf: (\r -> isNothing $ r ^. resultPrintJob . _entityVal . _printJobAcknowledged) , sortable (Just "created") (i18nCell MsgPrintJobCreated) $ \( view $ resultPrintJob . _entityVal . _printJobCreated -> t) -> dateTimeCell t , sortable (Just "acknowledged") (i18nCell MsgPrintJobAcknowledged) $ \( view $ resultPrintJob . _entityVal . _printJobAcknowledged -> t) -> maybeDateTimeCell t , sortable (Just "filename") (i18nCell MsgPrintPDF) $ \r -> let k = r ^. resultPrintJob . _entityKey @@ -262,7 +262,8 @@ mkPJTable = do = let acts :: Map PJTableAction (AForm Handler PJTableActionData) acts = mconcat [ singletonMap PJActAcknowledge $ pure PJActAcknowledgeData - , singletonMap PJActReprint $ pure PJActReprintData + , singletonMap PJActReprint $ PJActReprintData + <$> aopt checkBoxField (fslI MsgPJActReprintIgnoreReroute) Nothing ] in renderAForm FormStandard $ (, mempty) . First . Just @@ -292,15 +293,23 @@ postPrintCenterR = do num <- runDB $ updateWhereCount [PrintJobAcknowledged ==. Nothing, PrintJobId <-. pjIds] [PrintJobAcknowledged =. Just now] addMessageI Success $ MsgPrintJobAcknowledge num reloadKeepGetParams PrintCenterR - (PJActReprintData, Set.toList -> pjIds) -> do - let countOk = either (const $ Sum 0) (const $ Sum 1) - oks <- runDB $ forM pjIds $ fmap countOk . reprintPDF + (PJActReprintData{ignoreReroute}, Set.toList -> pjIds) -> do + 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 + 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! + |] siteLayoutMsg MsgMenuApc $ do setTitleI MsgMenuApc $(widgetFile "print-center") -- i18nWidgetFile? Currently no text contained; displays just the table only diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index ad3ab6ee1..92f9c4803 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -359,11 +359,11 @@ postUsersR = do | Set.null usersSet && isNotSetSupervisor act -> addMessageI Info MsgActionNoUsersSelected (UserLdapSyncData, userSet) -> do - runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseLdapUser uid + forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserAvsSyncData, userSet) -> do - runDBJobs . forM_ userSet $ \uid -> queueDBJob $ JobSynchroniseAvsUser uid Nothing + forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing addMessageI Success . MsgSynchroniseAvsUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserHijack, Set.minView -> Just (uid, _)) -> diff --git a/src/Jobs.hs b/src/Jobs.hs index c658668dc..0d5993ce7 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -593,7 +593,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker newReport@(healthReportStatus -> newStatus) <- lift $ generateHealthReport kind $logInfoS logIdent [st|#{tshow kind}: #{toPathPiece newStatus}|] - unless (newStatus == HealthSuccess) $ do + unless (newStatus > HealthFailure) $ do $logErrorS logIdent [st|#{tshow kind}: #{tshow newReport}|] liftIO $ do diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index d9953f15c..83f44e556 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -298,7 +298,7 @@ dispatchJobLmsUserlist :: QualificationId -> JobHandler UniWorX dispatchJobLmsUserlist qid = JobHandlerAtomic act where act :: YesodJobDB UniWorX () - act = do + act = whenM (exists [LmsUserlistQualification ==. qid]) $ do -- safeguard against multiple calls, which would close all learners due to first case below now <- liftIO getCurrentTime -- result :: [(Entity LmsUser, Entity LmsUserlist)] results <- E.select $ do diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 96ae456df..408758885 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -12,9 +12,9 @@ module Jobs.Handler.SynchroniseAvs import Import -import qualified Database.Esqueleto.Legacy as E hiding (upsert) -import qualified Database.Esqueleto.PostgreSQL as E -import qualified Database.Esqueleto.Utils as E +-- import qualified Database.Esqueleto.Legacy as E hiding (upsert) +-- import qualified Database.Esqueleto.PostgreSQL as E +-- import qualified Database.Esqueleto.Utils as E import qualified Data.Conduit.List as C import Jobs.Queue @@ -22,24 +22,24 @@ import Jobs.Queue import Handler.Utils.Avs dispatchJobSynchroniseAvs :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX -dispatchJobSynchroniseAvs numIterations epoch iteration pause - -- TODO: refactor so that the AvsIdLookup becomes obsolete - = JobHandlerAtomic . runConduit $ - readUsers .| filterIteration .| sinkDBJobs +dispatchJobSynchroniseAvs numIterations epoch iteration pause + = JobHandlerException . runDB $ do + now <- liftIO getCurrentTime + todos <- runConduit $ readUsers .| filterIteration now .| sinkList + putMany todos where - readUsers :: ConduitT () UserId (YesodJobDB UniWorX) () + readUsers :: ConduitT () UserId _ () readUsers = selectKeys [] [] - filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) () - filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do + filterIteration :: UTCTime -> ConduitT UserId AvsSync _ () + filterIteration now = C.mapMaybeM $ \userId -> runMaybeT $ do let userIteration, currentIteration :: Integer userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations currentIteration = toInteger iteration `mod` toInteger numIterations -- $logDebugS "SynchronisAvs" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|] - guard $ userIteration == currentIteration - - return $ JobSynchroniseAvsUser userId pause + guard $ userIteration == currentIteration + return $ AvsSync userId now pause -- dispatchJobSynchroniseAvs' :: Natural -> Natural -> Natural -> Maybe Day -> JobHandler UniWorX -- dispatchJobSynchroniseAvs' numIterations epoch iteration pause = JobHandlerAtomic $ do @@ -47,32 +47,34 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause dispatchJobSynchroniseAvsId :: AvsPersonId -> Maybe Day -> JobHandler UniWorX dispatchJobSynchroniseAvsId apid pause = JobHandlerException $ do - ok <- runDBJobs $ - getBy (UniqueUserAvsId apid) >>= \case + ok <- runDB $ getBy (UniqueUserAvsId apid) >>= + \case (Just Entity{entityVal=UserAvs{userAvsUser=uid}}) -> do -- known user workJobSychronizeAvs uid pause return True - Nothing -> -- unknown avsPersonId, attempt to create user + _ -> -- unknown avsPersonId, attempt to create user return False - -- flip (maybeM $ return False) (getBy $ UniqueUserAvsId apid) $ \Entity{entityVal=UserAvs{userAvsUser=uid}} -> do -- known user - -- workJobSychronizeAvs uid pause - -- return True unless ok $ void $ maybeCatchAll $ upsertAvsUserById apid dispatchJobSynchroniseAvsUser :: UserId -> Maybe Day -> JobHandler UniWorX -dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ runDBJobs $ workJobSychronizeAvs uid pause +dispatchJobSynchroniseAvsUser uid pause = JobHandlerException $ runDB $ workJobSychronizeAvs uid pause -workJobSychronizeAvs :: UserId -> Maybe Day -> JobDB () +workJobSychronizeAvs :: UserId -> Maybe Day -> DB () workJobSychronizeAvs uid pause = do now <- liftIO getCurrentTime - void $ E.upsert - AvsSync { avsSyncUser = uid - , avsSyncCreationTime = now - , avsSyncPause = pause - } - [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] - queueDBJob JobSynchroniseAvsQueue + -- void $ E.upsert + -- AvsSync { avsSyncUser = uid + -- , avsSyncCreationTime = now + -- , avsSyncPause = pause + -- } + -- [ \oldSync -> (AvsSyncPause E.=. E.greatest (E.val pause) (oldSync E.^. AvsSyncPause)) oldSync ] -- causes Esqueleto to call undefined at Database.Esqueleto.Internal.Internal.renderUpdates:1308 + maybeM + (insert_ AvsSync{avsSyncUser=uid, avsSyncCreationTime=now, avsSyncPause=pause}) + (\Entity{entityKey=asid, entityVal=AvsSync{avsSyncPause=oldPause}} -> + update asid [AvsSyncPause =. max pause oldPause, AvsSyncCreationTime =. now]) + (getBy $ UniqueAvsSyncUser uid) + queueJob' JobSynchroniseAvsQueue dispatchJobSynchroniseAvsQueue :: JobHandler UniWorX dispatchJobSynchroniseAvsQueue = JobHandlerException $ do @@ -97,7 +99,7 @@ dispatchJobSynchroniseAvsQueue = JobHandlerException $ do AvsInterfaceUnavailable -> return () -- ignore and retry later AvsUserUnknownByAvs _ -> return () -- ignore for users no longer listed in AVS otherExc -> throwM otherExc - ) + ) -- needed, since JobSynchroniseAvsQueue cannot requeue itself due to JobNoQueueSame (and having no parameters) dispatchJobSynchroniseAvsNext :: JobHandler UniWorX diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index d9b3e31f0..25df1337f 100644 --- a/src/Jobs/Queue.hs +++ b/src/Jobs/Queue.hs @@ -152,7 +152,7 @@ sinkDBJobs :: ConduitT Job Void (YesodJobDB UniWorX) () sinkDBJobs = C.mapM_ queueDBJob runDBJobs :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => YesodJobDB UniWorX a -> m a --- | Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction +-- | Blocking! Replacement for/Wrapper around `runDB` when jobs need to be queued as part of a database transaction -- -- Jobs get immediately executed if the transaction succeeds runDBJobs act = do @@ -161,7 +161,7 @@ runDBJobs act = do forM_ jIds $ flip runReaderT app . writeJobCtl . JobCtlPerform return ret - +-- | Blocking! runDBJobs' :: YesodJobDB UniWorX a -> DB a runDBJobs' act = do (ret, jIds) <- mapReaderT runWriterT act diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs index a1f49fad2..64ad49b3a 100644 --- a/src/Model/Types/Health.hs +++ b/src/Model/Types/Health.hs @@ -27,6 +27,8 @@ instance Finite HealthCheck instance Hashable HealthCheck instance NFData HealthCheck +-- embedRenderMessage ''UniWorX ''HealthCheck id -- not possible here + deriveJSON defaultOptions { constructorTagModifier = camelToPathPiece' 2 } ''HealthCheck @@ -65,10 +67,10 @@ classifyHealthReport :: HealthReport -> HealthCheck classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig classifyHealthReport HealthLDAPAdmins{} = HealthCheckLDAPAdmins classifyHealthReport HealthHTTPReachable{} = HealthCheckHTTPReachable -classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect -classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached -classifyHealthReport HealthActiveJobExecutors{} = HealthCheckActiveJobExecutors -classifyHealthReport HealthDoesFlush{} = HealthCheckDoesFlush +classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect +classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached -- kein Neustart notwendig +classifyHealthReport HealthActiveJobExecutors{} = HealthCheckActiveJobExecutors +classifyHealthReport HealthDoesFlush{} = HealthCheckDoesFlush -- evtl. kein Neustart notwendig -- | `HealthReport` classified (`classifyHealthReport`) by badness -- @@ -76,7 +78,7 @@ classifyHealthReport HealthDoesFlush{} = HealthCheckDoesFlush -- -- Currently all consumers of this type check for @(== HealthSuccess)@; this -- needs to be adjusted on a case-by-case basis if new constructors are added -data HealthStatus = HealthFailure | HealthSuccess +data HealthStatus = HealthFailure | HealthInactive | HealthSuccess deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) instance Universe HealthStatus @@ -87,17 +89,30 @@ deriveJSON defaultOptions } ''HealthStatus nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 +healthOk :: HealthStatus -> Bool +healthOk HealthFailure = False +healthOk HealthInactive = True +healthOk HealthSuccess = True + healthReportStatus :: HealthReport -> HealthStatus -- ^ Classify `HealthReport` by badness -healthReportStatus = \case - HealthMatchingClusterConfig False -> HealthFailure - HealthHTTPReachable (Just False) -> HealthFailure +healthReportStatus = \case + HealthMatchingClusterConfig True -> HealthSuccess + HealthHTTPReachable (Just True ) -> HealthSuccess + HealthHTTPReachable Nothing -> HealthInactive HealthLDAPAdmins (Just prop ) - | prop <= 0 -> HealthFailure - HealthSMTPConnect (Just False) -> HealthFailure + | prop > 0 -> HealthSuccess + HealthLDAPAdmins Nothing -> HealthInactive + HealthSMTPConnect (Just True ) -> HealthSuccess + HealthSMTPConnect Nothing -> HealthInactive HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully? + HealthWidgetMemcached (Just True ) -> HealthSuccess + HealthWidgetMemcached Nothing -> HealthInactive + HealthActiveJobExecutors Nothing -> HealthInactive HealthActiveJobExecutors (Just prop ) - | prop <= 0 -> HealthFailure - HealthDoesFlush mProp - | maybe True (>= 2) mProp -> HealthFailure - _other -> maxBound -- Minimum badness + | prop > 0 -> HealthSuccess + HealthDoesFlush Nothing -> HealthInactive + HealthDoesFlush (Just prop ) + | prop >= 2 -> HealthFailure + | otherwise -> HealthSuccess + _other -> HealthFailure diff --git a/src/Utils/PathPiece.hs b/src/Utils/PathPiece.hs index 05f7f558a..45b5643e5 100644 --- a/src/Utils/PathPiece.hs +++ b/src/Utils/PathPiece.hs @@ -9,6 +9,7 @@ module Utils.PathPiece , splitCamel, dropCamel , camelToPathPiece, camelToPathPiece', camelToPathPiece'' , nameToPathPiece, nameToPathPiece' + , kebabToCamel , tuplePathPiece , pathPieceJSON, pathPieceJSONKey , pathPieceBinary @@ -237,6 +238,11 @@ nameToPathPiece' dropN = camelToPathPiece' dropN . repack . nameBase nameToPathPiece :: Textual t => Name -> t nameToPathPiece = nameToPathPiece' 0 +-- | convert kebab-case to CamelCase +kebabToCamel :: Text -> Text +-- kebabToCamel = Text.filter (not . Char.isSpace) . Text.toTitle . Text.replace "-" " " -- eliminates all space +kebabToCamel = mconcat . fmap Text.toTitle . Text.split ('-'==) -- preserves existing spaces + tuplePathPiece :: Int -> DecQ tuplePathPiece tupleDim = do diff --git a/src/Utils/Print.hs b/src/Utils/Print.hs index 313ffb333..7735f1f09 100644 --- a/src/Utils/Print.hs +++ b/src/Utils/Print.hs @@ -278,12 +278,12 @@ printLetter' pji pdf = do insert_ PrintJob {..} return $ Right (ok, printJobFilename) -reprintPDF :: PrintJobId -> DB (Either Text Text) -reprintPDF pjid = maybeM (return $ Left "Print job id is unknown.") reprint $ get pjid +reprintPDF :: Bool -> PrintJobId -> DB (Either Text Text) +reprintPDF ignoreReroute pjid = maybeM (return $ Left "Print job id is unknown.") reprint $ get pjid where reprint :: PrintJob -> DB (Either Text Text) reprint pj@PrintJob{..} = do - result <- lprPDF printJobFilename $ LBS.fromStrict printJobFile + result <- lprPDF' ignoreReroute printJobFilename $ LBS.fromStrict printJobFile whenIsRight result $ const $ do now <- liftIO getCurrentTime insert_ pj{ printJobAcknowledged = Nothing @@ -460,26 +460,29 @@ encryptPDF pw bs = over _Left (decodeUtf8 . LBS.toStrict) . exit2either <$> read -- | Internal only, use `printLetter` instead lprPDF :: (MonadHandler m, HasAppSettings (HandlerSite m)) => FilePath -> LBS.ByteString -> m (Either Text Text) -lprPDF (sanitizeCmdArg' -> jb) bs = do - mbLprServerArg <- getLprServerArg - case mbLprServerArg of - Nothing -> return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." - Just lprServerArg -> do - let pc = setStdin (byteStringInput bs) $ - proc "lpr" $ - jobname ++ -- -J jobname -- a name for job identification at printing site - [ lprServerArg -- -P queue@hostname:port - , "-" -- read from stdin - ] - jobname | null jb = [] - | otherwise = ["-J " <> jb] - exit2either <$> readProcess' pc - where +lprPDF = lprPDF' False + +lprPDF' :: (MonadHandler m, HasAppSettings (HandlerSite m)) => Bool -> FilePath -> LBS.ByteString -> m (Either Text Text) +lprPDF' ignoreReroute (sanitizeCmdArg' -> jb) bs = maybeM hdlFail hdlLpr getLprServerArg + where + hdlFail = return $ Right "Print command ignored due to setting 'mail-reroute-to' being set." + + hdlLpr lprServerArg = do + let pc = setStdin (byteStringInput bs) $ + proc "lpr" $ + jobname ++ -- -J jobname -- a name for job identification at printing site + [ lprServerArg -- -P queue@hostname:port + , "-" -- read from stdin + ] + jobname | null jb = [] + | otherwise = ["-J " <> jb] + exit2either <$> readProcess' pc + getLprServerArg = do rerouteMail <- getsYesod $ view _appMailRerouteTo - case rerouteMail of - Just _ -> return Nothing - Nothing -> do + case (ignoreReroute, rerouteMail) of + (False, Just _) -> return Nothing + _ -> do LprConf{..} <- getsYesod $ view _appLprConf return . Just $ "-P " <> lprQueue <> "@" <> lprHost <> ":" <> show lprPort diff --git a/templates/i18n/info-lecturer/de-de-formal.hamlet b/templates/i18n/info-lecturer/de-de-formal.hamlet index e10eb28a5..b683e141a 100644 --- a/templates/i18n/info-lecturer/de-de-formal.hamlet +++ b/templates/i18n/info-lecturer/de-de-formal.hamlet @@ -285,9 +285,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
Ausbilder:innen

- Ausbilder:innen werden ad hoc pro Kursgruppe festgelegt. + Ausbilder:innen werden ad hoc pro Kurs festgelegt.
- Eine Kursgruppe kann beliebig viele Ausbilder:innen haben und ein Ausbilder kann beliebig viele Kursegruppen betreuen. + Eine Kurs kann beliebig viele Ausbilder:innen haben und ein Ausbilder kann beliebig viele Kursegruppen betreuen.

Ausbilder:innen haben Zugriff auf die Namen und Studiendaten ihrer Kursteilnehmer:innen, können Mitteilungen an sie verschicken (analog zu Kursartmitteilungen) und Teilnehmer:innen aus ihrem Kurs entfernen. @@ -307,16 +307,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
Eine vorherige Anmeldung zur Kursart ist Voraussetzung.

- Die Anmeldung kann pro Kursgruppe zeitlich beschränkt werden. + Die Anmeldung kann pro Kurs zeitlich beschränkt werden.

- Kursgruppen können mit einer Registrierungs-Gruppe versehen werden. + Kurse können mit einer Registrierungs-Gruppe versehen werden. Es handelt sich hierbei um einen beliebig wählbaren Text, der ansonsten keine Bedeutung hat.
Lernenden wird die Anmeldung nur in einem Kurs pro Registrierungs-Gruppe erlaubt. Leere Registrierungs-Gruppen (d.h. es wurde keine Registrierungs-Gruppe angegeben) zählen hierbei als verschieden.

- Um die Anmeldung in beliebig viele Kursgruppen zuzulassen können alle Registrierungs-Gruppen leer gelassen werden. + Um die Anmeldung in beliebig viele Kurse zuzulassen können alle Registrierungs-Gruppen leer gelassen werden.

^{newFeat 2019 10 10} Nachmeldung
diff --git a/templates/print-center.hamlet b/templates/print-center.hamlet index 6f6008a5c..1cac8e15e 100644 --- a/templates/print-center.hamlet +++ b/templates/print-center.hamlet @@ -6,4 +6,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later

- ^{pjTable} \ No newline at end of file + ^{pjTable} + +

+ ^{modal "APC Konfiguration" (Right lprWgt)} \ No newline at end of file