Merge branch '140-admin-handler-fur-oauth-response-inspection' into 'oauth2'

Resolve "Admin-Handler für OAuth Response Inspection"

See merge request fradrive/fradrive!24

.ports/assign.hs

@@ -0,0 +1,64 @@
+-- SPDX-FileCopyrightText: 2024 David Mosbach <david.mosbach@uniworx.de>
+--
+-- 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
+

.ports/offsets

@@ -0,0 +1,24 @@
+// SPDX-FileCopyrightText: 2024 David Mosbach <david.mosbach@uniworx.de>
+//
+// SPDX-License-Identifier: AGPL-3.0-or-later
+
+# gkleen
+  -1000
+  -950
+
+# ishka
+  -949
+  -899
+
+# jost
+  -898
+  -848
+
+# mosbach
+  -847
+  -797
+
+# savau
+  -796
+  -746
+

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)
 
 

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
+ProblemsAvsErrorHeading: Fehlermeldungen
+ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit 
+
+InterfaceLastSynch: Zuletzt
+InterfaceSubtype: Betreffend
+InterfaceWrite: Schreibend

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
+ProblemsAvsErrorHeading: Error Log
+ProblemsInterfaceSince: Only considering successes and errors since 
+
+InterfaceLastSynch: Last
+InterfaceSubtype: Affecting
+InterfaceWrite: Write

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.

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.

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"}

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"}

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

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

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
+TableUserEdit: Benutzer bearbeiten
+TableRows: Zeilen

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
+TableUserEdit: Edit user
+TableRows: Rows

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

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

models/audit.model

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- 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

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

nix/docker/version.json

@@ -1,3 +1,3 @@
 {
-  "version": "27.4.52"
+  "version": "27.4.54"
 }

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.52",
+  "version": "27.4.54",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.52",
+  "version": "27.4.54",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name: uniworx
-version: 27.4.52
+version: 27.4.54
 dependencies:
   - base
   - yesod

routes

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
 --
 -- 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

shell.nix

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2023 Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
 #
 # 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

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
+          (oauth2MockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
-        , loadPlugin (oauth2AzureADv2 tenantID) "AZURE_ADV2"
+        , loadPlugin (oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] tenantID) "AZURE_ADV2"
         ]
 
 

src/Audit.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- 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
+    }

src/Audit/Types.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- 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

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 :: YesodAuth m => String -> AuthPlugin m
-oauth2MockServer =
+oauth2MockServer port =
   let oa = OAuth2
-            { oauth2ClientId = "uniworx"
+            { oauth2ClientId = "42"
-            , oauth2ClientSecret = Just "shh"
+            , oauth2ClientSecret = Just "shhh"
-            , oauth2AuthorizeEndpoint = fromString $ mockServerURL <> "/authorize"
+            , oauth2AuthorizeEndpoint = (fromString $ mockServerURL <> "/auth") `withQuery` [scopeParam " " ["ID", "Profile"]]
             , oauth2TokenEndpoint = fromString $ mockServerURL <> "/token"
             , oauth2RedirectUri = Nothing
             }
-      mockServerURL = "0.0.0.0/"
+      mockServerURL = "http://localhost:" <> fromString port
-      profileSrc = fromString $ mockServerURL <> "/foo"
+      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 ":("

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

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

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
 

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

src/Handler/Admin.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- 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
+      cutOffOldDays = 1
-      cutOffPrintJob  = addLocalDays  (-cutOffPrintDays) now      
+      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 [PrintJobAcknowledged ==. Nothing, PrintJobCreated  <. cutOffOldTime])
-      <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])
+      <*> (not <$> exists [PrintAcknowledgeProcessed ==. False])      
-      <*> (not <$> exists [UserAvsLastSynchError !=. Nothing])    
+      <*> 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      
+      let problemIds = avsLicenceDiffRevokeAll <> avsLicenceDiffGrantVorfeld <> avsLicenceDiffRevokeRollfeld <> avsLicenceDiffGrantRollfeld
-      forM_ (take 42 $ Set.toList problemIds) $ queueJob' . flip JobSynchroniseAvsId (Just nowaday)      
+      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

src/Handler/Admin/OAuth2.hs

@@ -0,0 +1,59 @@
+-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>,David Mosbach <david.mosbach@uniworx.de>
+--
+-- 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")

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
+                            {  firmUserActSetSuperNames   :: Maybe (Set Text)
-                            ,  firmUserActSetSuperIds     :: [UserId]
+                            ,  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 }
+      return (Option{ optionDisplay = udn, optionInternalValue = uid, optionExternalValue = uuid }, mbSpr)
-    procOptions = fmap mkOptionList . traverse mkSprOption
+
+    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
+    (usr :& usrCmp) <- E.from $ E.table @User `E.leftJoin` E.table @UserCompany 
-    E.where_ $ E.exists $ firmQuerySupervisedBy cid Nothing usr
+            `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser E.&&. usrCmp E.?. UserCompanyCompany E.==. E.justVal cid)
-    return (usr E.^. UserId, usr E.^. UserDisplayName)
+    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
+    -- supervisorField  =      selectField' (Just $ SomeMessage MsgMultiNoSelection) $ procOptions rawSupers
-    supervisorsField = multiSelectField $ 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 (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 (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
+              <$> aopt (textField & cfAnySeparatedSet)                    (fslI MsgFirmNewSupervisor & setTooltip MsgCourseParticipantsRegisterUsersFieldTip) Nothing
-              <*> apopt supervisorsField (fslI MsgFirmSetSupervisor) Nothing
+              <*> aopt supervisorsField                                   (fslI MsgFirmSetSupervisor & setTooltip MsgMultiSelectTip)                          Nothing
-              <*> apopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip) (Just False)
+              <*> areq (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgMailSupervisorReroute & setTooltip MsgMailSupervisorRerouteTooltip)        (Just False)
-              <*> areq  (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgFirmActResetSuperKeep) (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) $

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

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."

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

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

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
+  | length content > 32 = modalCell  content
-  | otherwise           = textCell  content
+  | otherwise           = stringCell content
 
 markupCellLargeModal :: IsDBTable m a => StoredMarkup -> DBCell m a
 markupCellLargeModal mup

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 :: (IsDBTable m a) => Text -> DBCell m a
-textCell = cell . toWidget . (pack :: String -> Text) . otoList
+textCell = wgtCell
-stringCell = textCell
+
+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

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

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

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 [] []

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
+  appliedMigrations <- fmap (map E.unValue) . E.select . E.from $ \appliedMigration -> do    
-    E.where_ $ appliedMigration E.^. AppliedMigrationMigration `E.in_` E.valList universeF
     return $ appliedMigration E.^. AppliedMigrationMigration
   return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
 

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

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

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
+        <select ##{theId} name=#{name} multiple *{attrs} :isReq:required>
+          $maybe optMsg' <- assertM (const $ not isReq) optMsg
+            <option value="" :isSel Nothing:selected>
+              _{optMsg'}
+          $case opts
+            $of OptionList{olOptions}
+              $forall opt <- olOptions
+                <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
+                  #{optionDisplay opt}
+            $of OptionListGrouped{olOptionsGrouped}
+              $forall (groupLbl, iOpts) <- olOptionsGrouped
+                <optgroup label=#{groupLbl}>
+                  $forall opt <- iOpts
+                    <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
+                      #{optionDisplay opt}
+      |]
+
 radioField' :: ( Eq a
                , RenderMessage (HandlerSite m) FormMessage
                , MonadHandler m

src/Utils/Icon.hs

@@ -116,6 +116,7 @@ data Icon
   | IconUnlocked
   | IconResetTries -- also see IconReset
   | IconCompany
+  | IconEdit
   | IconUserEdit
   
   deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
@@ -211,6 +212,7 @@ iconText = \case
     IconUnlocked                -> "lock-open-alt"
     IconResetTries              -> "trash-undo"
     IconCompany                 -> "building"
+    IconEdit                    -> "edit"
     IconUserEdit                -> "user-edit"
 
 nullaryPathPiece ''Icon $ camelToPathPiece' 1

src/Utils/Lens.hs

@@ -309,6 +309,8 @@ makeLenses_ ''AuthorshipStatementDefinition
 
 makeLenses_ ''PrintJob
 
+makeLenses_ ''InterfaceLog
+
 --------------------------
 -- Fields for `UniWorX` --
 --------------------------

src/Utils/Session.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -20,6 +20,7 @@ data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
                 | SessionLang
                 | SessionError
                 | SessionFiles
+                | SessionOAuth2Token
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
   deriving anyclass (Universe, Finite)
 

templates/admin-problems.hamlet

@@ -43,7 +43,7 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
     <dd .deflist__dd>^{simpleLinkI MsgProblemsUsersAreReachable ProblemUnreachableR}
 
     <dt .deflist__dt>^{flagError noStalePrintJobs}
-    <dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffPrintDays) PrintCenterR}
+    <dd .deflist__dd>^{simpleLinkI (MsgProblemsNoStalePrintJobs cutOffOldDays) PrintCenterR}
 
     <dt .deflist__dt>^{flagError noBadAPCids}
     <dd .deflist__dd>_{MsgProblemsNoBadAPCIds}
@@ -54,7 +54,11 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 <section>
   <h2>
-    _{MsgProblemsHeadingMisc}
+    _{MsgMenuInterfaces}  
-  <dl .deflist>
+  <div>
-    <dt .deflist__dt>^{flagError noAvsSynchProblems}
+    <p>
-    <dd .deflist__dd>^{simpleLinkI MsgProblemsNoAvsSynchProblems ProblemAvsErrorR}
+      _{MsgProblemsInterfaceSince} ^{formatTimeW SelFormatDate cutOffOldTime}
+    ^{interfaceTable}
+
+<!-- section h2 {MsgProblemsHeadingMisc} -->
+

templates/login.hamlet

@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+$# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -9,7 +9,7 @@ $forall AuthPlugin{apName, apLogin} <- plugins
     <section>
       <h2>Azure
       ^{apLogin toParent}
-  $elseif apName == "uniworx_dev"
+  $elseif apName == "dev-oauth2-mock"
     <section>
       <h2>_{MsgDummyLoginTitle}
       ^{apLogin toParent}

templates/oauth2.hamlet

@@ -0,0 +1,19 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@uniworx.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<section>
+  <p> 
+    OAuth2 User Search:
+    ^{personForm}
+  $maybe answers <- mOAuth2Data
+    <h1>
+      Antwort: #
+    <dl .deflist>
+          <dt>
+            <pre>
+              #{answers}
+          <dd>
+            

test/Database/test-users.yaml

@@ -0,0 +1,231 @@
+# SPDX-FileCopyrightText: 2024 David Mosbach <david.mosbach@uniworx.de>
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+special-users:
+
+  - default: &default-user
+      userIdent: null
+      userAuthentication: AuthLDAP
+      userLastAuthentication: null
+      userTokensIssuedAfter: null
+      userMatrikelnummer: null
+      userEmail: ""
+      userDisplayEmail: null
+      userDisplayName: null
+      userSurname: ""
+      userFirstName: ""
+      userTitle: null
+      userMaxFavourites: userDefaultMaxFavourites
+      userMaxFavouriteTerms: userDefaultMaxFavouriteTerms
+      userTheme: ThemeDefault
+      userDateTimeFormat: userDefaultDateTimeFormat
+      userDateFormat: userDefaultDateFormat
+      userTimeFormat: userDefaultTimeFormat
+      userDownloadFiles: userDefaultDownloadFiles
+      userWarningDays: userDefaultWarningDays
+      userLanguages: null
+      userCreated: now
+      userNotificationSettings: def
+      userLastLdapSynchronisation: null
+      userLdapPrimaryKey: null
+      userCsvOptions: def
+      userSex: null
+      userBirthday: null
+      userShowSex: userDefaultShowSex
+      userTelephone: null
+      userMobile: null
+      userCompanyPersonalNumber: null
+      userCompanyDepartment: null
+      userPinPassword: null
+      userPostAddress: null
+      userPostLastUpdate: null
+      userPrefersPostal: true
+      userExamOfficeGetSynced: userDefaultExamOfficeGetSynced
+      userExamOfficeGetLabels: userDefaultExamOfficeGetLabels
+
+  - gkleen:
+      <<: *default-user
+      userIdent: "G.Kleen@campus.lmu.de"
+      userLastAuthentication: now
+      userTokensIssuedAfter: now
+      userEmail: "G.Kleen@campus.lmu.de"
+      userDisplayEmail: "gregor.kleen@ifi.lmu.de"
+      userDisplayName: "Gregor Kleen"
+      userSurname: "Kleen"
+      userFirstName: "Gregor Julius Arthur"
+      userMaxFavourites: 6
+      userMaxFavouriteTerms: 1
+      userLanguages: ["en"]
+      # userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
+      userSex: SexMale
+      userCompanyPersonalNumber: "00000"
+      userPostAddress: "Büro 127   \nMathematisches Institut der Ludwig-Maximilians-Universität München   \nTheresienstr. 39   \nD-80333 München"
+
+  - fhamann:
+      <<: *default-user
+      userIdent: "felix.hamann@campus.lmu.de"
+      userEmail: "noEmailKnown"
+      userDisplayEmail: "felix.hamann@campus.lmu.de"
+      userDisplayName: "Felix Hamann"
+      userSurname: "Hamann"
+      userFirstName: "Felix"
+      # userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
+      userSex: SexMale
+      userPinPassword: "tomatenmarmelade"
+      userPostAddress: "Erdbeerweg 24  \n12345 Schlumpfhausen  \nTraumland"
+
+  - jost:
+      <<: *default-user
+      userIdent: "jost@tcs.ifi.lmu.de"
+      userAuthentication: pwSimple
+      userMatrikelnummer: "12345678"
+      userEmail: "S.Jost@Fraport.de"
+      userDisplayEmail: "jost@tcs.ifi.lmu.de"
+      userDisplayName: "Steffen Jost"
+      userSurname: "Jost"
+      userFirstName: "Steffen"
+      userTitle: "Dr."
+      userMaxFavourites: 14
+      userMaxFavouriteTerms: 4
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      # userBirthday = Just $ n_day $ 35 * (-365)
+      userTelephone: "+49 69 690-71706"
+      userMobile: "0173 69 99 646"
+      userCompanyPersonalNumber: "57138"
+      userCompanyDepartment: "AVN-AR2"
+
+  - maxMuster:
+      <<: *default-user
+      userIdent: "max@campus.lmu.de"
+      userLastAuthentication: now
+      userMatrikelnummer: "1299"
+      userEmail: "max@campus.lmu.de"
+      userDisplayEmail: "max@max.com"
+      userDisplayName: "Max Musterstudent"
+      userSurname: "Musterstudent"
+      userFirstName: "Max"
+      userMaxFavourites: 7
+      userTheme: ThemeAberdeenReds
+      userLanguages: ["de"]
+      userSex: SexMale
+      # userBirthday = Just $ n_day $ 27 * (-365)
+      userPrefersPostal: false
+
+  - tinaTester:
+      <<: *default-user
+      userIdent: "tester@campus.lmu.de"
+      userAuthentication: null
+      userMatrikelnummer: "999"
+      userEmail: "tester@campus.lmu.de"
+      userDisplayEmail: "tina@tester.example"
+      userDisplayName: "Tina Tester"
+      userSurname: "vön Tërrör¿"
+      userFirstName: "Sabrina"
+      userTitle: "Magister"
+      userMaxFavourites: 5
+      userTheme: ThemeAberdeenReds
+      userLanguages: ["sn"]
+      userSex: SexNotApplicable
+      # userBirthday = Just $ n_day 3
+      userCompanyPersonalNumber: "12345"
+      userPrefersPostal: false
+
+  - svaupel:
+      <<: *default-user
+      userIdent: "vaupel.sarah@campus.lmu.de"
+      userEmail: "vaupel.sarah@campus.lmu.de"
+      userDisplayEmail: "vaupel.sarah@campus.lmu.de"
+      userDisplayName: "Sarah Vaupel"
+      userSurname: "Vaupel"
+      userFirstName: "Sarah"
+      userMaxFavourites: 14
+      userMaxFavouriteTerms: 4
+      userTheme: ThemeMossGreen
+      userLanguages: null
+      userSex: SexFemale
+      userPrefersPostal: false
+
+  - sbarth:
+      <<: *default-user
+      userIdent: "Stephan.Barth@campus.lmu.de"
+      userEmail: "Stephan.Barth@lmu.de"
+      userDisplayEmail: "stephan.barth@ifi.lmu.de"
+      userDisplayName: "Stephan Barth"
+      userSurname: "Barth"
+      userFirstName: "Stephan"
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      userPrefersPostal: false
+      userExamOfficeGetSynced: false
+      userExamOfficeGetLabels: true
+
+  - _stranger1:
+      userIdent: "AVSID:996699"
+      userEmail: "E996699@fraport.de"
+      userDisplayEmail: ""
+      userDisplayName: "Stranger One"
+      userSurname: "One"
+      userFirstName: "Stranger"
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      userCompanyPersonalNumber: "E996699"
+      userCompanyDepartment: "AVN-Strange"
+      userPrefersPostal: false
+      userExamOfficeGetSynced: false
+      userExamOfficeGetLabels: true
+
+  - _stranger2:
+      userIdent: "AVSID:669966"
+      userEmail: "E669966@fraport.de"
+      userDisplayEmail: ""
+      userDisplayName: "Stranger Two"
+      userSurname: "Stranger"
+      userFirstName: "Two"
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      userCompanyPersonalNumber: "669966"
+      userCompanyDepartment: "AVN-Strange"
+      userPrefersPostal: false
+      userExamOfficeGetSynced: false
+      userExamOfficeGetLabels: true
+
+  - _stranger3:
+      userIdent: "AVSID:6969"
+      userEmail: "E6969@fraport.de"
+      userDisplayEmail: ""
+      userDisplayName: "Stranger 3 Three"
+      userSurname: "Three"
+      userFirstName: "Stranger"
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      userCompanyPersonalNumber: "E996699"
+      userCompanyDepartment: "AVN-Strange"
+      userPostAddress: "Kartoffelweg 12  \n666 Höllensumpf  \nFreiland"
+      userPrefersPostal: false
+      userExamOfficeGetSynced: false
+      userExamOfficeGetLabels: true
+
+
+random-users:
+  firstNames: [ "James", "John", "Robert", "Michael"
+              , "William", "David", "Mary", "Richard"
+              , "Joseph", "Thomas", "Charles", "Daniel"
+              , "Matthew", "Patricia", "Jennifer", "Linda"
+              , "Elizabeth", "Barbara", "Anthony", "Donald"
+              , "Mark", "Paul", "Steven", "Andrew"
+              , "Kenneth", "Joshua", "George", "Kevin"
+              , "Brian", "Edward", "Susan", "Ronald"
+              ]
+  surnames: [ "Smith", "Johnson", "Williams", "Brown"
+            , "Jones", "Miller", "Davis", "Garcia"
+            , "Rodriguez", "Wilson", "Martinez", "Anderson"
+            , "Taylor", "Thomas", "Hernandez", "Moore"
+            , "Martin", "Jackson", "Thompson", "White"
+            , "Lopez", "Lee", "Gonzalez", "Harris"
+            , "Clark", "Lewis", "Robinson", "Walker"
+            , "Perez", "Hall", "Young", "Allen"
+            ]
+  middlenames: [ null, "Jamesson" ]
+