diff --git a/.ports/assign.hs b/.ports/assign.hs new file mode 100644 index 000000000..000881729 --- /dev/null +++ b/.ports/assign.hs @@ -0,0 +1,64 @@ +-- SPDX-FileCopyrightText: 2024 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# Language OverloadedStrings, LambdaCase, TypeApplications #-} + +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory +import System.Environment +import System.IO + +main :: IO () +main = getArgs >>= \case + ["--assign", offsetFile] -> parseOffsets offsetFile >>= uncurry nextOffset + ["--remove", offset] -> removeOffset offset + _ -> fail "unsupported args" + +parseOffsets :: FilePath -> IO (Int,Int) +parseOffsets offsetFile = do + user <- T.pack <$> getEnv "USER" + let pred x = "//" `T.isPrefixOf` x || T.null (T.strip x) + tokenise = map (filter (not . pred) . T.lines) . T.split (=='#') + extract = map tail . filter (\u -> not (null u) && user == (T.strip $ head u)) + ((extract . tokenise . T.pack) <$> readFile offsetFile) >>= \case + [[min,max]] -> return (read $ T.unpack min, read $ T.unpack max) + x -> print x >> fail "malformed offset file" + +nextOffset :: Int -> Int -> IO () +nextOffset min max + | min > max = nextOffset max min + | otherwise = do + home <- getEnv "HOME" + offset <- findFile [home] ".port-offsets" >>= \case + Nothing -> writeFile (home ++ "/.port-offsets") (show min) >> return min + Just path -> do + used <- (map (read @Int) . filter (not . null) . lines) <$> readFile path + o <- next min max used + appendFile path ('\n' : show o) + return o + print offset + where + next :: Int -> Int -> [Int] -> IO Int + next min max used + | min > max = fail "all offsets currently in use" + | min `elem` used = next (min+1) max used + | otherwise = return min + +removeOffset :: String -> IO () +removeOffset offset = do + home <- getEnv "HOME" + findFile [home] ".port-offsets" >>= \case + Nothing -> fail "offset file does not exist" + Just path -> do + remaining <- (filter (/= offset) . lines) <$> readFile path + run <- getEnv "XDG_RUNTIME_DIR" + (tempPath, fh) <- openTempFile run ".port-offsets" + let out = unlines remaining + hPutStr fh $ out + case T.null (T.strip $ T.pack out) of + True -> removeFile path + False -> writeFile path $ out + removeFile tempPath + diff --git a/.ports/offsets b/.ports/offsets new file mode 100644 index 000000000..7a4e5e7d6 --- /dev/null +++ b/.ports/offsets @@ -0,0 +1,24 @@ +// SPDX-FileCopyrightText: 2024 David Mosbach +// +// SPDX-License-Identifier: AGPL-3.0-or-later + +# gkleen + -1000 + -950 + +# ishka + -949 + -899 + +# jost + -898 + -848 + +# mosbach + -847 + -797 + +# savau + -796 + -746 + diff --git a/CHANGELOG.md b/CHANGELOG.md index cce1e6cff..d4a7e1e8d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,26 @@ 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.54](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.53...v27.4.54) (2023-12-11) + + +### Bug Fixes + +* **db:** prevent superfluous migrations ([b73557a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b73557a1eee4315911c6369032447f8d1836d964)) + +## [27.4.53](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.52...v27.4.53) (2023-12-09) + + +### Bug Fixes + +* **admin:** minor fixes and translations for admin problem page ([30fae33](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/30fae33dedb1501e570e9edca288fea3c84ac84a)) +* **avs:** background synch was only triggerd by manual synchs ([48ef25a](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/48ef25aa8ffbbd96c1578ae85b76f090d9042595)) +* **firm:** group multi select field supervisor ([fc0ca7b](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/fc0ca7b854a686cf395dadf81b7423e530fd26b8)) +* **firm:** set supervisor field not all fields required ([9878956](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/9878956716b04c7ae88989cb9b059d3edcb923dc)) +* **firm:** supervisor filter ([3acb847](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3acb847915010d10358ea02000c231dbba7cba26)) +* **form:** multiSelectField working with grouped options ([3aa8901](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/3aa89019a8b4393da0eca715871a3793c1e3abb2)) +* **print:** keep print jobs on user merge and lms id deletion ([a15862e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a15862ea72bc374af870ef3a23f86ae32c2c67a9)) + ## [27.4.52](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.51...v27.4.52) (2023-12-01) diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index 2bb340724..f4c23696d 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -111,7 +111,6 @@ ProblemsDriversHaveAvsIds: Alle Inhaber einer Fahrberechtigung konnten einer AVS ProblemsUsersAreReachable: Für alle Benutzer ist eine E-Mail oder postalische Adresse bekannt ProblemsNoStalePrintJobs n@Integer: Alle Briefversandaufträge der vergangenen #{show n} Tage wurden von der Druckerei bestätigt ProblemsNoBadAPCIds: Alle kürzlich empfangenen Druckauftragsbestätigungen waren gültig -ProblemsNoAvsSynchProblems: Synchronisation mit Ausweisverwaltungssystem (AVS) meldete keine Probleme ProblemsUnreachableHeading: Unerreichbare Benutzer ProblemsUnreachableBody: Benutzer ohne E-Mail oder Postadresse, welche z.B. bei ablaufenden Berechtigungen nicht benachrichtigt werden können: ProblemsRWithoutFHeading: Fahrer mit R ohne F @@ -119,4 +118,9 @@ ProblemsRWithoutFBody: Diese Fahrer sind wegen einer ungültigen Vorfeld-Fahrber ProblemsNoAvsIdHeading: Fahrer ohne AVS-Id ProblemsNoAvsIdBody: Fahrer mit gültiger Fahrberechtigung in FRADrive, welche trotzdem nicht fahren dürfen, da die Fahrberechtigung aufgrund einer unbekannten AVS Id nicht an die Ausweisstelle übermittelt werden konnte: ProblemsAvsSynchHeading: Synchronisation AVS Fahrberechtigungen -ProblemsAvsErrorHeading: Fehlermeldungen \ No newline at end of file +ProblemsAvsErrorHeading: Fehlermeldungen +ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit + +InterfaceLastSynch: Zuletzt +InterfaceSubtype: Betreffend +InterfaceWrite: Schreibend \ No newline at end of file diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 4d973593a..c035f54c0 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -111,7 +111,6 @@ ProblemsDriversHaveAvsIds: All driving licence holder could be matched with thei ProblemsUsersAreReachable: Either Email or postal address is known for all users ProblemsNoStalePrintJobs n: All requests for letter mailing within the last #{show n} days were acknowledged as printed by the airport printing center ProblemsNoBadAPCIds: All recently received print job ids from Airport Print Center were legit -ProblemsNoAvsSynchProblems: AVS synchronisation had not problems ProblemsUnreachableHeading: Unreachable Users ProblemsUnreachableBody: Users without Email nor postal address, who thus cannot be notified about expiring qualifications: ProblemsRWithoutFHeading: Drivers having 'R' but not 'F' @@ -119,4 +118,9 @@ ProblemsRWithoutFBody: Drivers without apron driving licence are prohibited from ProblemsNoAvsIdHeading: Drivers without AVS id ProblemsNoAvsIdBody: Drivers having a valid apron driving licence within FRADrive only, but who may not drive since a missing AVS id prevents communication of the driving licence to AVS: ProblemsAvsSynchHeading: Synchronisation AVS Driving Licences -ProblemsAvsErrorHeading: Error Log \ No newline at end of file +ProblemsAvsErrorHeading: Error Log +ProblemsInterfaceSince: Only considering successes and errors since + +InterfaceLastSynch: Last +InterfaceSubtype: Affecting +InterfaceWrite: Write \ No newline at end of file diff --git a/messages/uniworx/categories/firm/de-de-formal.msg b/messages/uniworx/categories/firm/de-de-formal.msg index f938dbaa9..c7a92efb3 100644 --- a/messages/uniworx/categories/firm/de-de-formal.msg +++ b/messages/uniworx/categories/firm/de-de-formal.msg @@ -2,6 +2,9 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Standardansprechpartner +FirmSuperForeign: Firmenfremde Ansprechpartner +FirmSuperIrregular: Irreguläre Ansprechpartner FirmAssociates: Firmenangehörige FirmContact: Firmenkontakt FirmNoContact: Keine allgemeinen Kontaktinformationen bekannt. diff --git a/messages/uniworx/categories/firm/en-eu.msg b/messages/uniworx/categories/firm/en-eu.msg index 747900397..043312a20 100644 --- a/messages/uniworx/categories/firm/en-eu.msg +++ b/messages/uniworx/categories/firm/en-eu.msg @@ -2,6 +2,9 @@ # # SPDX-License-Identifier: AGPL-3.0-or-later +FirmSuperDefault: Default supervisor +FirmSuperForeign: External supervisor +FirmSuperIrregular: Irregular supervisor FirmAssociates: Company associated users FirmContact: Company Contact FirmNoContact: No general contact information known. diff --git a/messages/uniworx/misc/de-de-formal.msg b/messages/uniworx/misc/de-de-formal.msg index eaa02c0fa..3fcd6ffe6 100644 --- a/messages/uniworx/misc/de-de-formal.msg +++ b/messages/uniworx/misc/de-de-formal.msg @@ -10,7 +10,7 @@ BoolIrrelevant !ident-ok: — FieldPrimary: Hauptfach FieldSecondary: Nebenfach MultiEmailFieldTip: Es sind mehrere, Komma-separierte, E-Mail-Adressen möglich -MultiSelectTip: Mehrfachauswahl mit Strg-Klick +MultiSelectTip: Mehrfachauswahl und Abwählen mit Strg-Klick WeekDay: Wochentag LdapIdentificationOrEmail: Fraport AG-Kennung / E-Mail-Adresse Months num@Int64: #{num} #{pluralDE num "Monat" "Monate"} diff --git a/messages/uniworx/misc/en-eu.msg b/messages/uniworx/misc/en-eu.msg index 5b6b15f5b..ed8bda4db 100644 --- a/messages/uniworx/misc/en-eu.msg +++ b/messages/uniworx/misc/en-eu.msg @@ -10,7 +10,7 @@ BoolIrrelevant: — FieldPrimary: Major FieldSecondary: Minor MultiEmailFieldTip: Multiple emails addresses may be specified (comma-separated) -MultiSelectTip: Multiple selection via Ctrl-Click +MultiSelectTip: Multiple selection and desection via Ctrl-Click WeekDay: Day of the week LdapIdentificationOrEmail: Fraport AG-Kennung / email address Months num: #{num} #{pluralEN num "Month" "Months"} diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index d7d246ed3..78e095b6d 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -136,11 +136,13 @@ MenuFirmUsers: Angehörige MenuFirmSupervisors: Ansprechpartner MenuFirmsComm: Mitteilung +MenuInterfaces: Schnittstellen MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle MenuAvsSynchError: AVS Problemübersicht -MenuLdap: LDAP Schnittstelle +MenuLdap !ident-ok: LDAP +MenuOAuth2 !ident-ok: OAuth2 MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 02e25ca1e..bb085c38e 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -70,7 +70,6 @@ MenuCourseDelete: Delete course MenuSubmissionNew: Create submission MenuSubmissionOwn: Submission MenuCorrectors: Correctors - MenuSheetEdit: Edit exercise sheet MenuSheetDelete: Delete exercise sheet MenuSheetClone: Clone exercise sheet @@ -137,11 +136,13 @@ MenuFirmUsers: Associates MenuFirmSupervisors: Supervisors MenuFirmsComm: Messaging +MenuInterfaces: Interfaces MenuSap: SAP Interface MenuAvs: AVS Interface MenuAvsSynchError: AVS Problem Overview -MenuLdap: LDAP Interface +MenuLdap: LDAP +MenuOAuth2: OAuth2 MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter diff --git a/messages/uniworx/utils/table_column/de-de-formal.msg b/messages/uniworx/utils/table_column/de-de-formal.msg index 71e251d18..0a67481af 100644 --- a/messages/uniworx/utils/table_column/de-de-formal.msg +++ b/messages/uniworx/utils/table_column/de-de-formal.msg @@ -105,4 +105,5 @@ TableFilterComma: Es können mehrere alternative Suchkriterien mit Komma getrenn TableFilterCommaPlus: Mehrere alternative Suchkriterien mit Komma trennen. Mindestens ein Suchkriterium muss erfüllt werden, zusätzlich zu allen Suchkriterien mit vorangestelltem Plus-Symbol. TableFilterCommaName: Mehrere Namen mit Komma trennen. TableFilterCommaNameNr: Mehrere Namen oder Nummern mit Komma trennen. Nummern werden nur exakt gesucht. -TableUserEdit: Benutzer bearbeiten \ No newline at end of file +TableUserEdit: Benutzer bearbeiten +TableRows: Zeilen \ 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 b000a6d7d..e7ae23a14 100644 --- a/messages/uniworx/utils/table_column/en-eu.msg +++ b/messages/uniworx/utils/table_column/en-eu.msg @@ -105,4 +105,5 @@ TableFilterComma: Separate multiple alternative filter criteria by comma, at lea TableFilterCommaPlus: Separate multiple alternative filter criteria by comma, at least one of which must be fulfilled in addition to all criteria preceded by a plus symbol. TableFilterCommaName: Separate names by comma. TableFilterCommaNameNr: Separate names and numbers by comma. Numbers have to match exact. -TableUserEdit: Edit user \ No newline at end of file +TableUserEdit: Edit user +TableRows: Rows \ No newline at end of file diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 067b7ba11..5ff122fb1 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Anweisungen RoomReferenceLinkInstructionsPlaceholder: Anweisungen UtilEmptyChoice: Auswahl war leer UtilEmptyNoChangeTip: Eine leere Eingabe belässt den vorherigen Wert unverändert. +MultiNoSelection: Keine Auswahl #invitation.hs InvitationAction: Aktion diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index cafb5fac8..f65004cd1 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -98,6 +98,7 @@ RoomReferenceLinkInstructions: Instructions RoomReferenceLinkInstructionsPlaceholder: Instructions UtilEmptyChoice: Empty selection UtilEmptyNoChangeTip: Existing values remain unchanged if this field is left empty. +MultiNoSelection: No selection #invitation.hs InvitationAction: Action diff --git a/models/audit.model b/models/audit.model index cf821f6ec..fd0889392 100644 --- a/models/audit.model +++ b/models/audit.model @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,4 +9,14 @@ TransactionLog initiator UserId Maybe -- User associated with performing this action remote IP Maybe -- Remote party that triggered this action via HTTP info Value -- JSON-encoded `Transaction` + deriving Eq Read Show Generic + +InterfaceLog + interface Text + subtype Text + 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 + UniqueInterfaceSubtypeWrite interface subtype write deriving Eq Read Show Generic \ No newline at end of file diff --git a/models/print.model b/models/print.model index ee3f1ea7c..ee22cf922 100644 --- a/models/print.model +++ b/models/print.model @@ -9,11 +9,11 @@ PrintJob file ByteString -- stores plain pdf; otherwise use FileContentReference Maybe created UTCTime acknowledged UTCTime Maybe - recipient UserId Maybe OnDeleteCascade OnUpdateCascade -- optional as some letters may contain just an address + recipient UserId Maybe OnDeleteSetNull OnUpdateCascade -- optional as some letters may contain just an address sender UserId Maybe OnDeleteSetNull OnUpdateCascade -- senders and associations are optional course CourseId Maybe OnDeleteCascade OnUpdateCascade qualification QualificationId Maybe OnDeleteCascade OnUpdateCascade - lmsUser LmsIdent Maybe OnDeleteCascade OnUpdateCascade -- allows tracking if recipient has been notified; must be unique + lmsUser LmsIdent Maybe OnDeleteSetNull OnUpdateCascade -- allows tracking if recipient has been notified; must be unique -- UniquePrintJobLmsUser lmsUser -- Note that in fact multiple print jobs per LMS user are possible! -- UniquePrintJobApcIdent apcIdent -- TODO: not yet enforced, since LmsIdent is currently used deriving Generic diff --git a/nix/docker/version.json b/nix/docker/version.json index 07d466528..95f066ec0 100644 --- a/nix/docker/version.json +++ b/nix/docker/version.json @@ -1,3 +1,3 @@ { - "version": "27.4.52" + "version": "27.4.54" } diff --git a/package-lock.json b/package-lock.json index 5fedced5f..40ca7e211 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.52", + "version": "27.4.54", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index f31e8c86b..44f278c6b 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "27.4.52", + "version": "27.4.54", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index c976fcbcb..d2a6652f8 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: uniworx -version: 27.4.52 +version: 27.4.54 dependencies: - base - yesod diff --git a/routes b/routes index 34891b367..2376c33af 100644 --- a/routes +++ b/routes @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -70,6 +70,7 @@ /admin/avs AdminAvsR GET POST /admin/avs/#CryptoUUIDUser AdminAvsUserR GET /admin/ldap AdminLdapR GET POST +/admin/oauth2 AdminOAuth2R GET POST /admin/problems AdminProblemsR GET /admin/problems/no-contact ProblemUnreachableR GET /admin/problems/no-avs-id ProblemWithoutAvsId GET @@ -283,7 +284,7 @@ /lms/#SchoolId/#QualificationShorthand/learners LmsLearnersR GET /lms/#SchoolId/#QualificationShorthand/learners/direct LmsLearnersDirectR GET !token -- LMS /lms/#SchoolId/#QualificationShorthand/report LmsReportR GET POST -/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST !development +/lms/#SchoolId/#QualificationShorthand/report/upload LmsReportUploadR GET POST /lms/#SchoolId/#QualificationShorthand/report/direct LmsReportDirectR POST !token -- LMS -- other lms routes /lms/#SchoolId/#QualificationShorthand/ident/#LmsIdent LmsIdentR GET -- redirect to LmsR with filter-parameter diff --git a/shell.nix b/shell.nix index 42c65ae1f..8c3f8b97e 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022-2023 Gregor Kleen , Sarah Vaupel , Steffen Jost +# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , Sarah Vaupel , Steffen Jost , David Mosbach # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,6 +9,12 @@ let haskellPackages = pkgs.haskellPackages; + oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=d47908b4f7883b4b485abf1ee06645495ccdc7b3&ref=user-queries").packages.x86_64-linux; + + oauth2MockServer = oauth2Flake.default; + mkOauth2DB = oauth2Flake.mkOauth2DB; + killOauth2DB = oauth2Flake.killOauth2DB; + postgresSchema = pkgs.writeText "schema.sql" '' CREATE USER uniworx WITH SUPERUSER; CREATE DATABASE uniworx_test; @@ -21,6 +27,17 @@ let local all all trust ''; + oauth2Schema = pkgs.writeText "oauth2_schema.sql" '' + CREATE USER oauth2mock WITH SUPERUSER; + CREATE DATABASE test_users; + GRANT ALL ON DATABASE test_users TO oauth2mock; + ''; + + oauth2Hba = pkgs.writeText "oauth2_hba_file" '' + local all all trust + ''; + + develop = pkgs.writeScriptBin "develop" '' #!${pkgs.zsh}/bin/zsh -e @@ -44,6 +61,9 @@ let type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached type cleanup_minio &>/dev/null && cleanup_minio type cleanup_maildev &>/dev/null && cleanup_maildev + [[ -z "$OAUTH2_PGDIR" ]] || source ${killOauth2DB}/bin/killOauth2DB + [[ -z "$OAUTH2_PGHOST" ]] || pkill oauth2-mock-ser + [[ -z "$PORT_OFFSET" ]] || runghc .ports/assign.hs --remove $PORT_OFFSET [ -f "''${basePath}/.develop.env" ] && rm -vf "''${basePath}/.develop.env" set +x @@ -51,7 +71,17 @@ let trap cleanup EXIT - export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000)) + export PORT_OFFSET=$(runghc .ports/assign.hs --assign .ports/offsets) + # export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000)) + + if [[ -z "$OAUTH2_PGHOST" ]]; then + set -xe + export OAUTH2_SERVER_PORT=$((9443 + $PORT_OFFSET)) + export OAUTH2_DB_PORT=$((9444 + $PORT_OFFSET)) + source ${mkOauth2DB}/bin/mkOauth2DB + ${oauth2MockServer}/bin/oauth2-mock-server& + set +xe + fi if [[ -z "$PGHOST" ]]; then set -xe @@ -271,6 +301,9 @@ in pkgs.mkShell { export CHROME_BIN=${pkgs.chromium}/bin/chromium ''; + OAUTH2_HBA = oauth2Hba; + OAUTH2_DB_SCHEMA = oauth2Schema; + OAUTH2_TEST_USERS = ./test/Database/test-users.yaml; nativeBuildInputs = [develop inDevelop killallUni2work diffRunning] ++ (with pkgs; [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client diff --git a/src/Application.hs b/src/Application.hs index 8b9a21739..08fef42ee 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -62,7 +62,7 @@ import Jobs import qualified Data.Text.Encoding as Text import qualified Data.Text as Text -import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2) +import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped) import Yesod.Auth.Util.PasswordStore import qualified Data.ByteString.Lazy as LBS @@ -337,8 +337,8 @@ makeFoundation appSettings''@AppSettings{..} = do return . uncurry p $ fromJust mArgs appAuthPlugins <- liftIO $ sequence [ - return oauth2MockServer - , loadPlugin (oauth2AzureADv2 tenantID) "AZURE_ADV2" + (oauth2MockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT" + , loadPlugin (oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] tenantID) "AZURE_ADV2" ] diff --git a/src/Audit.hs b/src/Audit.hs index b6b8012a0..e13c769b9 100644 --- a/src/Audit.hs +++ b/src/Audit.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2023 Gregor Kleen ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -8,6 +8,7 @@ module Audit , audit , AuditRemoteException(..) , getRemote + , logInterface ) where @@ -103,12 +104,38 @@ audit :: ( AuthId (HandlerSite m) ~ Key User -- - `transactionLogInitiator` is currently logged in user (or none) -- - `transactionLogRemote` is determined from current HTTP-Request audit transaction@(toJSON -> transactionLogInfo) = do - transactionLogTime <- liftIO getCurrentTime transactionLogInstance <- getsYesod $ view instanceID transactionLogInitiator <- liftHandler maybeAuthId transactionLogRemote <- handle (throwM . AuditRemoteException) $ Just <$> getRemote - insert_ TransactionLog{..} - $logInfoS "Audit" $ Text.filter (/= '\n') $ tshow (transaction, transactionLogInitiator, transactionLogRemote) <> " - " <> pack (prettyCallStack callStack) + +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 + -> 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 + interfaceLogWrite <- (methodGet /=) . Wai.requestMethod . reqWaiRequest <$> getRequest + deleteBy $ UniqueInterfaceSubtypeWrite interfaceLogInterface interfaceLogSubtype interfaceLogWrite -- always replace, deleteBy & insert seems to be safest and fastest + insert_ InterfaceLog{..} + audit TransactionInterface + { transactionInterfaceName = interfaceLogInterface + , transactionInterfaceSubtype = interfaceLogSubtype + , transactionInterfaceWrite = interfaceLogWrite + , transactionInterfaceRows = interfaceLogRows + , transactionInterfaceInfo = interfaceLogInfo + } diff --git a/src/Audit/Types.hs b/src/Audit/Types.hs index ed3927a03..b7ebe8807 100644 --- a/src/Audit/Types.hs +++ b/src/Audit/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,,Steffen Jost +-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -234,6 +234,13 @@ data Transaction , transactionQualification :: QualificationId , transactionQualificationScheduleRenewal :: Maybe Bool -- TRUE=will be notified upon expiry, FALSE=won't be notified; always JUST, for compatibility with TransactionQualificationUserEdit } + | TransactionInterface + { transactionInterfaceName :: Text + , transactionInterfaceSubtype :: Text + , transactionInterfaceWrite :: Bool -- True implies a write to FRADrive + , transactionInterfaceRows :: Maybe Int + , transactionInterfaceInfo :: Text + } deriving (Eq, Ord, Read, Show, Generic) deriveJSON defaultOptions @@ -243,4 +250,4 @@ deriveJSON defaultOptions , sumEncoding = TaggedObject "transaction" "data" } ''Transaction -derivePersistFieldJSON ''Transaction +derivePersistFieldJSON ''Transaction \ No newline at end of file diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs index 9b4efdd5d..fab04ca16 100644 --- a/src/Auth/OAuth2.hs +++ b/src/Auth/OAuth2.hs @@ -6,16 +6,24 @@ module Auth.OAuth2 ( AzureUserException(..) +, azurePluginName , oauth2MockServer , mockPluginName +, queryOAuth2User +, UserDataException ) where +import Data.Maybe (fromJust) import Data.Text -import Import.NoFoundation +import Import.NoFoundation hiding (unpack) + +import Network.HTTP.Simple (httpJSONEither, getResponseBody, JSONException) + +import System.Environment (lookupEnv) import Yesod.Auth.OAuth2 -import Yesod.Auth.OAuth2.Prelude +import Yesod.Auth.OAuth2.Prelude hiding (encodeUtf8) data AzureUserException = AzureUserError @@ -25,29 +33,32 @@ data AzureUserException = AzureUserError instance Exception AzureUserException +azurePluginName :: Text +azurePluginName = "azureadv2" + ---------------------------------------- ---- OAuth2 development auth plugin ---- ---------------------------------------- mockPluginName :: Text -mockPluginName = "uniworx_dev" +mockPluginName = "dev-oauth2-mock" newtype UserID = UserID Text instance FromJSON UserID where parseJSON = withObject "UserID" $ \o -> UserID <$> o .: "id" -oauth2MockServer :: YesodAuth m => AuthPlugin m -oauth2MockServer = +oauth2MockServer :: YesodAuth m => String -> AuthPlugin m +oauth2MockServer port = let oa = OAuth2 - { oauth2ClientId = "uniworx" - , oauth2ClientSecret = Just "shh" - , oauth2AuthorizeEndpoint = fromString $ mockServerURL <> "/authorize" + { oauth2ClientId = "42" + , oauth2ClientSecret = Just "shhh" + , oauth2AuthorizeEndpoint = (fromString $ mockServerURL <> "/auth") `withQuery` [scopeParam " " ["ID", "Profile"]] , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token" , oauth2RedirectUri = Nothing } - mockServerURL = "0.0.0.0/" - profileSrc = fromString $ mockServerURL <> "/foo" + mockServerURL = "http://localhost:" <> fromString port + profileSrc = fromString $ mockServerURL <> "/users/me" in authOAuth2 mockPluginName oa $ \manager token -> do (UserID userID, userResponse) <- authGetProfile mockPluginName manager token profileSrc return Creds @@ -56,4 +67,78 @@ oauth2MockServer = , credsExtra = setExtra token userResponse } +---------------------- +---- User Queries ---- +---------------------- +data UserDataException = UserDataJSONException JSONException + | UserDataInternalException Text + deriving Show + +instance Exception UserDataException + +queryOAuth2User :: forall j m . (FromJSON j, MonadIO m, MonadThrow m, MonadHandler m) + => Text + -> m (Either UserDataException j) +queryOAuth2User userID = runExceptT $ do + (queryUrl, tokenUrl) <- liftIO mkBaseUrls + req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID + mTokens <- lookupSessionJson SessionOAuth2Token + unless (isJust mTokens) . throwE $ UserDataInternalException "Tried to load session Oauth2 tokens, but there are none" +# ifdef DEVELOPMENT + let secure = False +# else + let secure = True +# endif + newTokens <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl secure + setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens) + eResult <- lift $ getResponseBody <$> httpJSONEither @m @j (req + { secure = secure + , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] }) + case eResult of + Left x -> throwE $ UserDataJSONException x + Right x -> return x + + +mkBaseUrls :: IO (String, String) +mkBaseUrls = do +# ifndef DEVELOPMENT + Just tenantID <- lookupEnv "AZURE_TENANT_ID" + return ( "https://graph.microsoft.com/v1.0/users/" + , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" ) +# else + Just port <- lookupEnv "OAUTH2_SERVER_PORT" + let base = "http://localhost:" ++ port + return ( base ++ "/users/query?id=" + , base ++ "/token" ) +# endif + + +refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m) + => (Maybe AccessToken, Maybe RefreshToken) + -> String + -> Bool + -> ExceptT UserDataException m OAuth2Token +refreshOAuth2Token (_, rToken) url secure + | isJust rToken = do + req <- parseRequest $ "POST " ++ url + let + body = + [ ("grant_type", "refresh_token") + , ("refresh_token", encodeUtf8 . rtoken $ fromJust rToken) + ] + body' <- if secure then do + clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID" + clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET" + return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), ("scope", "openid profile")] + else return $ ("scope", "ID Profile") : body + $logErrorS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure }) + eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure }) + case eResult of + Left x -> throwE $ UserDataJSONException x + Right x -> return x + | otherwise = throwE $ UserDataInternalException "Could not refresh access token. Refresh token is missing." + +instance Show RequestBody where + show (RequestBodyLBS x) = show x + show _ = error ":(" diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index 79fefdccf..20d10b2de 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -140,7 +140,7 @@ instance YesodAuth UniWorX where $(widgetFile "login") authenticate c@Creds{..} - | credsPlugin `elem` ["azureadv2", "uniworx_dev"] = UniWorX.oAuthenticate c + | credsPlugin `elem` ["azureadv2", "dev-oauth2-mock"] = UniWorX.oAuthenticate c | otherwise = UniWorX.authenticate c authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 59e430487..bf486ed22 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -116,12 +116,13 @@ breadcrumb AdminJobsR = i18nCrumb MsgBreadcrumbAdminJobs $ Just breadcrumb AdminAvsR = i18nCrumb MsgMenuAvs $ Just AdminR breadcrumb AdminAvsUserR{} = i18nCrumb MsgAvsPersonInfo $ Just AdminAvsR breadcrumb AdminLdapR = i18nCrumb MsgMenuLdap $ Just AdminR +breadcrumb AdminOAuth2R = i18nCrumb MsgMenuOAuth2 $ Just AdminR breadcrumb AdminProblemsR = i18nCrumb MsgProblemsHeading $ Just AdminR breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just AdminProblemsR breadcrumb ProblemFbutNoR = i18nCrumb MsgProblemsRWithoutFHeading $ Just AdminProblemsR breadcrumb ProblemAvsSynchR = i18nCrumb MsgProblemsAvsSynchHeading $ Just AdminProblemsR -breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just ProblemAvsSynchR +breadcrumb ProblemAvsErrorR = i18nCrumb MsgProblemsAvsErrorHeading $ Just AdminProblemsR breadcrumb FirmAllR = i18nCrumb MsgMenuFirms Nothing breadcrumb FirmsCommR{} = i18nCrumb MsgMenuFirmsComm $ Just FirmAllR @@ -861,6 +862,14 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navQuick' = mempty , navForceActive = False } + , NavLink + { navLabel = MsgMenuOAuth2 + , navRoute = AdminOAuth2R + , navAccess' = NavAccessTrue + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } ] } , return NavHeaderContainer diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 454be37a6..e7f7ba32b 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -9,7 +9,7 @@ module Foundation.Routes ( module Foundation.Routes.Definitions , module Foundation.Routes ) where - + import Import.NoFoundation import Foundation.Type diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index 2bd046479..7c3594a53 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -24,6 +24,7 @@ import Handler.Utils.Memcached import Foundation.Authorization (AuthorizationCacheKey(..)) import Yesod.Auth.Message +import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken) import Auth.LDAP import Auth.OAuth2 import Auth.PWHash (apHash) @@ -131,6 +132,9 @@ oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX => Creds UniWorX -> m (AuthenticationResult UniWorX) oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do $logErrorS "OAuth" $ "\a\27[31m" <> tshow creds <> "\27[0m" + setSessionJson SessionOAuth2Token $ (getAccessToken creds, getRefreshToken creds) + sess <- getSession + $logErrorS "OAuth" $ "\27[34m" <> tshow sess <> "\27[0m" now <- liftIO getCurrentTime let diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 0340bc41f..a64620899 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -21,11 +21,9 @@ import Database.Esqueleto.Experimental ((:&)(..)) import qualified Database.Esqueleto.Experimental as E import qualified Database.Esqueleto.Utils as E -import Handler.Utils.DateTime +import Handler.Utils import Handler.Utils.Avs -import Handler.Utils.Widgets import Handler.Utils.Users -import Handler.Utils.Qualification import Handler.Admin.Test as Handler.Admin import Handler.Admin.ErrorMessage as Handler.Admin @@ -33,6 +31,7 @@ import Handler.Admin.Tokens as Handler.Admin import Handler.Admin.Crontab as Handler.Admin import Handler.Admin.Avs as Handler.Admin import Handler.Admin.Ldap as Handler.Admin +import Handler.Admin.OAuth2 as Handler.Admin getAdminR :: Handler Html @@ -42,22 +41,33 @@ getAdminProblemsR :: Handler Html getAdminProblemsR = do now <- liftIO getCurrentTime let nowaday = utctDay now - cutOffPrintDays = 7 - cutOffPrintJob = addLocalDays (-cutOffPrintDays) now + cutOffOldDays = 1 + cutOffOldTime = toMidnight $ addDays (-cutOffOldDays) nowaday - (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, noAvsSynchProblems) <- runDB $ (,,,,,) + -- 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 + flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip + flagNonZero :: Int -> Widget + flagNonZero n | n <= 0 = flagError True + | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) + + (usersAreReachable, driversHaveAvsIds, rDriversHaveFs, noStalePrintJobs, noBadAPCids, interfaceTable) <- runDB $ (,,,,,) <$> areAllUsersReachable <*> allDriversHaveAvsId now <*> allRDriversHaveFs now - <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <=. cutOffPrintJob]) - <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) - <*> (not <$> exists [UserAvsLastSynchError !=. Nothing]) + <*> (not <$> exists [PrintJobAcknowledged ==. Nothing, PrintJobCreated <. cutOffOldTime]) + <*> (not <$> exists [PrintAcknowledgeProcessed ==. False]) + <*> fmap (view _2) (mkInterfaceLogTable flagError cutOffOldTime) diffLics <- try retrieveDifferingLicences >>= \case -- (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 - forM_ (take 42 $ Set.toList problemIds) $ queueJob' . 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 @@ -72,18 +82,7 @@ getAdminProblemsR = do -- ex -> return $ Left $ text2widget $ tshow ex) -- , Catch.Handler (\(ex::SomeException) -> return $ Left $ text2widget $ tshow ex) -- ] - - -- 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 - flagWarning = messageTooltip . bool msgWarningTooltip msgSuccessTooltip - flagNonZero :: Int -> Widget - flagNonZero n | n <= 0 = flagError True - | otherwise = messageTooltip =<< handlerToWidget (messageI Error (MsgProblemsDriverSynch n)) - rerouteMail <- getsYesod $ view _appMailRerouteTo siteLayoutMsg MsgProblemsHeading $ do @@ -237,4 +236,76 @@ 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/Admin/OAuth2.hs b/src/Handler/Admin/OAuth2.hs new file mode 100644 index 000000000..1face989f --- /dev/null +++ b/src/Handler/Admin/OAuth2.hs @@ -0,0 +1,59 @@ +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel ,David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.Admin.OAuth2 + ( getAdminOAuth2R + , postAdminOAuth2R + ) where + +import Import +-- import qualified Data.CaseInsensitive as CI +import Data.Aeson.Encode.Pretty (encodePretty) +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.Encoding as T +--import qualified Data.Text.Encoding as Text +--import Foundation.Yesod.Auth (CampusUserConversionException()) +import Handler.Utils + +import Auth.OAuth2 (queryOAuth2User) + + +getAdminOAuth2R, postAdminOAuth2R :: Handler Html +getAdminOAuth2R = postAdminOAuth2R +postAdminOAuth2R = do + ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminOAuth2Lookup"::Text) $ \html -> + flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing + + let procFormPerson :: Text -> Handler (Maybe T.Text) + procFormPerson lid = do --return . Just $ "Mock reply for id " <> lid + eUserData <- queryOAuth2User @Value lid + case eUserData of + Left e -> throwM e + Right userData -> return . Just . T.decodeUtf8 $ encodePretty userData + mOAuth2Data <- formResultMaybe presult procFormPerson + + --((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminOAuth2Upsert"::Text) $ \html -> + -- flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing + + --let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User))) + -- procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid) + --mbLdapUpsert <- formResultMaybe uresult procFormUpsert + + + actionUrl <- fromMaybe AdminOAuth2R <$> getCurrentRoute + siteLayoutMsg MsgMenuOAuth2 $ do + setTitleI MsgMenuOAuth2 + let personForm = wrapForm pwidget def + { formAction = Just $ SomeRoute actionUrl + , formEncoding = penctype + } + --upsertForm = wrapForm uwidget def + -- { formAction = Just $ SomeRoute actionUrl + -- , formEncoding = uenctype + -- } + --presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv) + --presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv) + + -- TODO: use i18nWidgetFile instead if this is to become permanent + $(widgetFile "oauth2") diff --git a/src/Handler/Firm.hs b/src/Handler/Firm.hs index 370e30467..53914269e 100644 --- a/src/Handler/Firm.hs +++ b/src/Handler/Firm.hs @@ -94,7 +94,7 @@ firmActionMap mr isAdmin acts = mconcat (mkAct isAdmin <$> acts) <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) mkAct _ FirmActAddSupersvisors = singletonMap FirmActAddSupersvisors $ FirmActAddSupersvisorsData <$> areq (textField & cfAnySeparatedSet) (fslI MsgTableIsDefaultSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> areq checkBoxField (fslI MsgTableIsDefaultReroute ) (Just True) + <*> areq checkBoxField (fslI MsgTableIsDefaultReroute) (Just True) <*> aopt postalEmailField (fslI MsgFormFieldPostal & setTooltip MsgFormFieldPostalTip) Nothing mkAct _ FirmActChangeContactFirm = singletonMap FirmActChangeContactFirm $ FirmActChangeContactFirmData <$> aopt htmlField (fslI MsgPostAddress & setTooltip (SomeMessages [SomeMessage MsgPostAddressTip, SomeMessage MsgUtilEmptyNoChangeTip])) Nothing @@ -380,14 +380,14 @@ firmCountForeignSupervisors cmpy = E.subSelectCountDistinct $ do -- firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) -- firmCountActiveReroutes cmpy = E.subSelectCountDistinct $ do -- usrSuper <- E.from $ E.table @UserSupervisor --- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) +-- E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) -- E.&&. usrSuper E.^. UserSupervisorRerouteNotifications -- pure $ usrSuper E.^. UserSupervisorSupervisor firmCountActiveReroutes :: E.SqlExpr (Entity Company) -> E.SqlExpr (E.Value Word64) firmCountActiveReroutes cmpy = E.subSelectCount $ do usrSuper <- E.from $ E.table @UserSupervisor - E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) + E.where_ $ E.exists (fromUserCompany (Just $ \usrCmpy -> usrCmpy E.^. UserCompanyUser E.==. usrSuper E.^. UserSupervisorUser) cmpy) E.&&. usrSuper E.^. UserSupervisorRerouteNotifications firmQuerySupervisedBy :: CompanyId -> Maybe (E.SqlExpr (Entity UserSupervisor) -> E.SqlExpr (E.Value Bool)) -> E.SqlExpr (Entity User) -> E.SqlQuery () @@ -507,7 +507,7 @@ mkFirmAllTable isAdmin uid = do dbtFilter = mconcat [ single $ fltrCompanyNameNr queryAllCompany , single ("company-number", FilterColumn $ E.mkExactFilterWithComma readMay (queryAllCompany >>> (E.^. CompanyAvsId))) - , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + , single ("is-associate" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do (usr :& usrCmp) <- E.from $ E.table @User `E.innerJoin` E.table @UserCompany `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser) @@ -517,6 +517,25 @@ mkFirmAllTable isAdmin uid = do E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) ) ) + , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do + (usr :& usrCmp) <- E.from $ E.table @User + `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser) + E.where_ $ ((usr E.^. UserDisplayName `E.hasInfix` E.val criterion) + E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk criterion)) + E.||. (usr E.^. UserSurname `E.hasInfix` E.val criterion) + ) E.&&. ((E.isTrue (usrCmp E.?. UserCompanySupervisor) E.&&. usrCmp E.?. UserCompanyCompany E.?=. queryAllCompany row E.^. CompanyId) + E.||. E.exists (do + usrSpr <- E.from $ E.table @UserSupervisor + E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId + E.&&. E.exists (do + usrSub <- E.from $ E.table @UserCompany + E.where_ $ usrSub E.^. UserCompanyUser E.==. usrSpr E.^. UserSupervisorUser + E.&&. usrSub E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId + ) + ) + ) + ) , single ("foreign-supervisor", FilterColumn $ \row (getLast -> criterion) -> -- let checkSuper = do -- expensive -- usrSpr <- E.from $ E.table @UserSupervisor @@ -552,6 +571,7 @@ mkFirmAllTable isAdmin uid = do [ fltrCompanyNameUI mPrev , prismAForm (singletonFilter "company-number") mPrev $ aopt textField (fslI MsgTableCompanyNo) , prismAForm (singletonFilter "is-supervisor") mPrev $ aopt textField (fslI MsgTableSupervisor) + , prismAForm (singletonFilter "is-associate") mPrev $ aopt textField (fslI MsgTableCompanyUser) , prismAForm (singletonFilter "foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterForeignSupervisor) , prismAForm (singletonFilter "company-postal" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterFirmExtern) ] @@ -618,8 +638,8 @@ data FirmUserActionData = FirmUserActNotifyData -- , firmUserActResetMutualSupervision :: Maybe Bool } | FirmUserActSetSupervisorData - { firmUserActSetSuperNames :: Set Text - , firmUserActSetSuperIds :: [UserId] + { firmUserActSetSuperNames :: Maybe (Set Text) + , firmUserActSetSuperIds :: Maybe [UserId] , firmUserActSetSuperReroute :: Bool , firmUserActSetSuperKeep :: Bool } @@ -662,20 +682,31 @@ instance HasUser UserCompanyTableData where mkFirmUserTable :: Bool -> CompanyId -> DB (FormResult (FirmUserActionData, Set UserId), Widget) mkFirmUserTable isAdmin cid = do + mr <- getMessageRender let - mkSprOption (E.Value uid, E.Value udn) = do + mkSprOption (E.Value uid, E.Value udn, E.Value mbSpr) = do uuid <- toPathPiece <$> encryptUser uid - return Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid } - procOptions = fmap mkOptionList . traverse mkSprOption + return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr) + + procOptions rawSupers = do + procSupers <- traverse mkSprOption rawSupers + return $ mkOptionListGrouped $ filter (notNull . snd) + [ (mr MsgFirmSuperDefault , [opt | (opt, Just True ) <- procSupers]) + , (mr MsgFirmSuperIrregular, [opt | (opt, Just False) <- procSupers]) + , (mr MsgFirmSuperForeign , [opt | (opt, Nothing ) <- procSupers]) + ] rawSupers <- E.select $ do - usr <- E.from $ E.table @User - E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr - return (usr E.^. UserId, usr E.^. UserDisplayName) + (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany + `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid) + E.where_ $ E.isTrue (usrCmp E.?. UserCompanySupervisor) + E.||. E.exists (firmQuerySupervisedBy cid Nothing usr) + return (usr E.^. UserId, usr E.^. UserDisplayName, usrCmp E.?. UserCompanySupervisor) let -- supervisorField :: Field Handler UserId - -- supervisorField = selectField $ procOptions rawSupers - supervisorsField = multiSelectField $ procOptions rawSupers + -- supervisorField = selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + supervisorsField = multiSelectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers + fsh = unCompanyKey cid resultDBTable = DBTable{..} @@ -764,8 +795,8 @@ mkFirmUserTable isAdmin cid = do -- superField = selectField $ ???? dbtFilterUI mPrev = mconcat [ fltrUserNameEmailHdrUI MsgTableCompanyUser mPrev - -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) - , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip ) + -- , prismAForm (singletonFilter "supervisor-is" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift supervisorField) (fslI MsgFilterSupervisor) + , prismAForm (multiFilter "supervisors-are" . maybePrism monoPathPieces) mPrev $ aopt (hoistField lift supervisorsField) (fslI MsgFilterSupervisor & setTooltip MsgMultiSelectTip) , prismAForm (singletonFilter "has-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFilterSupervisor) , prismAForm (singletonFilter "has-company-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorCompany fsh) , prismAForm (singletonFilter "has-foreign-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI $ MsgFilterSupervisorForeign fsh) @@ -778,10 +809,10 @@ mkFirmUserTable isAdmin cid = do <$> aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just $ Just False) -- <*> aopt checkBoxField (fslI MsgFirmActResetMutualSupervision) (Just $ Just True ) , singletonMap FirmUserActSetSupervisor $ FirmUserActSetSupervisorData - <$> apopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing - <*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing - <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) - <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) + <$> aopt (textField & cfAnySeparatedSet) (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing + <*> aopt supervisorsField (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip) Nothing + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False) + <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (Just False) , singletonMap FirmUserActMkSuper $ FirmUserActMkSuperData <$> aopt checkBoxField (fslI MsgTableIsDefaultReroute) (Just $ Just True) , singletonMap FirmUserActChangeContact $ FirmUserActChangeContactData @@ -867,10 +898,10 @@ postFirmUsersR fsh = do addMessageI Info $ MsgFirmResetSupervision delSupers newSupers reloadKeepGetParams $ FirmUsersR fsh -- reload to reflect changes (FirmUserActSetSupervisorData{..}, set2NonEmpty (error "Unexpected empty user list in getFirmUserR action handler.") -> uids) -> do - avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser firmUserActSetSuperNames + avsUsers :: Map Text (Maybe UserId) <- sequenceA $ Map.fromSet guessAvsUser $ maybeMonoid firmUserActSetSuperNames let (usersFound', usersNotFound) = partition (is _Just . view _2) $ Map.toList avsUsers usersFound = mapMaybe snd usersFound' - newSupers = Set.toList $ Set.fromList firmUserActSetSuperIds <> Set.fromList usersFound + newSupers = Set.toList $ Set.fromList (maybeMonoid firmUserActSetSuperIds) <> Set.fromList usersFound nrSupers = fromIntegral $ length newSupers nrUsers = fromIntegral $ length uids unless (null usersNotFound) $ diff --git a/src/Handler/LMS/Learners.hs b/src/Handler/LMS/Learners.hs index ff329166e..3e4b00b24 100644 --- a/src/Handler/LMS/Learners.hs +++ b/src/Handler/LMS/Learners.hs @@ -209,10 +209,10 @@ getLmsLearnersDirectR sid qsh = do csvOpts = def { csvFormat = fmtOpts } csvSheetName <- csvFilenameLmsUser qsh let nr = length lms_users - msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + msg = "Success. LMS user learners download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" $logInfoS "LMS" msg addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" - csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered - + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + <* runDB (logInterface "LMS" (ciOriginal qsh) (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 c95f13a1f..201c2eab4 100644 --- a/src/Handler/LMS/Report.hs +++ b/src/Handler/LMS/Report.hs @@ -199,8 +199,7 @@ mkReportTable sid qsh qid = do , LmsReportResult =. lmsReportCsvResult actionData , LmsReportLock =. lmsReportCsvLock actionData , LmsReportTimestamp =. eanow - ] - -- audit $ Transaction.. (add to Audit.Types) + ] lift . queueDBJob $ JobLmsReports qid return $ LmsReportR sid qsh , dbtCsvRenderKey = const $ \case @@ -321,6 +320,7 @@ postLmsReportDirectR sid qsh = 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) "" return (ok200, msg) [] -> do let msg = "Report upload file missing." diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index be4ad973a..4fb8c2c5d 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -16,6 +16,7 @@ import Handler.Utils import Handler.Utils.Csv import Handler.Utils.Profile +import qualified Data.Text as Text (intercalate) -- import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv import Database.Esqueleto.Experimental ((:&)(..)) @@ -137,10 +138,13 @@ getQualificationSAPDirectR = do csvOpts = def { csvFormat = fmtOpts } csvSheetName = "fradrive_sap_" <> fdate <> ".csv" nr = length qualUsers - msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + msg = "Qualification download file " <> csvSheetName <> " containing " <> tshow nr <> " rows" + quals = Text.intercalate ", " $ nubOrd $ mapMaybe (view (_2 . E._unValue)) qualUsers $logInfoS "SAP" msg + let logInt = runDB $ logInterface "SAP" quals (Just nr) "" addHeader "Content-Disposition" $ "attachment; filename=\"" <> csvSheetName <> "\"" - csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered + csvRenderedToTypedContentWith csvOpts csvSheetName csvRendered <* logInt + -- direct Download see: -- https://ersocon.net/blog/2017/2/22/creating-csv-files-in-yesod diff --git a/src/Handler/Submission/Helper/ArchiveTable.hs b/src/Handler/Submission/Helper/ArchiveTable.hs index 737440df2..05062d1a1 100644 --- a/src/Handler/Submission/Helper/ArchiveTable.hs +++ b/src/Handler/Submission/Helper/ArchiveTable.hs @@ -74,7 +74,7 @@ mkSubmissionArchiveTable tid ssh csh shn showCorrection smid = do isFile' = origIsFile <|> corrIsFile in maybeCell ((,) <$> fileTitle'' <*> isFile') $ \(fileTitle', isFile) -> if | Just True <- origIsFile -> anchorCell (subDownloadLink SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|] - | otherwise -> textCell $ bool (<> "/") id isFile fileTitle' + | otherwise -> stringCell $ bool (<> "/") id isFile fileTitle' , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgTableCorState) $ \t -> case t ^? resultCorrected of Nothing -> cell mempty Just (Entity _ SubmissionFile{..}) -> tellCell (Any True) $ if diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index a1ca0a18a..3994b81f0 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -158,8 +158,8 @@ modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget -- | Show Text if it is small, create modal otherwise modalCellLarge :: (IsDBTable m a, ToWidget UniWorX t, MonoFoldable t, Element t ~ Char) => t -> DBCell m a modalCellLarge content - | length content > 32 = modalCell content - | otherwise = textCell content + | length content > 32 = modalCell content + | otherwise = stringCell content markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a markupCellLargeModal mup diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 0d5182704..3b8888837 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1711,9 +1711,11 @@ cell wgt = dbCell # ([], return wgt) wgtCell :: (IsDBTable m a, ToWidget UniWorX wgt) => wgt -> DBCell m a wgtCell = cell . toWidget -textCell, stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a -textCell = cell . toWidget . (pack :: String -> Text) . otoList -stringCell = textCell +textCell :: (IsDBTable m a) => Text -> DBCell m a +textCell = wgtCell + +stringCell :: (MonoFoldable msg, Element msg ~ Char, IsDBTable m a) => msg -> DBCell m a +stringCell = wgtCell . (pack :: String -> Text) . otoList i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a i18nCell msg = cell $ do diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index 1e4a28487..5c85c9c73 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -847,6 +847,10 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do delete oldQKey -- deleteWhere [ QualificationUserUser ==. oldUserId ] -- no longer needed + -- PrintJobs + updateWhere [ PrintJobRecipient ==. Just oldUserId ] [ PrintJobRecipient =. Just newUserId ] + updateWhere [ PrintJobSender ==. Just oldUserId ] [ PrintJobSender =. Just newUserId ] + -- Supervision is fully merged E.insertSelectWithConflict UniqueUserSupervisor diff --git a/src/Jobs/Handler/LMS.hs b/src/Jobs/Handler/LMS.hs index 5ab7745ae..763f46b39 100644 --- a/src/Jobs/Handler/LMS.hs +++ b/src/Jobs/Handler/LMS.hs @@ -117,6 +117,7 @@ dispatchJobLmsEnqueue qid = JobHandlerAtomic act NotificationQualificationExpiry { nQualification = qid, nExpiry = uex } } forM_ renewalUsers (queueDBJob . usr_job) + logInterface "LMS" (qshort <> "-enq") (Just $ length renewalUsers) "" dispatchJobLmsEnqueueUser :: QualificationId -> UserId -> JobHandler UniWorX dispatchJobLmsEnqueueUser qid uid = JobHandlerAtomic act @@ -211,7 +212,8 @@ dispatchJobLmsDequeue qid = JobHandlerAtomic act E.where_ $ E.isNothing (luser E.^. LmsUserStatus) E.&&. luser E.^. LmsUserQualification E.==. E.val qid E.&&. (luser E.^. LmsUserId) `E.in_` E.valList expiredLearners - $logInfoS "LMS" $ "Expired qualification holders " <> tshow nrBlocked <> " and expired lms users " <> tshow nrExpired <> " for qualification " <> qshort + let dequeueInfo = "Blocked qualification holders " <> tshow nrBlocked <> " out of expired lms users " <> tshow nrExpired <> " for qualification " <> qshort + $logInfoS "LMS" dequeueInfo when (quali ^. _qualificationExpiryNotification) $ do -- notifies expired and previously lms-failed drivers notifyInvalidDrivers <- E.select $ do @@ -257,6 +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") dispatchJobLmsReports :: QualificationId -> JobHandler UniWorX diff --git a/src/Jobs/Handler/SynchroniseAvs.hs b/src/Jobs/Handler/SynchroniseAvs.hs index 408758885..0b393f0e2 100644 --- a/src/Jobs/Handler/SynchroniseAvs.hs +++ b/src/Jobs/Handler/SynchroniseAvs.hs @@ -27,6 +27,7 @@ dispatchJobSynchroniseAvs numIterations epoch iteration pause now <- liftIO getCurrentTime todos <- runConduit $ readUsers .| filterIteration now .| sinkList putMany todos + void $ queueJob JobSynchroniseAvsQueue where readUsers :: ConduitT () UserId _ () readUsers = selectKeys [] [] diff --git a/src/Model/Migration.hs b/src/Model/Migration.hs index dc0f83210..c04bf03ee 100644 --- a/src/Model/Migration.hs +++ b/src/Model/Migration.hs @@ -179,8 +179,7 @@ getMissingMigrations :: forall m m'. => ReaderT SqlBackend m (Map ManualMigration (ReaderT SqlBackend m' ())) getMissingMigrations = do $logDebugS "Migration" "Retrieve applied migrations" - appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do - E.where_ $ appliedMigration E.^. AppliedMigrationMigration `E.in_` E.valList universeF + appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do return $ appliedMigration E.^. AppliedMigrationMigration return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations diff --git a/src/Utils.hs b/src/Utils.hs index a2b35c37a..2093da8b2 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -626,6 +626,7 @@ guardMonoid True x = x assertMonoid :: Monoid m => (m -> Bool) -> m -> m assertMonoid f x = guardMonoid (f x) x +-- fold would also do, but is more risky if the Folable isn't Maybe maybeMonoid :: Monoid m => Maybe m -> m -- ^ Identify `Nothing` with `mempty` maybeMonoid = fromMaybe mempty diff --git a/src/Utils/DB.hs b/src/Utils/DB.hs index f53c22d23..de9608a4d 100644 --- a/src/Utils/DB.hs +++ b/src/Utils/DB.hs @@ -97,6 +97,15 @@ updateBy uniq updates = do updateGetEntity :: (PersistStoreWrite backend, MonadIO m, PersistRecordBackend record backend) => Key record -> [Update record] -> ReaderT backend m (Entity record) updateGetEntity k = fmap (Entity k) . updateGet k +-- | insert or replace a record based on a single uniqueness constraint +-- this function was meant to be supplied with the uniqueness constraint, but it would be unsafe if the uniqueness constraint would not match the supplied record +replaceBy :: (PersistUniqueWrite backend, MonadIO m, OnlyOneUniqueKey record, PersistEntityBackend record ~ BaseBackend backend) + => record -> ReaderT backend m () +replaceBy r = do + u <- onlyUnique r + deleteBy u + insert_ r + -- | Like 'myReplaceUnique' or 'replaceUnique' but with reversed result: returns 'Nothing' if the replacement was not possible, -- and 'Just key' for the successfully replaced record uniqueReplace :: ( MonadIO m diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 39107331e..e79761885 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -950,6 +950,53 @@ selectField' optMsg mkOpts = Field{..} #{optionDisplay opt} |] +multiSelectField' :: ( Eq a + , RenderMessage (HandlerSite m) FormMessage + , MonadHandler m + ) + => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option + -> HandlerT (HandlerSite m) IO (OptionList a) + -> Field m [a] +-- ^ Like @multiSelectField@, but it can handle OptionListGrouped and also offers more control over the @Nothing@-Option, if Field is optional +multiSelectField' optMsg mkOpts = Field{..} + where + fieldEnctype = UrlEncoded + + fieldParse [] _ = return $ Right Nothing + fieldParse optlist _ = do + let optlist' = filter notNull optlist + readExternal <- view _olReadExternal <$> liftHandler mkOpts + return $ case mapM readExternal optlist' of + Nothing -> Left $ SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist' + res -> Right res + + fieldView theId name attrs val isReq = do + opts <- liftHandler mkOpts + let + rendered = case val of + Left _ -> [] + Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o] + isSel Nothing = ClassyPrelude.Yesod.null rendered + isSel (Just opt) = optionExternalValue opt `elem` rendered + [whamlet| + $newline never +