Merge branch '142-userdata-oauth-mode' into 'oauth2'

Resolve "Benutzerdaten-Abfrage: Mehrere Modi & OAuth-Modus"

See merge request fradrive/fradrive!26

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.56](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.55...v27.4.56) (2023-12-20)
+
+
+### Bug Fixes
+
+* **firm:** improve supervisor filter by caching ([88f24fe](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/88f24fe6f199290a83af2d204ba9aa2a838d11b8))
+* **firm:** improve supervisor filter yet once more ([c7b5a3c](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/c7b5a3c6cb70c314ecbfbe25969b4b6be1d43161))
+* **users:** fix [#121](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/121) by providing last login column, which was the last part missing ([decc5af](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/decc5af6829998e2d0db79382bbd9a7bad7b5b09))
+
+## [27.4.55](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.54...v27.4.55) (2023-12-14)
+
+
+### Bug Fixes
+
+* **build:** while the blank is necessary to prevent unnecessary migrations, it is not allowed either, see [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) ([a4b2af7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a4b2af7f157444ead8c9df989741b266f7c2b4f2))
+* **firm:** supervisor filter performance ([db77850](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/db77850c4f4cd1d68bfd38e02e0ae24584e1e556))
+* **migration:** fix [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) by removing old outdated migrations irrelevant to FRADrive ([d4f0d69](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/d4f0d69428a4f7fc887cb6854cb59e3dea83b9bc))
+* **migration:** ignore superfluous migration entries gracefully ([1d48b62](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/1d48b627f6b8cf1b03e2ef63850c36c429c9d3d6))
+* **school:** fix [#133](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/issues/133) by adjusting default value ([2509358](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/25093588784381a19f34e5b091677b908420ddea))
+
 ## [27.4.54](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v27.4.53...v27.4.54) (2023-12-11)
 
 

config/settings.yml

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 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>,David Mosbach <david.mosbach@uniworx.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@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
 
@@ -25,8 +25,8 @@ mail-from:
 mail-object-domain: "_env:MAILOBJECT_DOMAIN:localhost"
 mail-use-replyto-instead-sender: "_env:MAIL_USES_REPLYTO:true"
 mail-reroute-to:
- name:         "_env:MAIL_REROUTE_TO_NAME:"
+  name:         "_env:MAIL_REROUTE_TO_NAME:"
- email:        "_env:MAIL_REROUTE_TO_EMAIL:"
+  email:        "_env:MAIL_REROUTE_TO_EMAIL:"
 #mail-verp:
 #  separator:    "_env:VERP_SEPARATOR:+"
 #  prefix:       "_env:VERP_PREFIX:bounce"
@@ -66,7 +66,7 @@ keep-unreferenced-files: 86400
 health-check-interval:
   matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600"
   http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600"
-  ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600"
+  ldap-admins: "_env:HEALTHCHECK_INTERVAL_LDAP_ADMINS:600" # TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
   smtp-connect: "_env:HEALTHCHECK_INTERVAL_SMTP_CONNECT:600"
   widget-memcached: "_env:HEALTHCHECK_INTERVAL_WIDGET_MEMCACHED:600"
   active-job-executors: "_env:HEALTHCHECK_INTERVAL_ACTIVE_JOB_EXECUTORS:60"
@@ -77,13 +77,10 @@ health-check-http: "_env:HEALTHCHECK_HTTP:true" # Can we assume, that we can rea
 health-check-active-job-executors-timeout: "_env:HEALTHCHECK_ACTIVE_JOB_EXECUTORS_TIMEOUT:5"
 health-check-active-widget-memcached-timeout: "_env:HEALTHCHECK_ACTIVE_WIDGET_MEMCACHED_TIMEOUT:2"
 health-check-smtp-connect-timeout: "_env:HEALTHCHECK_SMTP_CONNECT_TIMEOUT:5"
-health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60"
+health-check-ldap-admins-timeout: "_env:HEALTHCHECK_LDAP_ADMINS_TIMEOUT:60" # TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
 health-check-http-reachable-timeout: "_env:HEALTHCHECK_HTTP_REACHABLE_TIMEOUT:2"
 health-check-matching-cluster-config-timeout: "_env:HEALTHCHECK_MATCHING_CLUSTER_CONFIG_TIMEOUT:2"
 
-synchronise-ldap-users-within: "_env:SYNCHRONISE_LDAP_WITHIN:1209600"   # 14 Tage in Sekunden
-synchronise-ldap-users-interval: "_env:SYNCHRONISE_LDAP_INTERVAL:3600"  # jede Stunde
-
 synchronise-avs-users-within: "_env:SYNCHRONISE_AVS_WITHIN:5702400"     # alle 66 Tage
 synchronise-avs-users-interval: "_env:SYNCHRONISE_AVS_INTERVAL:21600"   # alle 6 Stunden
 
@@ -129,26 +126,43 @@ database:
   database: "_env:PGDATABASE:uniworx"
   poolsize: "_env:PGPOOLSIZE:990"
 
-auto-db-migrate: '_env:AUTO_DB_MIGRATE:true'
+auto-db-migrate: "_env:AUTO_DB_MIGRATE:true"
+
+# External sources used for user authentication and userdata lookups
+user-auth:
+# mode: single-source
+  protocol: azureadv2
+  config:
+    client-id:     "_env:AZURECLIENTID:00000000-0000-0000-0000-000000000000"
+    client-secret: "_env:AZURECLIENTSECRET:''"
+    tenant-id:     "_env:AZURETENANTID:00000000-0000-0000-0000-000000000000"
+    scopes:        "_env:AZURESCOPES:[ID,Profile]"
+    # protocol: "ldap"
+    # config:
+    #   host:           "_env:LDAPHOST:"
+    #   tls:            "_env:LDAPTLS:"
+    #   port:           "_env:LDAPPORT:389"
+    #   user:           "_env:LDAPUSER:"
+    #   pass:           "_env:LDAPPASS:"
+    #   baseDN:         "_env:LDAPBASE:"
+    #   scope:          "_env:LDAPSCOPE:WholeSubtree"
+    #   timeout:        "_env:LDAPTIMEOUT:5"
+    #   search-timeout: "_env:LDAPSEARCHTIME:5"
 
 single-sign-on: "_env:OIDC_SSO:true"
 
-ldap:
+# TODO: generalize for arbitrary auth protocols
-  - host:    "_env:LDAPHOST:"
+# TODO: maybe use separate pools for external databases?
-    tls:     "_env:LDAPTLS:"
+ldap-pool:
-    port:    "_env:LDAPPORT:389"
+  stripes: "_env:LDAPSTRIPES:1"
-    user:    "_env:LDAPUSER:"
+  timeout: "_env:LDAPTIMEOUT:20"
-    pass:    "_env:LDAPPASS:"
+  limit:   "_env:LDAPLIMIT:10"
-    baseDN:  "_env:LDAPBASE:"
-    scope:   "_env:LDAPSCOPE:WholeSubtree"
-    timeout: "_env:LDAPTIMEOUT:5"
-    search-timeout: "_env:LDAPSEARCHTIME:5"
-    pool:
-      stripes: "_env:LDAPSTRIPES:1"
-      timeout: "_env:LDAPTIMEOUT:20"
-      limit:   "_env:LDAPLIMIT:10"
 
-ldap-re-test-failover: 60
+# TODO: reintroduce and move into failover settings once failover mode has been reimplemented
+# user-retest-failover: 60
+# TODO; maybe implement syncWithin and syncInterval per auth source
+user-sync-within:   "_env:USER_SYNC_WITHIN:1209600" # 14 Tage in Sekunden
+user-sync-interval: "_env:USER_SYNC_INTERVAL:3600"  # jede Stunde
 
 lms-direct:
   upload-header:        "_env:LMSUPLOADHEADER:true"

messages/uniworx/categories/admin/de-de-formal.msg

@@ -124,3 +124,5 @@ ProblemsInterfaceSince: Berücksichtigt werden nur Erfolge und Fehler seit
 InterfaceLastSynch: Zuletzt
 InterfaceSubtype: Betreffend
 InterfaceWrite: Schreibend
+
+AdminUserPassword: Passwort

messages/uniworx/categories/admin/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -124,3 +124,5 @@ ProblemsInterfaceSince: Only considering successes and errors since
 InterfaceLastSynch: Last
 InterfaceSubtype: Affecting
 InterfaceWrite: Write
+
+AdminUserPassword: Password

messages/uniworx/categories/authorization/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+# SPDX-FileCopyrightText: 2022-2024 David Mosbach <david.mosbach@uniworx.de>, 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>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -72,8 +72,8 @@ UnauthorizedTutorialTutorControl: Ausbilder:innen dürfen diesen Kurs nicht edit
 UnauthorizedCourseTutor: Sie sind nicht Ausbilder:in für diese Kursart.
 UnauthorizedTutor: Sie sind nicht Ausbilder:in.
 UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Kurs mit derselben Registrierungs-Gruppe eingetragen.
-UnauthorizedLDAP: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit Fraport Login an.
+UnauthorizedExternal: Angegebene:r Benuzter:in meldet sich nicht über einen aktuell unterstützten externen Login an.
-UnauthorizedPWHash: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit FRADrive-Kennung an.
+UnauthorizedInternal: Angegebene:r Benutzer:in meldet sich nicht mit FRADrive-Kennung an.
 UnauthorizedExternalExamListNotEmpty: Liste von externen Prüfungen ist nicht leer
 UnauthorizedExternalExamLecturer: Sie sind nicht als Prüfer:in für diese externe Prüfung eingetragen
 UnauthorizedSubmissionSubmissionGroup: Sie sind nicht Mitglied in einer der registrierten Abgabegruppen, die an dieser Abgabe beteiligt sind
@@ -102,15 +102,15 @@ LDAPLoginTitle: Fraport Login für interne und externe Nutzer
 PWHashLoginTitle: Spezieller Funktionsnutzer Login
 PWHashLoginNote: Verwenden Sie dieses Formular nur, wenn Sie explizit dazu aufgefordert wurden. Alle anderen sollten das andere Login Formular verwenden!
 DummyLoginTitle: Development-Login
-InternalLdapError: Interner Fehler beim Fraport Büko-Login
+InternalLoginError: Interner Fehler beim Login
-CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
+DecodeUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln
-CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
+DecodeUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln
-CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
+DecodeUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln
-CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
+DecodeUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln
-CampusUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
+DecodeUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln
-CampusUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
+DecodeUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln
-CampusUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
+DecodeUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge ermitteln
-CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln
+DecodeUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln
 InvalidCredentialsADNoSuchObject: Benutzereintrag existiert nicht
 InvalidCredentialsADLogonFailure: Ungültiges Passwort
 InvalidCredentialsADAccountRestriction: Beschränkungen des Fraport Accounts verhindern Login

messages/uniworx/categories/authorization/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -72,8 +72,8 @@ UnauthorizedTutorialTutorControl: Instructors may not edit this course.
 UnauthorizedCourseTutor: You are no instructor for this course.
 UnauthorizedTutor: You are no instructor.
 UnauthorizedTutorialRegisterGroup: You are already registered for a course with the same registration group.
-UnauthorizedLDAP: Specified user does not log in with their Fraport password.
+UnauthorizedExternal: Specified user does not log in with any currently supported external login.
-UnauthorizedPWHash: Specified user does not log in with an FRADrive-account.
+UnauthorizedInternal: Specified user does not log in with a FRADrive-account.
 UnauthorizedExternalExamListNotEmpty: List of external exams is not empty
 UnauthorizedExternalExamLecturer: You are not an associated person for this external exam
 UnauthorizedSubmissionSubmissionGroup: You are not member in any of the submission groups for this submission
@@ -103,15 +103,15 @@ LDAPLoginTitle: Fraport login for intern and extern users
 PWHashLoginTitle: Special function user login
 PWHashLoginNote: Only use this login form if you have received special instructions to do so. All others should use the other login field.
 DummyLoginTitle: Development login
-InternalLdapError: Internal error during Fraport Büko login
+InternalLoginError: Internal error during login
-CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login
+DecodeUserInvalidIdent: Could not determine unique identification during Fraport Büko login
-CampusUserInvalidEmail: Could not determine email address during Fraport Büko login
+DecodeUserInvalidEmail: Could not determine email address during Fraport Büko login
-CampusUserInvalidDisplayName: Could not determine display name during Fraport Büko login
+DecodeUserInvalidDisplayName: Could not determine display name during Fraport Büko login
-CampusUserInvalidGivenName: Could not determine given name during Fraport Büko login
+DecodeUserInvalidGivenName: Could not determine given name during Fraport Büko login
-CampusUserInvalidSurname: Could not determine surname during Fraport Büko login
+DecodeUserInvalidSurname: Could not determine surname during Fraport Büko login
-CampusUserInvalidTitle: Could not determine title during Fraport Büko login
+DecodeUserInvalidTitle: Could not determine title during Fraport Büko login
-CampusUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
+DecodeUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login
-CampusUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
+DecodeUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login
 InvalidCredentialsADNoSuchObject: User entry does not exist
 InvalidCredentialsADLogonFailure: Invalid password
 InvalidCredentialsADAccountRestriction: Restrictions on your Fraport account prevent a login

messages/uniworx/categories/send/send_notifications/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -75,11 +75,10 @@ NotPassed: Nicht bestanden
 
 #userAuthModeUpdate.hs + templates
 MailSubjectUserAuthModeUpdate: Ihr FRADrive-Login
-UserAuthModeChangedToLDAP: Sie können sich nun mit Ihrer Fraport AG Kennung (Büko) in FRADrive einloggen.
+UserAuthPasswordEnabled: Sie können sich nun mit einer FRADrive-internen Kennung einloggen.
-UserAuthModeChangedToPWHash: Sie können sich nun mit einer FRADrive-internen Kennung einloggen.
+UserAuthPasswordDisabled: Sie können sich nun nicht mehr mit Ihrer FRADrive-internen Kennung einloggen.
-UserAuthModeChangedToNoLogin: Ihr Login auf der FRADrive Webseite wurde deaktiviert, aber ihr FRADrive Konto besteht weiterhin. Gültigkeit und Verlängerungen Ihrer Qualifikationen sind dadurch nicht beeinträchtigt. Wenden Sie sich an die Fahrschuladmins, wenn der Login auf der FRADrive Webseite benötigt werden sollte.
+AuthExternalLoginTip: Sollten Sie Zugriff zu einem von FRADrive unterstützten externen Account (Azure-Login über Fraport-Kennung, Fraport-BüKo-Login) besitzen, so können Sie sich mit Ihren externen Login-Daten in FRADrive einloggen.
-AuthPWHashTip: Sie müssen nun das mit "FRADrive-Login" beschriftete Login-Formular verwenden. Stellen Sie bitte sicher, dass Sie ein Passwort gesetzt haben, bevor Sie versuchen sich anzumelden.
+PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie aus Sicherheitsgründen in einer separaten E-Mail.
-PasswordResetEmailIncoming: Einen Link um ihr Passwort zu setzen bzw. zu ändern bekommen Sie, aus Sicherheitsgründen, in einer separaten E-Mail.
 MailFradrive !ident-ok: FRADrive
 MailBodyFradrive: ist die Führerscheinverwaltungsapp der Fraport AG.
 

messages/uniworx/categories/send/send_notifications/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -75,10 +75,9 @@ NotPassed: Failed
 
 #userAuthModeUpdate.hs + templates
 MailSubjectUserAuthModeUpdate: Your FRADrive login
-UserAuthModeChangedToLDAP: You can now log in to FRADrive using your Fraport AG account (Büko)
+UserAuthPasswordEnabled: You can now log in using your FRADrive-internal account credentials.
-UserAuthModeChangedToPWHash: You can now log in using your FRADrive-internal account
+UserAuthPasswordDisabled: You can no longer log in using your FRADrive-internal account credentials.
-UserAuthModeChangedToNoLogin: Your login for the FRADrive website has been deactivated, but you FRADrive account persists. This has no effect on you qualifications. Please contact the driving school admins, if you need new login credentials for the FRADrive website.
+AuthExternalLoginTip: If you have access to an external account supported by FRADrive (Azure login via Fraport identification, Fraport-BüKo login), you can login in FRADrive using your external credentials.
-AuthPWHashTip: You now need to use the login form labeled "FRADrive login". Please ensure that you have already set a password when you try to log in.
 PasswordResetEmailIncoming: For security reasons you will receive a link to the page on which you can set and later change your password in a separate email.
 MailFradrive: FRADrive
 MailBodyFradrive: is the apron driver's licence management app of Fraport AG.

messages/uniworx/categories/settings/auth_settings/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,8 +45,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursartteilnehmer:innen
 AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektor:innen
 AuthTagCorrectionAnonymous: Korrektur ist anonymisiert
 AuthTagSelf: Nutzer:in greift nur auf eigene Daten zu
-AuthTagIsLDAP: Nutzer:in meldet sich mit Fraport AG Kennung an
+AuthTagIsExternal: Nutzer:in meldet sich mit extern verwalteten Logindaten an
-AuthTagIsPWHash: Nutzer:in meldet sich mit FRADrive spezifischer Kennung an
+AuthTagIsInternal: Nutzer:in meldet sich mit FRADrive-internen Logindaten an
 AuthTagAuthentication: Nutzer:in ist angemeldet, falls erforderlich
 AuthTagRead: Zugriff ist nur lesend
 AuthTagWrite: Zugriff ist i.A. schreibend

messages/uniworx/categories/settings/auth_settings/en-eu.msg

@@ -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>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-2024 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>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -45,8 +45,8 @@ AuthTagUserSubmissions: Submissions are made by course type participants
 AuthTagCorrectorSubmissions: Submissions are registered by correctors
 AuthTagCorrectionAnonymous: Correction is anonymised
 AuthTagSelf: User is only accessing their only data
-AuthTagIsLDAP: User logs in using their Fraport AG account
+AuthTagIsExternal: User logs in using externally managed credentials
-AuthTagIsPWHash: User logs in using their FRADrive specific account
+AuthTagIsInternal: User logs in using FRADrive-internal credentials
 AuthTagAuthentication: User is authenticated
 AuthTagRead: Access is read only
 AuthTagWrite: Access might write

messages/uniworx/categories/user/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -38,8 +38,8 @@ AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennun
 UsersCourseSchool: Bereich
 ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
 SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
-SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
+SynchroniseUserdbUserQueued n@Int: Benutzerdatenbank-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
-SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen
+SynchroniseUserdbAllUsersQueued: Benutzerdatenbank-Synchronisation von allen Benutzer:innen angestoßen
 UserListTitle: Komprehensive Benutzerliste
 AccessRightsSaved: Berechtigungen erfolgreich verändert
 AccessRightsNotChanged: Berechtigungen wurden nicht verändert
@@ -48,6 +48,7 @@ AuthLDAPInvalidLookup: Bestehender Nutzer/Bestehende Nutzerin konnte nicht einde
 AuthLDAPAlreadyConfigured: Nutzer:in meldet sich bereits per Fraport AG Kennung in FRADrive an
 AuthLDAPConfigured: Nutzer:in meldet sich nun per Fraport AG Kennung in FRADrive an
 AuthLDAP !ident-ok: Fraport AG Kennung
+AuthAzure: Azure-Account
 AuthNoLogin: Kein Login erlaubt.
 PasswordResetQueued: Link zum Passwort-Zurücksetzen versandt
 UserAssimilateUser: Benutzer:in
@@ -95,10 +96,14 @@ UserAddSupervisor: Ansprechpartner hinzufügen
 UserSetSupervisor: Ansprechpartner ersetzen
 UserRemoveSupervisor: Alle Ansprechpartner entfernen
 UserIsSupervisor: Ist Ansprechpartner
-AuthKindLDAP: Fraport AG Kennung
-AuthKindPWHash: FRADrive Kennung
-AuthKindNoLogin: Kein Login möglich
 Name !ident-ok: Name
 UsersChangeSupervisorsSuccess usr@Int spr@Int: #{tshow spr} Ansprechpartner für #{tshow usr} Benutzer gesetzt.
 UsersChangeSupervisorsWarning usr@Int spr@Int bad@Int: Nur _{MsgUsersChangeSupervisorsSuccess usr spr} #{tshow bad} Ansprechpartner #{pluralDE bad "wurde" "wurden"} nicht gefunden!
 UsersRemoveSupervisors usr@Int: Alle Ansprechpartner für #{tshow usr} Benutzer gelöscht.
+
+AdminUserAuthentication: Authentification
+AdminUserAuthLastSync: Zuletzt synchronisiert
+AuthKindLDAP: Fraport-AG-Kennung (LDAP)
+AuthKindAzure: Azure-Login
+AuthKindPWHash: Interne FRADrive-Kennung
+AuthKindNoLogin: Kein Login möglich

messages/uniworx/categories/user/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -38,8 +38,8 @@ AuthPWHashConfigured: User now logs in using their FRADrive specific account
 UsersCourseSchool: Department
 ActionNoUsersSelected: No users selected
 SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}.
-SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}.
+SynchroniseUserdbUserQueued n: Triggered user database synchronisation of #{n} #{pluralEN n "user" "users"}.
-SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users
+SynchroniseUserdbAllUsersQueued: Triggered user database synchronisation of all users
 UserListTitle: Comprehensive list of users
 AccessRightsSaved: Successfully updated permissions
 AccessRightsNotChanged: Permissions left unchanged
@@ -48,6 +48,7 @@ AuthLDAPInvalidLookup: Existing user could not be uniquely matched with a LDAP e
 AuthLDAPAlreadyConfigured: User already logs in using their Fraport AG account
 AuthLDAPConfigured: User now logs in using their Fraport AG account
 AuthLDAP: Fraport AG account
+AuthAzure: Azure account
 AuthNoLogin: No login allowed.
 PasswordResetQueued: Sent link to reset password
 UserAssimilateUser: User
@@ -95,10 +96,14 @@ UserAddSupervisor: Add supervisor
 UserSetSupervisor: Replace supervisors
 UserRemoveSupervisor: Set to unsupervised
 UserIsSupervisor: Is supervisor
-AuthKindLDAP: Fraport AG account
-AuthKindPWHash: FRADrive account
-AuthKindNoLogin: No login
 Name: Name
 UsersChangeSupervisorsSuccess usr spr: #{pluralENsN spr "supervisor"} for #{pluralENsN usr "user"} set.
 UsersChangeSupervisorsWarning usr spr bad: Only _{MsgUsersChangeSupervisorsSuccess usr spr} #{pluralENsN bad "supervisors"} could not be identified!
 UsersRemoveSupervisors usr: Removed all supervisors for #{pluralENsN usr "user"}.
+
+AdminUserAuthentication: Authentifizierung
+AdminUserAuthLastSync: Last synchronised
+AuthKindLDAP: Fraport AG account (LDAP)
+AuthKindAzure: Azure account
+AuthKindPWHash: Internal FRADrive login
+AuthKindNoLogin: No login

messages/uniworx/utils/navigation/menu/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -142,8 +142,7 @@ MenuSap: SAP Schnittstelle
 
 MenuAvs: AVS Schnittstelle
 MenuAvsSynchError: AVS Problemübersicht
-MenuLdap !ident-ok: LDAP
+MenuExternalUser: Externe Benutzer
-MenuOAuth2 !ident-ok: OAuth2
 MenuApc: Druckerei
 MenuPrintSend: Manueller Briefversand
 MenuPrintDownload: Brief herunterladen

messages/uniworx/utils/navigation/menu/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -142,8 +142,7 @@ MenuSap: SAP Interface
 
 MenuAvs: AVS Interface
 MenuAvsSynchError: AVS Problem Overview
-MenuLdap: LDAP
+MenuExternalUser: External users
-MenuOAuth2: OAuth2
 MenuApc: Printing
 MenuPrintSend: Send Letter
 MenuPrintDownload: Download Letter

messages/uniworx/utils/utils/de-de-formal.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023 Steffen Jost <jost@tcs.ifi.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -159,3 +159,5 @@ SheetTypeNormal !ident-ok: Normal
 SheetTypeBonus !ident-ok: Bonus
 
 InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten
+
+InvalidUuid: Invalide UUID!

messages/uniworx/utils/utils/en-eu.msg

@@ -1,4 +1,4 @@
-# SPDX-FileCopyrightText: 2023 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 #
 # SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -159,3 +159,5 @@ SheetTypeNormal: Normal
 SheetTypeBonus: Bonus
 
 InvalidFormAction: No action taken due to invalid form data
+
+InvalidUuid: Invalid UUID!

models/schools.model

@@ -10,7 +10,7 @@ School json
     examMinimumRegisterBeforeStart NominalDiffTime Maybe
     examMinimumRegisterDuration    NominalDiffTime Maybe
     examRequireModeForRegistration Bool default=false
-    examDiscouragedModes ExamModeDNF default='{"dnf-terms":[]}'  -- This comment fixes syntax highlighting error only " 
+    examDiscouragedModes ExamModeDNF
     examCloseMode ExamCloseMode default='separate' 
     sheetAuthorshipStatementMode SchoolAuthorshipStatementMode default='optional'
     sheetAuthorshipStatementDefinition AuthorshipStatementDefinitionId Maybe

models/users.model

@@ -1,8 +1,8 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
--- The files in /models determine t he database scheme.
+-- The files in /models determine the database scheme.
 -- The organisational split into several files has no operational effects.
 -- White-space and case matters: Each SQL table is named in 1st column of this file
 -- Indendent lower-case lines describe the SQL-columns of the table with name, type and options
@@ -11,17 +11,16 @@
 -- Indendent upper-case lines usually impose Uniqueness constraints for rows by some columns.
 -- Each table will also have an column storing a unique numeric row key, unless there is a row Primary columnname
 --
+
 User json    -- Each Uni2work user has a corresponding row in this table; created upon first login.
+    ident          UserIdent                -- Case-insensitive user-identifier
+    passwordHash   Text Maybe               -- If specified, allows the user to login with credentials independently of external authentication
+    lastAuthentication UTCTime Maybe        -- When did the user last authenticate?
     surname        UserSurname              -- Display user names always through 'nameWidget displayName surname'
     displayName    UserDisplayName
     displayEmail   UserEmail
     email          UserEmail                -- Case-insensitive eMail address, used for sending  TODO: make this nullable
-    ident          UserIdent                -- Case-insensitive user-identifier
-    authentication AuthenticationMode       -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
-    lastAuthentication UTCTime Maybe        -- last login date
     created        UTCTime default=now()
-    lastLdapSynchronisation UTCTime Maybe
-    ldapPrimaryKey UserEduPersonPrincipalName Maybe
     tokensIssuedAfter  UTCTime Maybe        -- do not accept bearer tokens issued before this time (accept all tokens if null)
     matrikelnummer UserMatriculation Maybe  -- usually a number; AVS Personalnummer; nicht Fraport Personalnummer!
     firstName      Text                     -- For export in tables, pre-split firstName from displayName
@@ -50,11 +49,20 @@ User json    -- Each Uni2work user has a corresponding row in this table; create
     prefersPostal         Bool default=false    -- user prefers letters by post instead of email
     examOfficeGetSynced   Bool default=true     -- whether synced status should be displayed for exam results by default
     examOfficeGetLabels   Bool default=true     -- whether labels should be displayed for exam results by default
-    UniqueAuthentication ident                  -- Column 'ident' can be used as a row-key in this table
+    lastSync              UTCTime Maybe         -- When was the User data last synchronised with external sources?
+    UniqueAuthentication  ident                 -- Column 'ident' can be used as a row-key in this table
     UniqueEmail email                           -- Column 'email' can be used as a row-key in this table
-    UniqueLdapPrimaryKey ldapPrimaryKey !force  -- Column 'ldapPrimaryKey' is either empty or contains a unique value
     deriving Show Eq Ord Generic                -- Haskell-specific settings for runtime-value representing a row in memory
 
+-- | User data fetched from external user sources, used for authentication and data queries
+ExternalUser
+    user      UserIdent
+    source    AuthSourceIdent              -- Identifier of the external source in the config
+    data      Value "default='{}'::jsonb"  -- Raw user data from external source -- TODO: maybe make Maybe, iff the source only ever responds with "success"?
+    lastSync  UTCTime                      -- When was the external source last queried?
+    UniqueExternalUser user source         -- At most one entry of this user per source
+    deriving Show Eq Ord Generic
+
 UserFunction -- Administratively assigned functions (lecturer, admin, evaluation, ...)
     user     UserId
     school   SchoolId
@@ -99,4 +107,3 @@ UserSupervisor
     rerouteNotifications  Bool   -- User can be his own supervisor to receive notifications as well
     UniqueUserSupervisor supervisor user -- each supervisor/user combination is unique (same supervisor can superviser the same user only once)
     deriving Generic
-    

nix/docker/version.json

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

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.54",
+  "version": "27.4.56",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {
@@ -2404,12 +2404,6 @@
       "integrity": "sha512-8+9WqebbFzpX9OR+Wa6O29asIogeRMzcGtAINdpMHHyAg10f05aSFVBbcEqGf/PXw1EjAZ+q2/bEBg3DvurK3Q==",
       "dev": true
     },
-    "array-flatten": {
-      "version": "1.1.1",
-      "resolved": "https://registry.npmjs.org/array-flatten/-/array-flatten-1.1.1.tgz",
-      "integrity": "sha512-PCVAQswWemu6UdxsDFFX/+gVeYqKAod3D3UVm91jHwynguOwAvYPhx8nNlM++NqRcK6CxxpUafjmhIdKiHibqg==",
-      "dev": true
-    },
     "array-ify": {
       "version": "1.0.0",
       "resolved": "https://registry.npmjs.org/array-ify/-/array-ify-1.0.0.tgz",
@@ -3525,23 +3519,6 @@
       "integrity": "sha512-lGe34o6EHj9y3Kts9R4ZYs/Gr+6N7MCaMlIFA3F1R2O5/m7K06AxfSeO5530PEERE6/WyEg3lsuyw4GHlPZHog==",
       "dev": true
     },
-    "basic-auth": {
-      "version": "2.0.1",
-      "resolved": "https://registry.npmjs.org/basic-auth/-/basic-auth-2.0.1.tgz",
-      "integrity": "sha512-NF+epuEdnUYVlGuhaxbbq+dvJttwLnGY+YixlXlME5KpQ5W3CnXA5cVTneY3SPbPDRkcjMbifrwmFYcClgOZeg==",
-      "dev": true,
-      "requires": {
-        "safe-buffer": "5.1.2"
-      },
-      "dependencies": {
-        "safe-buffer": {
-          "version": "5.1.2",
-          "resolved": "https://registry.npmjs.org/safe-buffer/-/safe-buffer-5.1.2.tgz",
-          "integrity": "sha512-Gd2UZBJDkXlY7GbJxfsE8/nvKkUEU1G38c1siN6QP6a9PT9MmHB8GnpscSmMJSoF8LOIrt8ud/wPtojys4G6+g==",
-          "dev": true
-        }
-      }
-    },
     "bcrypt-pbkdf": {
       "version": "1.0.2",
       "resolved": "https://registry.npmjs.org/bcrypt-pbkdf/-/bcrypt-pbkdf-1.0.2.tgz",
@@ -4165,15 +4142,6 @@
         }
       }
     },
-    "content-disposition": {
-      "version": "0.5.4",
-      "resolved": "https://registry.npmjs.org/content-disposition/-/content-disposition-0.5.4.tgz",
-      "integrity": "sha512-FveZTNuGw04cxlAiWbzi6zTAL/lhehaWbTtgluJh4/E95DqMwTmha3KZN1aAWA8cFIhHzMZUvLevkw5Rqk+tSQ==",
-      "dev": true,
-      "requires": {
-        "safe-buffer": "5.2.1"
-      }
-    },
     "content-type": {
       "version": "1.0.4",
       "resolved": "https://registry.npmjs.org/content-type/-/content-type-1.0.4.tgz",
@@ -4549,12 +4517,6 @@
       "integrity": "sha512-aSWTXFzaKWkvHO1Ny/s+ePFpvKsPnjc551iI41v3ny/ow6tBG5Vd+FuqGNhh1LxOmVzOlGUriIlOaokOvhaStA==",
       "dev": true
     },
-    "cookie-signature": {
-      "version": "1.0.6",
-      "resolved": "https://registry.npmjs.org/cookie-signature/-/cookie-signature-1.0.6.tgz",
-      "integrity": "sha512-QADzlaHc8icV8I7vbaJXJwod9HWYp8uCqf1xa4OfNu1T7JVxQIrUgOWtHdNDtPiywmFbiS12VjotIXLrKM3orQ==",
-      "dev": true
-    },
     "copy-webpack-plugin": {
       "version": "11.0.0",
       "resolved": "https://registry.npmjs.org/copy-webpack-plugin/-/copy-webpack-plugin-11.0.0.tgz",
@@ -5074,12 +5036,6 @@
       "integrity": "sha1-3zrhmayt+31ECqrgsp4icrJOxhk=",
       "dev": true
     },
-    "depd": {
-      "version": "2.0.0",
-      "resolved": "https://registry.npmjs.org/depd/-/depd-2.0.0.tgz",
-      "integrity": "sha512-g7nH6P6dyDioJogAAGprGpCtVImJhpPk/roCzdb3fIh61/s/nPsfR6onyMwkCAR/OlC3yBC0lESvUoQEAssIrw==",
-      "dev": true
-    },
     "destroy": {
       "version": "1.2.0",
       "resolved": "https://registry.npmjs.org/destroy/-/destroy-1.2.0.tgz",
@@ -5673,12 +5629,6 @@
       "integrity": "sha512-kVscqXk4OCp68SZ0dkgEKVi6/8ij300KBWTJq32P/dYeWTSwK41WyTxalN1eRmA5Z9UU/LX9D7FWSmV9SAYx6g==",
       "dev": true
     },
-    "etag": {
-      "version": "1.8.1",
-      "resolved": "https://registry.npmjs.org/etag/-/etag-1.8.1.tgz",
-      "integrity": "sha512-aIL5Fx7mawVa300al2BnEE4iNvo1qETxLrPI/o05L7z6go7fCw1J6EQmbK4FmJ2AS7kgVF/KEZWufBfdClMcPg==",
-      "dev": true
-    },
     "eventemitter3": {
       "version": "4.0.7",
       "resolved": "https://registry.npmjs.org/eventemitter3/-/eventemitter3-4.0.7.tgz",
@@ -5716,112 +5666,6 @@
         }
       }
     },
-    "express": {
-      "version": "4.18.2",
-      "resolved": "https://registry.npmjs.org/express/-/express-4.18.2.tgz",
-      "integrity": "sha512-5/PsL6iGPdfQ/lKM1UuielYgv3BUoJfz1aUwU9vHZ+J7gyvwdQXFEBIEIaxeGf0GIcreATNyBExtalisDbuMqQ==",
-      "dev": true,
-      "requires": {
-        "accepts": "~1.3.8",
-        "array-flatten": "1.1.1",
-        "body-parser": "1.20.1",
-        "content-disposition": "0.5.4",
-        "content-type": "~1.0.4",
-        "cookie": "0.5.0",
-        "cookie-signature": "1.0.6",
-        "debug": "2.6.9",
-        "depd": "2.0.0",
-        "encodeurl": "~1.0.2",
-        "escape-html": "~1.0.3",
-        "etag": "~1.8.1",
-        "finalhandler": "1.2.0",
-        "fresh": "0.5.2",
-        "http-errors": "2.0.0",
-        "merge-descriptors": "1.0.1",
-        "methods": "~1.1.2",
-        "on-finished": "2.4.1",
-        "parseurl": "~1.3.3",
-        "path-to-regexp": "0.1.7",
-        "proxy-addr": "~2.0.7",
-        "qs": "6.11.0",
-        "range-parser": "~1.2.1",
-        "safe-buffer": "5.2.1",
-        "send": "0.18.0",
-        "serve-static": "1.15.0",
-        "setprototypeof": "1.2.0",
-        "statuses": "2.0.1",
-        "type-is": "~1.6.18",
-        "utils-merge": "1.0.1",
-        "vary": "~1.1.2"
-      },
-      "dependencies": {
-        "body-parser": {
-          "version": "1.20.1",
-          "resolved": "https://registry.npmjs.org/body-parser/-/body-parser-1.20.1.tgz",
-          "integrity": "sha512-jWi7abTbYwajOytWCQc37VulmWiRae5RyTpaCyDcS5/lMdtwSz5lOpDE67srw/HYe35f1z3fDQw+3txg7gNtWw==",
-          "dev": true,
-          "requires": {
-            "bytes": "3.1.2",
-            "content-type": "~1.0.4",
-            "debug": "2.6.9",
-            "depd": "2.0.0",
-            "destroy": "1.2.0",
-            "http-errors": "2.0.0",
-            "iconv-lite": "0.4.24",
-            "on-finished": "2.4.1",
-            "qs": "6.11.0",
-            "raw-body": "2.5.1",
-            "type-is": "~1.6.18",
-            "unpipe": "1.0.0"
-          }
-        },
-        "cookie": {
-          "version": "0.5.0",
-          "resolved": "https://registry.npmjs.org/cookie/-/cookie-0.5.0.tgz",
-          "integrity": "sha512-YZ3GUyn/o8gfKJlnlX7g7xq4gyO6OSuhGPKaaGssGB2qgDUS0gPgtTvoyZLTt9Ab6dC4hfc9dV5arkvc/OCmrw==",
-          "dev": true
-        },
-        "debug": {
-          "version": "2.6.9",
-          "resolved": "https://registry.npmjs.org/debug/-/debug-2.6.9.tgz",
-          "integrity": "sha512-bC7ElrdJaJnPbAP+1EotYvqZsb3ecl5wi6Bfi6BJTUcNowp6cvspg0jXznRTKDjm/E7AdgFBVeAPVMNcKGsHMA==",
-          "dev": true,
-          "requires": {
-            "ms": "2.0.0"
-          }
-        },
-        "finalhandler": {
-          "version": "1.2.0",
-          "resolved": "https://registry.npmjs.org/finalhandler/-/finalhandler-1.2.0.tgz",
-          "integrity": "sha512-5uXcUVftlQMFnWC9qu/svkWv3GTd2PfUhK/3PLkYNAe7FbqJMt3515HaxE6eRL74GdsriiwujiawdaB1BpEISg==",
-          "dev": true,
-          "requires": {
-            "debug": "2.6.9",
-            "encodeurl": "~1.0.2",
-            "escape-html": "~1.0.3",
-            "on-finished": "2.4.1",
-            "parseurl": "~1.3.3",
-            "statuses": "2.0.1",
-            "unpipe": "~1.0.0"
-          }
-        },
-        "ms": {
-          "version": "2.0.0",
-          "resolved": "https://registry.npmjs.org/ms/-/ms-2.0.0.tgz",
-          "integrity": "sha512-Tpp60P6IUJDTuOq/5Z8cdskzJujfwqfOTkrwIwj7IRISpnkJnT6SyJ4PCPnGMoFjC9ddhal5KVIYtAt97ix05A==",
-          "dev": true
-        },
-        "qs": {
-          "version": "6.11.0",
-          "resolved": "https://registry.npmjs.org/qs/-/qs-6.11.0.tgz",
-          "integrity": "sha512-MvjoMCJwEarSbUYk5O+nmoSzSutSsTwF85zcHPQ9OrlFoZOYIjaqBAJIqIXjptyD5vThxGq52Xu/MaJzRkIk4Q==",
-          "dev": true,
-          "requires": {
-            "side-channel": "^1.0.4"
-          }
-        }
-      }
-    },
     "extend": {
       "version": "3.0.2",
       "resolved": "https://registry.npmjs.org/extend/-/extend-3.0.2.tgz",
@@ -6037,24 +5881,12 @@
         "mime-types": "^2.1.12"
       }
     },
-    "forwarded": {
-      "version": "0.2.0",
-      "resolved": "https://registry.npmjs.org/forwarded/-/forwarded-0.2.0.tgz",
-      "integrity": "sha512-buRG0fpBtRHSTCOASe6hD258tEubFoRLb4ZNA6NxMVHNw2gOcwHo9wyablzMzOA5z9xA9L1KNjk/Nt6MT9aYow==",
-      "dev": true
-    },
     "fraction.js": {
       "version": "4.2.0",
       "resolved": "https://registry.npmjs.org/fraction.js/-/fraction.js-4.2.0.tgz",
       "integrity": "sha512-MhLuK+2gUcnZe8ZHlaaINnQLl0xRIGRfcGk2yl8xoQAfHrSsL3rYu6FCmBdkdbhc9EPlwyGHewaRsvwRMJtAlA==",
       "dev": true
     },
-    "fresh": {
-      "version": "0.5.2",
-      "resolved": "https://registry.npmjs.org/fresh/-/fresh-0.5.2.tgz",
-      "integrity": "sha512-zJ2mQYM18rEFOudeV4GShTGIQ7RbzA7ozbU9I/XBpm7kqgMywgmylMwXHxZJmkVoYkna9d2pVXVXPdYTP9ej8Q==",
-      "dev": true
-    },
     "fs-extra": {
       "version": "10.1.0",
       "resolved": "https://registry.npmjs.org/fs-extra/-/fs-extra-10.1.0.tgz",
@@ -6609,15 +6441,6 @@
       "integrity": "sha512-xs7/chUH/CKdOCs7Zy0Aev9e/dKOMZf3K1Az1nar3tzlv0jfqnYtu235bstsWTmXOR0EfINrPa97yy4Lz6RiKw==",
       "dev": true
     },
-    "iconv-lite": {
-      "version": "0.4.24",
-      "resolved": "https://registry.npmjs.org/iconv-lite/-/iconv-lite-0.4.24.tgz",
-      "integrity": "sha512-v3MXnZAcvnywkTUEZomIActle7RXXeedOR31wwl7VlyoXO4Qi9arvSenNQWne1TcRwhCL1HwLI21bEqdpj8/rA==",
-      "dev": true,
-      "requires": {
-        "safer-buffer": ">= 2.1.2 < 3"
-      }
-    },
     "icss-utils": {
       "version": "5.1.0",
       "resolved": "https://registry.npmjs.org/icss-utils/-/icss-utils-5.1.0.tgz",
@@ -6718,12 +6541,6 @@
         "loose-envify": "^1.0.0"
       }
     },
-    "ipaddr.js": {
-      "version": "1.9.1",
-      "resolved": "https://registry.npmjs.org/ipaddr.js/-/ipaddr.js-1.9.1.tgz",
-      "integrity": "sha512-0KI/607xoxSToH7GjN1FfSbLoU0+btTicjsQSWQlh/hZykN8KpmMf7uYwPW3R+akZ6R/w18ZlXSHBYXiYUPO3g==",
-      "dev": true
-    },
     "is-arrayish": {
       "version": "0.2.1",
       "resolved": "https://registry.npmjs.org/is-arrayish/-/is-arrayish-0.2.1.tgz",
@@ -7008,12 +6825,6 @@
         }
       }
     },
-    "jose": {
-      "version": "4.15.4",
-      "resolved": "https://registry.npmjs.org/jose/-/jose-4.15.4.tgz",
-      "integrity": "sha512-W+oqK4H+r5sITxfxpSU+MMdr/YSWGvgZMQDIsNoBDGGy4i7GBPTtvFKibQzW06n3U3TqHjhvBJsirShsEJ6eeQ==",
-      "dev": true
-    },
     "js-cookie": {
       "version": "3.0.1",
       "resolved": "https://registry.npmjs.org/js-cookie/-/js-cookie-3.0.1.tgz",
@@ -8011,12 +7822,6 @@
         }
       }
     },
-    "merge-descriptors": {
-      "version": "1.0.1",
-      "resolved": "https://registry.npmjs.org/merge-descriptors/-/merge-descriptors-1.0.1.tgz",
-      "integrity": "sha512-cCi6g3/Zr1iqQi6ySbseM1Xvooa98N0w31jzUYrXPX2xqObmFGHJ0tQ5u74H3mVh7wLouTseZyYIq39g8cNp1w==",
-      "dev": true
-    },
     "merge-stream": {
       "version": "2.0.0",
       "resolved": "https://registry.npmjs.org/merge-stream/-/merge-stream-2.0.0.tgz",
@@ -8041,12 +7846,6 @@
         "underscore": "*"
       }
     },
-    "methods": {
-      "version": "1.1.2",
-      "resolved": "https://registry.npmjs.org/methods/-/methods-1.1.2.tgz",
-      "integrity": "sha512-iclAHeNqNm68zFtnZ0e+1L2yUIdvzNoauKU4WBA3VvH/vPFieF7qfRlwUZU+DA9P9bPXIS90ulxoUoCH23sV2w==",
-      "dev": true
-    },
     "micromatch": {
       "version": "4.0.5",
       "resolved": "https://registry.npmjs.org/micromatch/-/micromatch-4.0.5.tgz",
@@ -10055,27 +9854,6 @@
         }
       }
     },
-    "oauth2-mock-server": {
-      "version": "7.1.1",
-      "resolved": "https://registry.npmjs.org/oauth2-mock-server/-/oauth2-mock-server-7.1.1.tgz",
-      "integrity": "sha512-4/PdPZLySsC68IoiO79BKpr5Rv2j2+WgFZskox7bzSlsXqoX8Nm9OWm3IXB0HQ7xJCbzcR4vvvcDe6UnA/UIiw==",
-      "dev": true,
-      "requires": {
-        "basic-auth": "^2.0.1",
-        "cors": "^2.8.5",
-        "express": "^4.18.2",
-        "is-plain-object": "^5.0.0",
-        "jose": "^4.15.4"
-      },
-      "dependencies": {
-        "is-plain-object": {
-          "version": "5.0.0",
-          "resolved": "https://registry.npmjs.org/is-plain-object/-/is-plain-object-5.0.0.tgz",
-          "integrity": "sha512-VRSzKkbMm5jMDoKLbltAkFQ5Qr7VDiTFGXxYFXXowVj387GeGNOCsOH6Msy00SGZ3Fp84b1Naa1psqgcCIEP5Q==",
-          "dev": true
-        }
-      }
-    },
     "object-assign": {
       "version": "4.1.1",
       "resolved": "https://registry.npmjs.org/object-assign/-/object-assign-4.1.1.tgz",
@@ -10286,12 +10064,6 @@
       "integrity": "sha512-LDJzPVEEEPR+y48z93A0Ed0yXb8pAByGWo/k5YYdYgpY2/2EsOsksJrq7lOHxryrVOn1ejG6oAp8ahvOIQD8sw==",
       "dev": true
     },
-    "path-to-regexp": {
-      "version": "0.1.7",
-      "resolved": "https://registry.npmjs.org/path-to-regexp/-/path-to-regexp-0.1.7.tgz",
-      "integrity": "sha512-5DFkuoqlv1uYQKxy8omFBeJPQcdoE07Kv2sferDCrAq1ohOU+MSDswDIbnx3YAM60qIOnYa53wBhXW0EbMonrQ==",
-      "dev": true
-    },
     "path-type": {
       "version": "4.0.0",
       "resolved": "https://registry.npmjs.org/path-type/-/path-type-4.0.0.tgz",
@@ -11046,16 +10818,6 @@
       "integrity": "sha512-3ouUOpQhtgrbOa17J7+uxOTpITYWaGP7/AhoR3+A+/1e9skrzelGi/dXzEYyvbxubEF6Wn2ypscTKiKJFFn1ag==",
       "dev": true
     },
-    "proxy-addr": {
-      "version": "2.0.7",
-      "resolved": "https://registry.npmjs.org/proxy-addr/-/proxy-addr-2.0.7.tgz",
-      "integrity": "sha512-llQsMLSUDUPT44jdrU/O37qlnifitDP+ZwrmmZcoSKyLKvtZxpyV0n2/bD/N4tBAAZ/gJEdZU7KMraoK1+XYAg==",
-      "dev": true,
-      "requires": {
-        "forwarded": "0.2.0",
-        "ipaddr.js": "1.9.1"
-      }
-    },
     "psl": {
       "version": "1.8.0",
       "resolved": "https://registry.npmjs.org/psl/-/psl-1.8.0.tgz",
@@ -11795,58 +11557,6 @@
         }
       }
     },
-    "send": {
-      "version": "0.18.0",
-      "resolved": "https://registry.npmjs.org/send/-/send-0.18.0.tgz",
-      "integrity": "sha512-qqWzuOjSFOuqPjFe4NOsMLafToQQwBSOEpS+FwEt3A2V3vKubTquT3vmLTQpFgMXp8AlFWFuP1qKaJZOtPpVXg==",
-      "dev": true,
-      "requires": {
-        "debug": "2.6.9",
-        "depd": "2.0.0",
-        "destroy": "1.2.0",
-        "encodeurl": "~1.0.2",
-        "escape-html": "~1.0.3",
-        "etag": "~1.8.1",
-        "fresh": "0.5.2",
-        "http-errors": "2.0.0",
-        "mime": "1.6.0",
-        "ms": "2.1.3",
-        "on-finished": "2.4.1",
-        "range-parser": "~1.2.1",
-        "statuses": "2.0.1"
-      },
-      "dependencies": {
-        "debug": {
-          "version": "2.6.9",
-          "resolved": "https://registry.npmjs.org/debug/-/debug-2.6.9.tgz",
-          "integrity": "sha512-bC7ElrdJaJnPbAP+1EotYvqZsb3ecl5wi6Bfi6BJTUcNowp6cvspg0jXznRTKDjm/E7AdgFBVeAPVMNcKGsHMA==",
-          "dev": true,
-          "requires": {
-            "ms": "2.0.0"
-          },
-          "dependencies": {
-            "ms": {
-              "version": "2.0.0",
-              "resolved": "https://registry.npmjs.org/ms/-/ms-2.0.0.tgz",
-              "integrity": "sha512-Tpp60P6IUJDTuOq/5Z8cdskzJujfwqfOTkrwIwj7IRISpnkJnT6SyJ4PCPnGMoFjC9ddhal5KVIYtAt97ix05A==",
-              "dev": true
-            }
-          }
-        },
-        "mime": {
-          "version": "1.6.0",
-          "resolved": "https://registry.npmjs.org/mime/-/mime-1.6.0.tgz",
-          "integrity": "sha512-x0Vn8spI+wuJ1O6S7gnbaQg8Pxh4NNHb7KSINmEWKiPE4RKOplvijn+NkmYmmRgP68mc70j2EbeTFRsrswaQeg==",
-          "dev": true
-        },
-        "ms": {
-          "version": "2.1.3",
-          "resolved": "https://registry.npmjs.org/ms/-/ms-2.1.3.tgz",
-          "integrity": "sha512-6FlzubTLZG3J2a/NVCAleEhjzq5oxgHyaCU9yYXvcLsvoVaHJq/s5xXI6/XXP6tz7R9xAOtHnSO/tXtF3WRTlA==",
-          "dev": true
-        }
-      }
-    },
     "serialize-javascript": {
       "version": "6.0.0",
       "resolved": "https://registry.npmjs.org/serialize-javascript/-/serialize-javascript-6.0.0.tgz",
@@ -11856,18 +11566,6 @@
         "randombytes": "^2.1.0"
       }
     },
-    "serve-static": {
-      "version": "1.15.0",
-      "resolved": "https://registry.npmjs.org/serve-static/-/serve-static-1.15.0.tgz",
-      "integrity": "sha512-XGuRDNjXUijsUL0vl6nSD7cwURuzEgglbOaFuZM9g3kwDXOWVTck0jLzjPzGD+TazWbboZYu52/9/XPdUgne9g==",
-      "dev": true,
-      "requires": {
-        "encodeurl": "~1.0.2",
-        "escape-html": "~1.0.3",
-        "parseurl": "~1.3.3",
-        "send": "0.18.0"
-      }
-    },
     "setimmediate": {
       "version": "1.0.5",
       "resolved": "https://registry.npmjs.org/setimmediate/-/setimmediate-1.0.5.tgz",

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "27.4.54",
+  "version": "27.4.56",
   "description": "",
   "keywords": [],
   "author": "",
@@ -86,7 +86,6 @@
     "mini-css-extract-plugin": "^2.6.0",
     "npm-run-all": "^4.1.5",
     "null-loader": "^4.0.1",
-    "oauth2-mock-server": "^7.1.1",
     "optimize-css-assets-webpack-plugin": "^6.0.1",
     "postcss-loader": "^7.0.0",
     "postcss-preset-env": "^7.7.1",

package.yaml

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

routes

@@ -30,8 +30,8 @@
 --    !capacity       -- course this route is associated with has at least one unit of participant capacity
 --    !empty          -- course this route is associated with has no participants whatsoever
 --
---    !is-ldap        -- user has authentication mode set to LDAP
+--    !is-external    -- user can login using external sources
---    !is-pw-hash     -- user has authentication mode set to PWHash
+--    !is-internal    -- user can login using internal credentials
 --
 --    !materials      -- only if course allows all materials to be free (no meaning outside of courses)
 --    !time           -- access depends on time somehow
@@ -62,24 +62,23 @@
 /users/#CryptoUUIDUser/password       UserPasswordR               GET POST   !selfANDis-pw-hash
 !/users/functionary-invite/new        AdminNewFunctionaryInviteR  GET POST
 !/users/functionary-invite            AdminFunctionaryInviteR     GET POST
-!/users/add                   AdminUserAddR    GET POST
+!/users/add                   AdminUserAddR      GET POST
-/admin                        AdminR           GET
+/admin                        AdminR             GET
-/admin/test                   AdminTestR       GET POST
+/admin/test                   AdminTestR         GET POST
-/admin/test/pdf               AdminTestPdfR    GET
+/admin/test/pdf               AdminTestPdfR      GET
-/admin/errMsg                 AdminErrMsgR     GET POST
+/admin/errMsg                 AdminErrMsgR       GET POST
-/admin/tokens                 AdminTokensR     GET POST
+/admin/tokens                 AdminTokensR       GET POST
-/admin/crontab                AdminCrontabR    GET
+/admin/crontab                AdminCrontabR      GET
-/admin/crontab/jobs           AdminJobsR       GET POST
+/admin/crontab/jobs           AdminJobsR         GET POST
-/admin/avs                    AdminAvsR        GET POST
+/admin/avs                    AdminAvsR          GET POST
-/admin/avs/#CryptoUUIDUser    AdminAvsUserR    GET
+/admin/avs/#CryptoUUIDUser    AdminAvsUserR      GET
-/admin/ldap                   AdminLdapR       GET POST
+/admin/external-user          AdminExternalUserR GET POST
-/admin/oauth2                 AdminOAuth2R     GET POST
+/admin/problems               AdminProblemsR     GET
-/admin/problems               AdminProblemsR			 GET
 /admin/problems/no-contact    ProblemUnreachableR  GET
 /admin/problems/no-avs-id     ProblemWithoutAvsId  GET
 /admin/problems/r-without-f   ProblemFbutNoR       GET
-/admin/problems/avs  					ProblemAvsSynchR 		 GET POST
+/admin/problems/avs           ProblemAvsSynchR     GET POST
-/admin/problems/avs/errors		ProblemAvsErrorR 		 GET
+/admin/problems/avs/errors    ProblemAvsErrorR 	   GET
 
 /print                                PrintCenterR    GET POST  !system-printer
 /print/acknowledge/#Day/#Int/#Int     PrintAckR       GET POST  !system-printer

src/Application.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -60,7 +60,6 @@ import System.Directory
 import Jobs
 
 import qualified Data.Text.Encoding as Text
-import qualified Data.Text as Text
 
 import Yesod.Auth.OAuth2.AzureADv2 (oauth2AzureADv2Scoped)
 import Yesod.Auth.Util.PasswordStore
@@ -299,13 +298,32 @@ makeFoundation appSettings''@AppSettings{..} = do
           sqlPool = Custom.hoistPool (liftIO . flip runLoggingT logFunc) sqlPool'
       void . Prometheus.register . poolMetrics PoolDatabaseConnections $ sqlPool @IO
 
-      ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appLdapConf $ \conf@LdapConf{..} -> do
+      -- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appUserDbConf $ \conf -> if
-        let ldapLabel = case ldapHost of
+      --   | UserDbSingleSource{..} <- conf
-              Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
+      --   , UserDbLdap LdapConf{..} <- userdbSingleSource
-              Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
+      --   , Just ResourcePoolConf{..} <- userdbPoolConf
-        $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
+      --     -> do
-        (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort (poolStripes ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool)
+      --          let ldapLabel = case ldapHost of
-      forM_ ldapPool $ registerFailoverMetrics "ldap"
+      --                Ldap.Plain str -> pack str <> ":" <> tshow ldapPort
+      --                Ldap.Tls str _ -> pack str <> ":" <> tshow ldapPort
+      --          $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
+      --          (ldapLabel,) . (conf,) <$> createLdapPool ldapHost ldapPort poolStripes poolTimeout ldapTimeout poolLimit
+      --   | otherwise
+      --     -> return mempty
+      -- forM_ ldapPool $ registerFailoverMetrics "ldap"
+
+      -- TODO: reintroduce failover once UserDbFailover is implemented (see above)
+      ldapPool <- fmap join . forM appLdapPoolConf $ \ResourcePoolConf{..} -> if
+        | UserAuthConfSingleSource{..} <- appUserAuthConf
+        , AuthSourceConfLdap conf@LdapConf{..} <- userAuthConfSingleSource
+          -> do -- set up a singleton ldap pool with no failover
+               let ldapLabel = case ldapConfHost of
+                     Ldap.Plain str -> pack str <> ":" <> tshow ldapConfPort
+                     Ldap.Tls str _ -> pack str <> ":" <> tshow ldapConfPort
+               $logDebugS "setup" $ "LDAP-Pool " <> ldapLabel
+               Just . (conf,) <$> createLdapPool ldapConfHost ldapConfPort poolStripes poolTimeout ldapConfTimeout poolLimit
+        | otherwise -- No LDAP pool to be initialized
+          -> return Nothing
 
       -- Perform database migration using our application's logging settings.
       flip runReaderT tempFoundation $
@@ -326,21 +344,33 @@ makeFoundation appSettings''@AppSettings{..} = do
       appAuthKey <- clusterSetting (Proxy :: Proxy 'ClusterAuthKey) `customRunSqlPool` sqlPool
       appPersonalisedSheetFilesSeedKey <- clusterSetting (Proxy :: Proxy 'ClusterPersonalisedSheetFilesSeedKey) `customRunSqlPool` sqlPool
 
-
+      -- TODO: either migrate these to Foundation.Instances, or migrate additions in Foundation.Instances here
-      mAzureTenantID <- liftIO $ (fmap Text.pack) <$> (return $ Just "123") -- lookupEnv "AZURE_ADV2_TENANT_ID"
+      -- TODO: use scopes from Settings
+#ifdef DEVELOPMENT
+      oauth2Plugins <- liftIO $ sequence
+        [ (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
+        , return $ oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] "42" "42" "shhh"
+        ]
+#else
       let -- Auth Plugins
-        tenantID = fromMaybe (error "Tenant ID mising") mAzureTenantID
         loadPlugin p prefix = do -- Loads given YesodAuthPlugin
-          mID <- (fmap Text.pack) <$> (return $ Just "UWX") -- (lookupEnv $ prefix ++ "_CLIENT_ID")
+          mID <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzure . _azureConfClientId
-          mSecret <- (fmap Text.pack) <$> (return $ Just prefix) -- (lookupEnv $ prefix ++ "_CLIENT_SECRET")
+          mSecret <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzure . _azureConfClientSecret
           let mArgs = (,) <$> mID <*> mSecret
           guard $ isJust mArgs
           return . uncurry p $ fromJust mArgs
-
+        tenantID = case appUserAuthConf of
-      appAuthPlugins <- liftIO $ sequence [
+          UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..})
-          (oauth2MockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT"
+            -> Text.pack azureConfTenantId
-        , loadPlugin (oauth2AzureADv2Scoped ["openid", "profile", "offline_access"] tenantID) "AZURE_ADV2"
+          _other
-        ]
+            -> error "Tenant ID missing!"
+        oauth2Plugins
+          | UserAuthConfSingleSource (AuthSourceConfAzure AzureConf{..}) appUserAuthConf
+            -> singleton $ oauth2AzureADv2Scoped (Set.toList azureConfScopes) azureConfTenantId azureConfClientId azureConfClientSecret
+          | otherwise
+            -> mempty
+#endif
+      let appAuthPlugins = oauth2Plugins
 
 
       let appVolatileClusterSettingsCacheTime' = Clock.fromNanoSecs ns
@@ -402,6 +432,7 @@ makeFoundation appSettings''@AppSettings{..} = do
 
       $logDebugS "Runtime configuration" $ tshowCrop appSettings'
 
+      -- TODO: reimplement user db failover
       let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery
 
       -- Return the foundation
@@ -641,6 +672,8 @@ appMain = runResourceT $ do
     foundation <- makeFoundation settings
 
     runAppLoggingT foundation $ do
+      $logErrorS "AppSettings" $ tshow settings
+
       $logInfoS "setup" "Job-Handling"
       handleJobs foundation
 
@@ -757,7 +790,7 @@ shutdownApp app = do
   liftIO $ do
     Custom.purgePool $ appConnPool app
     for_ (appSmtpPool app) destroyAllResources
-    for_ (appLdapPool app) . mapFailover $ views _2 destroyAllResources
+    for_ (appLdapPool app) $ views _2 destroyAllResources
     for_ (appWidgetMemcached app) Memcached.close
     for_ (appMemcached app) $ views _memcachedConn Memcached.close
   release . fst $ appLogger app
@@ -782,7 +815,7 @@ db' = handler' . runDB
 addPWEntry :: User
            -> Text {-^ Password -}
            -> IO ()
-addPWEntry User{ userAuthentication = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
+addPWEntry User{ userPasswordHash = _, ..} (Text.encodeUtf8 -> pw) = db' $ do
   PWHashConf{..} <- getsYesod $ view _appAuthPWHash
-  (AuthPWHash . Text.decodeUtf8 -> userAuthentication) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
+  (Just . Text.decodeUtf8 -> userPasswordHash) <- liftIO $ makePasswordWith pwHashAlgorithm pw pwHashStrength
   void $ insert User{..}

src/Auth/LDAP.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -7,11 +7,11 @@
 module Auth.LDAP
   ( apLdap
   , ADError(..), ADInvalidCredentials(..)
-  , campusLogin
+  , ldapLogin
-  , CampusUserException(..)
+  , LdapUserException(..)
-  , campusUser, campusUser', campusUser''
+  , ldapUser, ldapUser', ldapUser''
-  , campusUserReTest, campusUserReTest'
+--, ldapUserReTest, ldapUserReTest'
-  , campusUserMatr, campusUserMatr'
+  , ldapUserMatr, ldapUserMatr'
   , CampusMessage(..)
   , ldapPrimaryKey
   , ldapUserPrincipalName, ldapUserEmail, ldapUserDisplayName
@@ -20,32 +20,36 @@ module Auth.LDAP
   , ldapUserMobile, ldapUserTelephone
   , ldapUserFraportPersonalnummer, ldapUserFraportAbteilung
   , ldapUserTitle
+  , ldapSearch
   ) where
 
 import Import.NoFoundation
 
-import qualified Data.CaseInsensitive as CI
+import Auth.LDAP.AD
-
-import Utils.Metrics
-import Utils.Form
 
 import qualified Ldap.Client as Ldap
 
+import Utils.Form
+import Utils.Metrics
+
+import qualified Data.CaseInsensitive as CI
 import qualified Data.Text.Encoding as Text
 
 import qualified Yesod.Auth.Message as Msg
 
-import Auth.LDAP.AD
 
--- allow Ldap.Attr usage as key for Data.Map
+-- | Plugin name of the LDAP yesod auth plugin
-deriving newtype instance Ord Ldap.Attr
+apLdap :: Text
+apLdap = "LDAP"
 
 
+-- TODO: rename
 data CampusLogin = CampusLogin
   { campusIdent :: CI Text
   , campusPassword :: Text
   } deriving (Generic)
 
+-- TODO: rename
 data CampusMessage = MsgCampusIdentPlaceholder
                    | MsgCampusIdent
                    | MsgCampusPassword
@@ -53,8 +57,12 @@ data CampusMessage = MsgCampusIdentPlaceholder
   deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
 
 
-findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
+findUser :: LdapConf 
-findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
+         -> Ldap
+         -> Text -- ^ needle
+         -> [Ldap.Attr]
+         -> IO [Ldap.SearchEntry]
+findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
   where
     userFilters =
       [ ldapUserPrincipalName Ldap.:= Text.encodeUtf8 ident
@@ -69,21 +77,37 @@ findUser conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM
       [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 ident
       ]
 
-findUserMatr :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
+findUserMatr :: LdapConf
-findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters
+             -> Ldap
+             -> Text -- ^ matriculation needle
+             -> [Ldap.Attr]
+             -> IO [Ldap.SearchEntry]
+findUserMatr conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapConfBase $ userSearchSettings conf) retAttrs) userFilters
   where
     userFilters =
       [ ldapUserFraportPersonalnummer Ldap.:= Text.encodeUtf8 userMatr
       ]
 
-userSearchSettings :: LdapConf -> Ldap.Mod Ldap.Search
+userSearchSettings :: LdapConf
+                   -> Ldap.Mod Ldap.Search
 userSearchSettings LdapConf{..} = mconcat
-  [ Ldap.scope ldapScope
+  [ Ldap.scope ldapConfScope
   , Ldap.size 2
-  , Ldap.time ldapSearchTimeout
+  , Ldap.time ldapConfSearchTimeout
   , Ldap.derefAliases Ldap.DerefAlways
   ]
 
+ldapSearch :: forall m.
+              ( MonadUnliftIO m
+              , MonadCatch m
+              )
+           => (LdapConf, LdapPool)
+           -> Text -- ^ needle
+           -> m [Ldap.SearchEntry]
+ldapSearch (conf@LdapConf{..}, ldapPool) needle = either (throwM . LdapUserLdapError) return <=< withLdap ldapPool $ \ldap -> liftIO $ do
+  Ldap.bind ldap ldapConfDn ldapConfPassword
+  findUser conf ldap needle []
+
 ldapPrimaryKey, ldapUserPrincipalName, ldapUserDisplayName, ldapUserFirstName, ldapUserSurname, ldapAffiliation, ldapUserTitle, ldapUserTelephone,  ldapUserMobile, ldapUserFraportPersonalnummer, ldapUserFraportAbteilung  :: Ldap.Attr
 ldapPrimaryKey            = Ldap.Attr "cn" -- should always be identical to "sAMAccountName"
 ldapUserPrincipalName     = Ldap.Attr "userPrincipalName"
@@ -104,30 +128,35 @@ ldapUserEmail = Ldap.Attr "mail" :|
   ]
 
 
-data CampusUserException = CampusUserLdapError LdapPoolError
+-- TODO: deprecate in favour of FetchUserDataException
-                         | CampusUserNoResult
+data LdapUserException = LdapUserLdapError LdapPoolError
-                         | CampusUserAmbiguous
+                       | LdapUserNoResult
+                       | LdapUserAmbiguous
   deriving (Show, Eq, Generic)
 
-instance Exception CampusUserException
+instance Exception LdapUserException
 
-makePrisms ''CampusUserException
+makePrisms ''LdapUserException
 
-campusUserWith :: ( MonadUnliftIO m
+
-                  , MonadCatch m
+ldapUserWith :: ( MonadUnliftIO m
-                  )
+                , MonadCatch m
-               => (    Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
+              --, MonadLogger m
-                    -> Failover (LdapConf, LdapPool)
+                )
-                    -> FailoverMode
+                -- (    Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap
-                    -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
+                --     -> (LdapConf, LdapPool)
-                    -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
+                --     -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList [])))
-                  )
+                --     -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList [])))
-               -> Failover (LdapConf, LdapPool)
+                -- )
-               -> FailoverMode
+             => (    LdapPool
-               -> Creds site
+                  -> (Ldap -> m (Either LdapUserException (Ldap.AttrList [])))
-               -> m (Either CampusUserException (Ldap.AttrList []))
+                  -> m (Either LdapPoolError (Either LdapUserException (Ldap.AttrList [])))
-campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapError) return <=< withLdap' _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO . runExceptT $ do
+                )
-  lift $ Ldap.bind ldap ldapDn ldapPassword
+             -> (LdapConf, LdapPool)
+             -> Creds site
+             -> m (Either LdapUserException (Ldap.AttrList []))
+ldapUserWith withLdap' (conf@LdapConf{..}, pool) Creds{..} = either (throwM . LdapUserLdapError) return <=< withLdap' pool $ \ldap -> liftIO . runExceptT $ do
+  lift $ Ldap.bind ldap ldapConfDn ldapConfPassword
   results <- case lookup "DN" credsExtra of
     Just userDN -> do
       let userFilter = Ldap.Present ldapUserPrincipalName
@@ -135,43 +164,91 @@ campusUserWith withLdap' pool mode Creds{..} = either (throwM . CampusUserLdapEr
     Nothing -> do
       lift $ findUser conf ldap credsIdent []
   case results of
-    [] -> throwE CampusUserNoResult
+    [] -> throwE LdapUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwE CampusUserAmbiguous
+    _otherwise -> throwE LdapUserAmbiguous
-
-campusUserReTest  :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
-campusUserReTest pool doTest mode creds = throwLeft =<< campusUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
-
-campusUserReTest' :: (MonadMask m, MonadLogger m, MonadUnliftIO m) => Failover (LdapConf, LdapPool) -> (Nano -> Bool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
-campusUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUserReTest pool doTest mode (Creds apLdap upsertIdent [])
-  where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey 
 
 
-campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList [])
+-- TODO: reintroduce once failover has been reimplemented
-campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds
+-- ldapUserReTest  :: ( MonadUnliftIO m
+--                    , MonadMask m
+--                    , MonadLogger m
+--                    )
+--                 => Failover (LdapConf, LdapPool)
+--                 -> (Nano -> Bool)
+--                 -> FailoverMode
+--                 -> Creds site
+--                 -> m (Ldap.AttrList [])
+-- ldapUserReTest pool doTest mode creds = throwLeft =<< ldapUserWith (\l -> flip (withLdapFailoverReTest l) doTest) pool mode creds
+-- 
+-- ldapUserReTest' :: ( MonadMask m
+--                    , MonadLogger m
+--                    , MonadUnliftIO m
+--                    )
+--                 => Failover (LdapConf, LdapPool)
+--                 -> (Nano -> Bool)
+--                 -> FailoverMode
+--                 -> User
+--                 -> m (Maybe (Ldap.AttrList []))
+-- ldapUserReTest' pool doTest mode User{userIdent,userLdapPrimaryKey}
+--   = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ ldapUserReTest pool doTest mode (Creds apLdap upsertIdent [])
+--   where upsertIdent = fromMaybe (CI.original userIdent) userLdapPrimaryKey 
 
-campusUser' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> User -> m (Maybe (Ldap.AttrList []))
-campusUser' pool mode User{userIdent}
-  = campusUser'' pool mode $ CI.original userIdent
 
-campusUser'' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Text -> m (Maybe (Ldap.AttrList []))
+-- TODO: deprecate in favour of fetchUserData
-campusUser'' pool mode ident
+ldapUser :: ( MonadMask m
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident [])
+            , MonadUnliftIO m
+          --, MonadLogger m
+            )
+         => (LdapConf, LdapPool)
+         -> Creds site
+         -> m (Ldap.AttrList [])
+ldapUser pool creds = throwLeft =<< ldapUserWith withLdap pool creds
 
-campusUserMatr :: (MonadUnliftIO m, MonadMask m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Ldap.AttrList [])
+ldapUser' :: ( MonadMask m
-campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
+             , MonadUnliftIO m
-  Ldap.bind ldap ldapDn ldapPassword
+           --, MonadLogger m
+             )
+          => (LdapConf, LdapPool)
+          -> User
+          -> m (Maybe (Ldap.AttrList []))
+ldapUser' pool User{userIdent}
+  = ldapUser'' pool $ CI.original userIdent
+
+ldapUser'' :: ( MonadMask m
+              , MonadUnliftIO m
+            --, MonadLogger m
+              )
+           => (LdapConf, LdapPool)
+           -> Text
+           -> m (Maybe (Ldap.AttrList []))
+ldapUser'' pool ident
+  = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) $ ldapUser pool (Creds apLdap ident [])
+
+
+ldapUserMatr :: ( MonadUnliftIO m
+                , MonadMask m
+              --, MonadLogger m
+                )
+             => (LdapConf, LdapPool)
+             -> UserMatriculation
+             -> m (Ldap.AttrList [])
+ldapUserMatr (conf@LdapConf{..}, pool) userMatr = either (throwM . LdapUserLdapError) return <=< withLdap pool $ \ldap -> liftIO $ do
+  Ldap.bind ldap ldapConfDn ldapConfPassword
   results <- findUserMatr conf ldap userMatr []
   case results of
-    [] -> throwM CampusUserNoResult
+    [] -> throwM LdapUserNoResult
     [Ldap.SearchEntry _ attrs] -> return attrs
-    _otherwise -> throwM CampusUserAmbiguous
+    _otherwise -> throwM LdapUserAmbiguous
-
-campusUserMatr' :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> UserMatriculation -> m (Maybe (Ldap.AttrList []))
-campusUserMatr' pool mode
-  = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) . campusUserMatr pool mode
 
+ldapUserMatr' :: ( MonadMask m
+                 , MonadUnliftIO m
+               --, MonadLogger m
+                 )
+              => (LdapConf, LdapPool)
+              -> UserMatriculation
+              -> m (Maybe (Ldap.AttrList []))
+ldapUserMatr' pool = runMaybeT . catchIfMaybeT (is _LdapUserNoResult) . ldapUserMatr pool
 
 
 newtype ADInvalidCredentials = ADInvalidCredentials ADError
@@ -186,25 +263,28 @@ campusForm :: ( RenderMessage (HandlerSite m) FormMessage
               , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
               , RenderMessage (HandlerSite m) CampusMessage
               , MonadHandler m
-              ) => WForm m (FormResult CampusLogin)
+              )
+           => WForm m (FormResult CampusLogin)
 campusForm = do
   MsgRenderer mr <- getMsgRenderer
   aFormToWForm $ CampusLogin
    <$> areq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "" & addAttr "autocomplete" "username") Nothing
    <*> areq passwordField (fslpI MsgCampusPassword (mr MsgCampusPasswordPlaceholder) & addAttr "autocomplete" "current-password") Nothing
 
-apLdap :: Text
-apLdap = "LDAP"
 
-campusLogin :: forall site.
+-- TODO: reintroduce Failover
-               ( YesodAuth site
+ldapLogin :: forall site.
-               , RenderMessage site CampusMessage
+             ( YesodAuth site
-               , RenderAFormSite site
+             , RenderMessage site CampusMessage
-               , RenderMessage site (ValueRequired site)
+             , RenderAFormSite site
-               , RenderMessage site ADInvalidCredentials
+             , RenderMessage site (ValueRequired site)
-               , Button site ButtonSubmit
+             , RenderMessage site ADInvalidCredentials
-               ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site
+             , Button site ButtonSubmit
-campusLogin pool mode = AuthPlugin{..}
+             )
+          => LdapConf
+          -> LdapPool
+          -> AuthPlugin site
+ldapLogin conf@LdapConf{..} pool = AuthPlugin{..}
   where
     apName :: Text
     apName = apLdap
@@ -215,8 +295,8 @@ campusLogin pool mode = AuthPlugin{..}
       tp <- getRouteToParent
 
       resp <- formResultMaybe loginRes $ \CampusLogin{ campusIdent = CI.original -> campusIdent, ..} -> Just <$> do
-        ldapResult <- withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do
+        ldapResult <- withLdap pool $ \ldap -> liftIO $ do
-          Ldap.bind ldap ldapDn ldapPassword
+          Ldap.bind ldap ldapConfDn ldapConfPassword
           searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName]
           case searchResults of
             [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs]

src/Auth/OAuth2.hs

@@ -1,19 +1,22 @@
--- SPDX-FileCopyrightText: 2023 David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Auth.OAuth2
-( AzureUserException(..)
+  ( apAzure
-, azurePluginName
+  , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage
-, oauth2MockServer
+  -- , azureUser, azureUser'
-, mockPluginName
+  , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous
-, queryOAuth2User
+  , apAzureMock
-, UserDataException
+  , azureMockServer
-, singleSignOut
+  , queryOAuth2User
-) where
+  , refreshOAuth2Token
+  , singleSignOut
+  ) where
 
+-- import qualified Data.CaseInsensitive as CI
 import Data.Maybe (fromJust)
 import Data.Text
 
@@ -26,31 +29,94 @@ import System.Environment (lookupEnv)
 import Yesod.Auth.OAuth2
 import Yesod.Auth.OAuth2.Prelude hiding (encodeUtf8)
 
+-- | Plugin name of the OAuth2 yesod plugin for Azure ADv2
+apAzure :: Text
+apAzure = "AzureADv2"
 
+
+-- TODO: deprecate in favour of FetchUserDataException
 data AzureUserException = AzureUserError
                         | AzureUserNoResult
-                        | AzureUserAmbiguous -- TODO
+                        | AzureUserAmbiguous
                         deriving (Show, Eq, Generic)
 
 instance Exception AzureUserException
 
-azurePluginName :: Text
+makePrisms ''AzureUserException
-azurePluginName = "azureadv2"
+
+
+azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage :: Text
+azurePrimaryKey = "id"
+azureUserPrincipalName = "userPrincipalName"
+azureUserDisplayName = "displayName"
+azureUserGivenName = "givenName"
+azureUserSurname = "surname"
+azureUserMail = "mail"
+azureUserTelephone = "businessPhones"
+azureUserMobile = "mobilePhone"
+azureUserPreferredLanguage = "preferredLanguage"
+
+
+-- | User lookup in Microsoft Graph with given credentials
+-- TODO: deprecate in favour of fetchUserData
+-- azureUser :: ( MonadMask m
+--              , MonadHandler m
+--              -- , HandlerSite m ~ site
+--              -- , BackendCompatible SqlBackend (YesodPersistBackend site)
+--              -- , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+--              -- , YesodPersist site
+--              -- , PersistUniqueWrite (YesodPersistBackend site)
+--              )
+--              => AzureConf
+--              -> Creds site
+--              -> m [(Text, [ByteString])] -- (Either AzureUserException [(Text, [ByteString])])
+-- azureUser AzureConf{..} Creds{..} = fmap throwLeft . runExceptT $ do
+--   now <- liftIO getCurrentTime
+--   results <- queryOAuth2User @[(Text, [ByteString])] credsIdent
+--   case results of
+--     Right [res] -> do
+--       -- void . liftHandler . runDB $ upsert ExternalUser
+--       --   { externalUserUser     =  error "no userid" -- TODO: use azureUserPrimaryKey once UserIdent is referenced instead of UserId
+--       --   , externalUserSource   =  AuthSourceIdAzure azureConfClientId
+--       --   , externalUserData     =  toJSON res
+--       --   , externalUserLastSync =  now
+--       --   }
+--       --   [ ExternalUserData     =. toJSON res
+--       --   , ExternalUserLastSync =. now
+--       --   ]
+--       return res
+--     Right _multiple -> throwE AzureUserAmbiguous
+--     Left _ -> throwE AzureUserNoResult
+
+-- | User lookup in Microsoft Graph with given user
+-- azureUser' :: ( MonadMask m
+--               , MonadHandler m
+--               , HandlerSite m ~ site
+--               , BaseBackend (YesodPersistBackend site) ~ SqlBackend
+--               , YesodPersist site
+--               , PersistUniqueWrite (YesodPersistBackend site)
+--               )
+--              => AzureConf
+--              -> User
+--              -> ReaderT (YesodPersistBackend site) m (Maybe [(Text, [ByteString])]) -- (Either AzureUserException [(Text, [ByteString])])
+-- azureUser' conf User{userIdent}
+--   = runMaybeT . catchIfMaybeT (is _AzureUserNoResult) $ azureUser conf (Creds apAzure (CI.original userIdent) [])
+
 
 -----------------------------------------------
 ---- OAuth2 + OIDC development auth plugin ----
 -----------------------------------------------
 
-mockPluginName :: Text
+apAzureMock :: Text
-mockPluginName = "dev-oauth2-mock"
+apAzureMock = "uniworx_dev"
 
 newtype UserID = UserID Text
 instance FromJSON UserID where
   parseJSON = withObject "UserID" $ \o ->
     UserID <$> o .: "id"
 
-oauth2MockServer :: YesodAuth m => String -> AuthPlugin m
+azureMockServer :: YesodAuth m => String -> AuthPlugin m
-oauth2MockServer port =
+azureMockServer port =
   let oa = OAuth2
             { oauth2ClientId = "42"
             , oauth2ClientSecret = Just "shhh"
@@ -64,14 +130,15 @@ oauth2MockServer port =
             }
       mockServerURL = "http://localhost:" <> fromString port
       profileSrc = fromString $ mockServerURL <> "/users/me"
-  in  authOAuth2 mockPluginName oa $ \manager token -> do
+  in  authOAuth2 apAzureMock oa $ \manager token -> do
-        (UserID userID, userResponse) <- authGetProfile mockPluginName manager token profileSrc
+        (UserID userID, userResponse) <- authGetProfile apAzureMock manager token profileSrc
         return Creds
-                { credsPlugin = mockPluginName
+                { credsPlugin = apAzureMock
                 , credsIdent = userID
                 , credsExtra = setExtra token userResponse
                 }
 
+
 ----------------------
 ---- User Queries ----
 ----------------------
@@ -82,8 +149,12 @@ data UserDataException = UserDataJSONException JSONException
 
 instance Exception UserDataException
 
-queryOAuth2User :: forall j m . (FromJSON j, MonadIO m, MonadThrow m, MonadHandler m)
+queryOAuth2User :: forall j m.
-                => Text
+                   ( FromJSON j
+                   , MonadHandler m
+                   , MonadThrow m
+                   )
+                => Text -- ^ User identifier (arbitrary needle)
                 -> m (Either UserDataException j)
 queryOAuth2User userID = runExceptT $ do
   (queryUrl, tokenUrl) <- liftIO mkBaseUrls
@@ -120,7 +191,10 @@ mkBaseUrls = do
 # endif
 
 
-refreshOAuth2Token :: forall m. (MonadIO m, MonadThrow m, MonadHandler m)
+refreshOAuth2Token :: forall m.
+                      ( MonadHandler m
+                      , MonadThrow m
+                      )
                    => (Maybe AccessToken, Maybe RefreshToken)
                    -> String
                    -> Bool
@@ -136,8 +210,8 @@ refreshOAuth2Token (_, rToken) url secure
     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 offline_access")] -- TODO read from config
+        return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), scopeParam " " ["openid","profile"," offline_access"]] -- TODO read from config
-      else return $ ("scope", "openid profile offline_access") : body -- TODO read from config
+      else return $ scopeParam " " ["openid","profile","offline_access"] : body -- TODO read from config
     $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

src/Auth/PWHash.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -68,12 +68,13 @@ hashLogin pwHashAlgo = AuthPlugin{..}
       tp <- getRouteToParent
 
       resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do
-        user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
+        user :: Maybe (Entity User) <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
         case user of
-          Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
+          Just (Entity _ User{userIdent,userPasswordHash})
-            | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> do -- (2^) is magic.
+            | Just pwHash <- userPasswordHash
+            , verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 pwHash) -> do -- (2^) is magic.
                 observeLoginOutcome apName LoginSuccessful
-                setCredsRedirect $ Creds apName userIdent []
+                setCredsRedirect $ Creds apName (CI.original userIdent) []
           other -> do
             $logDebugS apName $ tshow other
             observeLoginOutcome apName LoginInvalidCredentials

src/Database/Esqueleto/Utils.hs

@@ -227,8 +227,13 @@ explicitUnsafeCoerceSqlExprValue typ (E.ERaw _m1 f1) = E.ERaw E.noMeta $ \_nPare
       )
 
 and, or :: Foldable f => f (E.SqlExpr (E.Value Bool)) -> E.SqlExpr (E.Value Bool)
-and = F.foldl' (E.&&.) true -- we can use foldl' since Postgresql reorders conditions anyway
+-- and = F.foldl' (E.&&.) true -- we can use foldl' since PostgreSQL reorders conditions anyway
-or = F.foldl' (E.||.) false
+-- or = F.foldl' (E.||.) false
+-- Maybe this help the PostgreSQL query optimizer, though I doubt it?
+and f | F.null f    = true
+      | otherwise = F.foldl1 (E.&&.) f
+or f  | F.null f    = false
+      | otherwise = F.foldl1 (E.||.) f
 
 -- | Given a test and a set of values, check whether anyone succeeds the test
 --   WARNING: SQL leaves it explicitely unspecified whether `||` is short curcuited (i.e. lazily evaluated)

src/Foundation/Authorization.hs

@@ -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-2024 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
 
@@ -1521,7 +1521,7 @@ tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return retu
       | uid == referencedUser -> return Authorized
     Nothing -> return AuthenticationRequired
     _other  -> unauthorizedI MsgUnauthorizedSelf
-tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
     AdminUserR cID -> return cID
     AdminUserDeleteR cID -> return cID
@@ -1529,13 +1529,17 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $
     UserNotificationR cID -> return cID
     UserPasswordR cID -> return cID
     CourseR _ _ _ (CUserR cID) -> return cID
-    _other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsExternal route
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
-  maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
+  availableSources <- getsYesod (view _appUserAuthConf) >>= \case
-    User{..} <- MaybeT $ get referencedUser'
+    UserAuthConfSingleSource{..} -> return . singleton $ case userAuthConfSingleSource of
-    guard $ userAuthentication == AuthLDAP
+      AuthSourceConfAzureAdV2 AzureConf{..} -> AuthSourceIdAzure azureConfTenantId
+      AuthSourceConfLdap      LdapConf{..}  -> AuthSourceIdLdap  ldapConfSourceId
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedExternal) $ do
+    Entity _ User{userIdent} <- MaybeT $ getEntity referencedUser'
+    guardM . lift $ exists [ ExternalUserUser ==. userIdent, ExternalUserSource <-. availableSources ]
   return Authorized
-tagAccessPredicate AuthIsPWHash = APDB $ \_ _ _ route _ -> exceptT return return $ do
+tagAccessPredicate AuthIsInternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
   referencedUser <- case route of
     AdminUserR cID -> return cID
     AdminUserDeleteR cID -> return cID
@@ -1543,11 +1547,11 @@ tagAccessPredicate AuthIsPWHash = APDB $ \_ _ _ route _ -> exceptT return return
     UserNotificationR cID -> return cID
     UserPasswordR cID -> return cID
     CourseR _ _ _ (CUserR cID) -> return cID
-    _other -> throwError =<< $unsupportedAuthPredicate AuthIsPWHash route
+    _other -> throwError =<< $unsupportedAuthPredicate AuthIsInternal route
   referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
-  maybeTMExceptT (unauthorizedI MsgUnauthorizedPWHash) $ do
+  maybeTMExceptT (unauthorizedI MsgUnauthorizedInternal) $ do
     User{..} <- MaybeT $ get referencedUser'
-    guard $ is _AuthPWHash userAuthentication
+    guard $ is _Just userPasswordHash
   return Authorized
 tagAccessPredicate AuthAuthentication = APDB $ \_ _ mAuthId route _ -> case route of
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageAuth) $ do

src/Foundation/I18n.hs

@@ -384,8 +384,6 @@ embedRenderMessage ''UniWorX ''ExamRequiredEquipmentPreset id
 embedRenderMessage ''UniWorX ''ChangelogItemKind id
 embedRenderMessage ''UniWorX ''RoomReference' $ dropSuffix "'"
 
-embedRenderMessage ''UniWorX ''AuthenticationMode id
-
 embedRenderMessage ''UniWorX ''RatingValidityException id
 
 embedRenderMessage ''UniWorX ''UrlFieldMessage id

src/Foundation/Instances.hs

@@ -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>,David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022-2024 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>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -141,7 +141,7 @@ instance YesodAuth UniWorX where
       AppSettings{..} <- getsYesod appSettings'
 
       when appSingleSignOn $ do
-        let plugin = P.head $ P.filter ((`elem` [mockPluginName, azurePluginName]) . apName) plugins
+        let plugin = P.head $ P.filter ((`elem` [apAzureMock, apAzure]) . apName) plugins
             pieces = case oauth2Url (apName plugin) of
                       PluginR _ p -> p
                       _ -> error "Unexpected OAuth2 AuthRoute"
@@ -154,12 +154,10 @@ instance YesodAuth UniWorX where
         setTitleI MsgLoginTitle
         $(widgetFile "login")
 
-    authenticate c@Creds{..}
+    authenticate = UniWorX.authenticate
-      | credsPlugin `elem` ["azureadv2", "dev-oauth2-mock"] = UniWorX.oAuthenticate c
-      | otherwise                                       = UniWorX.authenticate c
 
     authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes
-      [ flip campusLogin campusUserFailoverMode <$> appLdapPool
+      [ uncurry ldapLogin <$> appLdapPool
       , Just . hashLogin $ pwHashAlgorithm appAuthPWHash
       , dummyLogin <$ guard appAuthDummyLogin
       ]

src/Foundation/Navigation.hs

@@ -117,8 +117,7 @@ breadcrumb AdminCrontabR        = i18nCrumb MsgBreadcrumbAdminCrontab     $ Just
 breadcrumb AdminJobsR           = i18nCrumb MsgBreadcrumbAdminJobs        $ Just AdminCrontabR
 breadcrumb AdminAvsR            = i18nCrumb MsgMenuAvs                    $ Just AdminR
 breadcrumb AdminAvsUserR{}      = i18nCrumb MsgAvsPersonInfo              $ Just AdminAvsR
-breadcrumb AdminLdapR           = i18nCrumb MsgMenuLdap                   $ Just AdminR
+breadcrumb AdminExternalUserR   = i18nCrumb MsgMenuExternalUser           $ 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
@@ -852,16 +851,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the
               , navForceActive = False
               }
           , NavLink
-              { navLabel       = MsgMenuLdap
+              { navLabel       = MsgMenuExternalUser
-              , navRoute       = AdminLdapR
+              , navRoute       = AdminExternalUserR
-              , navAccess'     = NavAccessTrue
-              , navType        = NavTypeLink { navModal = False }
-              , navQuick'      = mempty
-              , navForceActive = False
-              }
-          , NavLink
-              { navLabel       = MsgMenuOAuth2
-              , navRoute       = AdminOAuth2R
               , navAccess'     = NavAccessTrue
               , navType        = NavTypeLink { navModal = False }
               , navQuick'      = mempty
@@ -1218,8 +1209,8 @@ pageActions (AdminUserR cID) = return
       , navRoute       = UserPasswordR cID
       , navAccess' = NavAccessDB $ do
           uid <- decrypt cID
-          User{userAuthentication} <- get404 uid
+          User{userPasswordHash} <- get404 uid
-          return $ is _AuthPWHash userAuthentication
+          return $ is _Just userPasswordHash
       , navType        = NavTypeLink { navModal = True }
       , navQuick'      = mempty
       , navForceActive = False

src/Foundation/Type.hs

@@ -79,7 +79,7 @@ data UniWorX = UniWorX
     , appStatic            :: EmbeddedStatic -- ^ Settings for static file serving.
     , appConnPool          :: forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend -- ^ Database connection pool.
     , appSmtpPool          :: Maybe SMTPPool
-    , appLdapPool          :: Maybe (Failover (LdapConf, LdapPool))
+    , appLdapPool          :: Maybe (LdapConf, LdapPool) -- TODO: reintroduce Failover
     , appWidgetMemcached   :: Maybe Memcached.Connection -- ^ Actually a proper pool
     , appHttpManager       :: Manager
     , appLogger            :: (ReleaseKey, TVar Logger)

src/Foundation/Types.hs

@@ -1,39 +1,44 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Foundation.Types
-  ( UpsertCampusUserMode(..)
+  ( UpsertUserMode(..)
-  , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser
+  , _UpsertUserLogin, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser
-  , _upsertCampusUserIdent
+  , _upsertUserSource, _upsertUserIdent
-  , UpsertAzureUserMode(..)
+  , UpsertUserData(..)
-  , _UpsertAzureUserLoginOAuth, _UpsertAzureUserLoginDummy, _UpsertAzureUserLoginOther, _UpsertAzureUserOAuthSync, _UpsertAzureUserGuessUser
+  , _UpsertUserDataAzure, _UpsertUserDataLdap
-  , _upsertAzureUserIdent
+  , _upsertUserAzureTenantId, _upsertUserAzureData, _upsertUserLdapHost, _upsertUserLdapData
   ) where
 
 import Import.NoFoundation
 
-
+import qualified Ldap.Client as Ldap
-data UpsertCampusUserMode
-  = UpsertCampusUserLoginLdap
-  | UpsertCampusUserLoginDummy { upsertCampusUserIdent :: UserIdent }
-  | UpsertCampusUserLoginOther { upsertCampusUserIdent :: UserIdent } -- erlaubt keinen späteren Login
-  | UpsertCampusUserLdapSync   { upsertCampusUserIdent :: UserIdent }
-  | UpsertCampusUserGuessUser
-  deriving (Eq, Ord, Read, Show, Generic)
-
-makeLenses_ ''UpsertCampusUserMode
-makePrisms ''UpsertCampusUserMode
 
 
--- Azure users logging in via OAuth2
+-- TODO: rename?
-data UpsertAzureUserMode
+data UpsertUserMode
-  = UpsertAzureUserLoginOAuth
+  = UpsertUserLogin      { upsertUserSource :: Text } -- TODO: use type synonym?
-  | UpsertAzureUserLoginDummy { upsertAzureUserIdent :: UserIdent }
+  | UpsertUserLoginDummy { upsertUserIdent  :: UserIdent }
-  | UpsertAzureUserLoginOther { upsertAzureUserIdent :: UserIdent }
+  | UpsertUserLoginOther { upsertUserIdent  :: UserIdent } -- does not allow further login
-  | UpsertAzureUserOAuthSync  { upsertAzureUserIdent :: UserIdent }
+  | UpsertUserSync       { upsertUserIdent  :: UserIdent }
-  | UpsertAzureUserGuessUser
+  | UpsertUserGuessUser
-  deriving (Eq, Ord, Read, Show, Generic)
+  deriving (Show)
 
-makeLenses_ ''UpsertAzureUserMode
+makeLenses_ ''UpsertUserMode
-makePrisms ''UpsertAzureUserMode
+makePrisms ''UpsertUserMode
+
+
+data UpsertUserData
+  = UpsertUserDataAzure
+    { upsertUserAzureTenantId :: UUID
+    , upsertUserAzureData     :: [(Text, [ByteString])]  -- TODO: use type synonym?
+    }
+  | UpsertUserDataLdap
+    { upsertUserLdapHost      :: Text
+    , upsertUserLdapData      :: Ldap.AttrList []
+    }
+  deriving (Show)
+
+makeLenses_ ''UpsertUserData
+makePrisms ''UpsertUserData

src/Foundation/Yesod/Auth.hs

@@ -1,148 +1,70 @@
--- SPDX-FileCopyrightText: 2023 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 module Foundation.Yesod.Auth
   ( authenticate
-  , oAuthenticate
+  , userLookupAndUpsert
-  , ldapLookupAndUpsert
+  , upsertUser, maybeUpsertUser
-  , upsertCampusUser
   , decodeUserTest
-  , CampusUserConversionException(..)
+  , DecodeUserException(..)
-  , campusUserFailoverMode, updateUserLanguage
+  , updateUserLanguage
   ) where
 
 import Import.NoFoundation hiding (authenticate)
 
+import Auth.Dummy (apDummy)
+import Auth.LDAP
+import Auth.OAuth2
+import Auth.PWHash (apHash)
+
 import Foundation.Type
 import Foundation.Types
 import Foundation.I18n
 
-import Handler.Utils.Profile
+-- import Handler.Utils.Profile
 import Handler.Utils.LdapSystemFunctions
 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)
-import Auth.Dummy (apDummy)
 
-import qualified Data.CaseInsensitive as CI
 import qualified Control.Monad.Catch as C (Handler(..))
-import qualified Ldap.Client as Ldap
+
+import qualified Data.ByteString as ByteString
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Map as Map
+import qualified Data.List.NonEmpty as NonEmpty (toList)
+import qualified Data.Set as Set
 import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
-import qualified Data.ByteString as ByteString
-import qualified Data.Set as Set
-import qualified Data.Map as Map
--- import qualified Data.Conduit.Combinators as C
 
--- import qualified Data.List as List ((\\))
+import qualified Ldap.Client as Ldap
-
--- import qualified Data.UUID as UUID
--- import Data.ByteArray (convert)
--- import Crypto.Hash (SHAKE128)
--- import qualified Data.Binary as Binary
-
--- import qualified Database.Esqueleto.Legacy as E
--- import qualified Database.Esqueleto.Utils as E
-
--- import Crypto.Hash.Conduit (sinkHash)
 
 
 authenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
                 , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
                 , YesodAuth UniWorX, UserId ~ AuthId UniWorX
                 )
-             => Creds UniWorX -> m (AuthenticationResult UniWorX)
+             => Creds UniWorX
+             -> m (AuthenticationResult UniWorX)
 authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend $ do
-  $logErrorS "Auth" $ "\a\27[31m" <> tshow creds <> "\27[0m"
+  $logErrorS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m" -- TODO: debug only
-  now <- liftIO getCurrentTime
-
-  let
-    uAuth = UniqueAuthentication $ CI.mk credsIdent
-    upsertMode = creds ^? _upsertCampusUserMode
-
-    isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode
-    isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode
-
-    excRecovery res
-      | isDummy || isOther
-      = do
-          case res of
-            UserError   err -> addMessageI Error   err
-            ServerError err -> addMessage  Error $ toHtml err
-            _other          -> return ()
-          acceptExisting
-      | otherwise
-      = return res
-
-    excHandlers =
-      [ C.Handler $ \case
-          CampusUserNoResult -> do
-            $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent
-            excRecovery . UserError $ IdentifierNotFound credsIdent
-          CampusUserAmbiguous -> do
-            $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent
-            excRecovery . UserError $ IdentifierNotFound credsIdent
-          err -> do
-            $logErrorS "LDAP" $ tshow err
-            mr <- getMessageRender
-            excRecovery . ServerError $ mr MsgInternalLdapError
-      , C.Handler $ \(cExc :: CampusUserConversionException) -> do
-          $logErrorS "LDAP" $ tshow cExc
-          mr <- getMessageRender
-          excRecovery . ServerError $ mr cExc
-      ]
-
-    acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
-    acceptExisting = do
-      res <- maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth
-      case res of
-        Authenticated uid
-          -> associateUserSchoolsByTerms uid
-        _other
-          -> return ()
-      case res of
-        Authenticated uid
-          | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
-        _other -> return res
-
-  $logDebugS "auth" $ tshow Creds{..}  
-  ldapPool' <- getsYesod $ view _appLdapPool
-
-  flip catches excHandlers $ case ldapPool' of
-    Just ldapPool
-      | Just upsertMode' <- upsertMode -> do
-          ldapData <- campusUser ldapPool campusUserFailoverMode Creds{..}
-          $logDebugS "LDAP" $ "Successful LDAP lookup: " <> tshow ldapData
-          Authenticated . entityKey <$> upsertCampusUser upsertMode' ldapData
-    _other
-      -> acceptExisting
-
-
--- | Authentication via AzureADv2 / OAuth 2
-oAuthenticate :: ( MonadHandler m, HandlerSite m ~ UniWorX
-                 , YesodPersist UniWorX, BackendCompatible SqlBackend (YesodPersistBackend UniWorX)
-                 , YesodAuth UniWorX, UserId ~ AuthId 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"
+  $logErrorS "OAuth session Debug" $ "\27[34m" <> tshow sess <> "\27[0m" -- TODO: debug only
+
   now <- liftIO getCurrentTime
+  userAuthConf <- getsYesod $ view _appUserAuthConf -- TODO: debug only
+  $logErrorS "authenticate AuthConf Debug" $ "\27[31m" <> tshow userAuthConf <> "\27[0m" -- TODO: debug only
 
   let
     uAuth = UniqueAuthentication $ CI.mk credsIdent
-    upsertMode = creds ^? _upsertAzureUserMode
+    upsertMode = creds ^? _upsertUserMode
 
-    isDummy = is (_Just . _UpsertAzureUserLoginDummy) upsertMode -- mock server 
+    isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode
-    isOther = is (_Just . _UpsertAzureUserLoginOther) upsertMode
+    isOther = is (_Just . _UpsertUserLoginOther) upsertMode
 
     excRecovery res
       | isDummy || isOther
@@ -156,21 +78,21 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
       = return res
 
     excHandlers =
-      [ C.Handler $ \case
+      [ C.Handler $ \(fExc :: FetchUserDataException) -> case fExc of
-          AzureUserNoResult -> do
+          FetchUserDataNoResult -> do
-            $logWarnS "OAuth" $ "User lookup failed after successful login for " <> credsIdent
+            $logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
-          AzureUserAmbiguous -> do
+          FetchUserDataAmbiguous -> do
-            $logWarnS "OAuth" $ "Multiple OAuth results for " <> credsIdent
+            $logWarnS "FetchUserException" $ "Multiple User results for " <> credsIdent
             excRecovery . UserError $ IdentifierNotFound credsIdent
           err -> do
-            $logErrorS "OAuth" $ tshow err
+            $logErrorS "FetchUserException" $ tshow err
             mr <- getMessageRender
-            excRecovery . ServerError $ mr MsgInternalLdapError -- TODO where does this come from?
+            excRecovery . ServerError $ mr MsgInternalLoginError
-      , C.Handler $ \(cExc :: CampusUserConversionException) -> do -- TODO new exception type or not?
+      , C.Handler $ \(dExc :: DecodeUserException) -> do
-          $logErrorS "OAuth" $ tshow cExc
+          $logErrorS "Auth" $ tshow dExc
           mr <- getMessageRender
-          excRecovery . ServerError $ mr cExc
+          excRecovery . ServerError $ mr dExc
       ]
 
     acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX)
@@ -186,271 +108,300 @@ oAuthenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend
           | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ]
         _other -> return res
 
-  $logDebugS "oauth" $ tshow creds
+  $logDebugS "Auth" $ tshow Creds{..}
-  -- TODO If user not in DB then put
+
-  pool <- getsYesod $ view _appLdapPool
+  flip catches excHandlers $ if
-  flip catches excHandlers $ case pool of
+    | not isDummy, not isOther
-    Just ldapPool
+    , Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case
-      | Just upsertMode' <- upsertMode -> do
+      Just userData -> do
-          ldapData <- campusUser ldapPool campusUserFailoverMode creds
+        $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData
-          $logDebugS "OAuth" $ "Successful LDAP lookup of Azure user: " <> tshow ldapData
+        Authenticated . entityKey <$> upsertUser upsertMode' userData
-          Authenticated . entityKey <$> upsertAzureUser upsertMode' ldapData
+      Nothing
-    _other
+        -> throwM FetchUserDataNoResult
+    | otherwise
       -> acceptExisting
 
 
-
+data DecodeUserException
-data CampusUserConversionException
+  = DecodeUserInvalidIdent
-  = CampusUserInvalidIdent
+  | DecodeUserInvalidEmail
-  | CampusUserInvalidEmail
+  | DecodeUserInvalidDisplayName
-  | CampusUserInvalidDisplayName
+  | DecodeUserInvalidGivenName
-  | CampusUserInvalidGivenName
+  | DecodeUserInvalidSurname
-  | CampusUserInvalidSurname
+  | DecodeUserInvalidTitle
-  | CampusUserInvalidTitle
+  | DecodeUserInvalidFeaturesOfStudy Text
-  -- | CampusUserInvalidMatriculation
+  | DecodeUserInvalidAssociatedSchools Text
-  | CampusUserInvalidFeaturesOfStudy Text
-  | CampusUserInvalidAssociatedSchools Text
   deriving (Eq, Ord, Read, Show, Generic)
   deriving anyclass (Exception)
 
-_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode
+
-_upsertCampusUserMode mMode cs@Creds{..}
+_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode
-  | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent)
+_upsertUserMode mMode cs@Creds{..}
-  | credsPlugin == apLdap  = setMode <$> mMode  UpsertCampusUserLoginLdap
+  | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent)
-  | otherwise              = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent)
+  | credsPlugin `elem` loginAPs
+                           = setMode <$> mMode (UpsertUserLogin credsPlugin)
+  | otherwise              = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent)
   where
-    setMode UpsertCampusUserLoginLdap
+    setMode UpsertUserLogin{..} | upsertUserSource `elem` loginAPs
-      = cs{ credsPlugin = apLdap }
+      = cs { credsPlugin = upsertUserSource }
-    setMode (UpsertCampusUserLoginDummy ident)
+    setMode UpsertUserLoginDummy{..}
-      = cs{ credsPlugin = apDummy
+      = cs { credsPlugin = apDummy
-          , credsIdent  = CI.original ident
+           , credsIdent  = CI.original upsertUserIdent
-          }
+           }
-    setMode (UpsertCampusUserLoginOther ident)
+    setMode UpsertUserLoginOther{..}
-      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap)
+      = cs { credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure])
-          , credsIdent  = CI.original ident
+           , credsIdent  = CI.original upsertUserIdent
-          }
+           }
     setMode _ = cs
 
+    loginAPs = [ apAzure, apLdap ]
     defaultOther = apHash
 
 
-_upsertAzureUserMode :: Traversal' (Creds UniWorX) UpsertAzureUserMode
+userLookupAndUpsert :: forall m.
-_upsertAzureUserMode mMode cs@Creds{..}
+                       ( MonadHandler m
-  | credsPlugin == mockPluginName = setMode <$> mMode (UpsertAzureUserLoginDummy $ CI.mk credsIdent)
+                       , HandlerSite m ~ UniWorX
-  | credsPlugin == "azureadv2"    = setMode <$> mMode  UpsertAzureUserLoginOAuth
+                       , MonadMask m
-  | otherwise                     = setMode <$> mMode (UpsertAzureUserLoginOther $ CI.mk credsIdent)
+                       , MonadUnliftIO m
-  where
+                       )
-    setMode UpsertAzureUserLoginOAuth
+                    => Text
-      = cs{ credsPlugin = "azureadv2" }
+                    -> UpsertUserMode
-    setMode (UpsertAzureUserLoginDummy ident)
+                    -> SqlPersistT m (Maybe (Entity User))
-      = cs{ credsPlugin = mockPluginName
+userLookupAndUpsert credsIdent mode =
-          , credsIdent  = CI.original ident
+  fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode
-          }
-    setMode (UpsertAzureUserLoginOther ident)
-      = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= mockPluginName && credsPlugin /= "azureadv2")
-          , credsIdent  = CI.original ident
-          }
-    setMode _ = cs
-
-    defaultOther = apHash
 
 
+data FetchUserDataException
+  = FetchUserDataNoResult
+  | FetchUserDataAmbiguous
+  | FetchUserDataException
+  deriving (Eq, Ord, Read, Show, Generic)
+  deriving anyclass (Exception)
 
-ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User)                    
+-- | Fetch user data with given credentials from external source(s)
-ldapLookupAndUpsert ident = 
+fetchUserData :: forall m site.
-  getsYesod (view _appLdapPool) >>= \case 
+                 ( MonadHandler m
-    Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation."
+                 , HandlerSite m ~ UniWorX
-    Just ldapPool ->
+                 , MonadCatch m
-      campusUser'' ldapPool campusUserFailoverMode ident >>= \case
+                 , MonadMask m
-        Nothing -> throwM CampusUserNoResult
+                 , MonadUnliftIO m
-        Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse
+                 )
+              => Creds site
+              -> SqlPersistT m (Maybe (NonEmpty UpsertUserData))
+fetchUserData Creds{..} = do
+  userAuthConf <- getsYesod $ view _appUserAuthConf
+  now <- liftIO getCurrentTime
+
+  results :: Maybe (NonEmpty UpsertUserData) <- case userAuthConf of
+    UserAuthConfSingleSource{..} -> fmap (:| []) <$> case userAuthConfSingleSource of
+      AuthSourceConfAzureAdV2 AzureConf{ azureConfClientId = upsertUserAzureTenantId } -> do
+        queryOAuth2User @[(Text, [ByteString])] credsIdent >>= \case
+          Right upsertUserAzureData -> return $ Just UpsertUserDataAzure{..}
+          Left _ -> return Nothing
+      AuthSourceConfLdap LdapConf{..} -> getsYesod (view _appLdapPool) >>= \case
+        Just ldapPool -> fmap (UpsertUserDataLdap ldapConfSourceId) <$> ldapUser'' ldapPool credsIdent
+        Nothing -> throwM FetchUserDataException
+
+  -- insert ExternalUser entries for each fetched dataset
+  whenIsJust results $ \ress -> forM_ ress $ \res -> do
+    let externalUserLastSync = now
+        (externalUserData, externalUserSource) = case res of
+          UpsertUserDataAzure{..} -> (toJSON upsertUserAzureData, AuthSourceIdAzure upsertUserAzureTenantId)
+          UpsertUserDataLdap{..} -> (toJSON upsertUserLdapData, AuthSourceIdLdap upsertUserLdapHost)
+    externalUserUser <- if
+      | UpsertUserDataAzure{..} <- res
+      , azureData <- Map.fromListWith (++) $ upsertUserAzureData <&> \(t,bs) -> (t, filter (not . ByteString.null) bs)
+      , [(Text.decodeUtf8' -> Right azureUserPrincipalName')] <- azureData !!! azureUserPrincipalName
+        -> return $ CI.mk azureUserPrincipalName'
+      | UpsertUserDataLdap{..} <- res
+      , ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> \(t,bs) -> (t, filter (not . ByteString.null) bs)
+      , [(Text.decodeUtf8' -> Right ldapPrimaryKey')] <- ldapData !!! ldapPrimaryKey
+        -> return $ CI.mk ldapPrimaryKey'
+      | otherwise
+        -> throwM DecodeUserInvalidIdent
+    void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync]
+
+  return results
 
 
-upsertAzureUser :: forall m.
+-- | Upsert User and related auth in DB according to given external source data (does not query source itself)
-                   ( MonadHandler m, HandlerSite m ~ UniWorX
+maybeUpsertUser :: forall m.
+                   ( MonadHandler m
+                   , HandlerSite m ~ UniWorX
                    , MonadCatch m
                    )
-                => UpsertAzureUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User) -- TODO UpsertAzureUserMode is probably redundant
+                => UpsertUserMode
-upsertAzureUser upsertMode = upsertCampusUser (toCampus upsertMode)
+                -> Maybe (NonEmpty UpsertUserData)
-  where
+                -> SqlPersistT m (Maybe (Entity User))
-    toCampus :: UpsertAzureUserMode -> UpsertCampusUserMode
+maybeUpsertUser _upsertMode Nothing = return Nothing
-    toCampus  UpsertAzureUserLoginOAuth    = UpsertCampusUserLoginLdap
+maybeUpsertUser _upsertMode (Just upsertData) = do
-    toCampus (UpsertAzureUserLoginDummy u) = UpsertCampusUserLoginDummy u
-    toCampus (UpsertAzureUserLoginOther u) = UpsertCampusUserLoginOther u
-    toCampus (UpsertAzureUserOAuthSync  u) = UpsertCampusUserLdapSync u
-    toCampus  UpsertAzureUserGuessUser     = UpsertCampusUserGuessUser
-
-
-{- THIS FUNCION JUST DECODES, BUT IT DOES NOT QUERY LDAP!
-upsertCampusUserByCn :: forall m.
-                        ( MonadHandler m, HandlerSite m ~ UniWorX
-                        , MonadThrow m
-                        )
-                      => Text -> SqlPersistT m (Entity User)
-upsertCampusUserByCn persNo = upsertCampusUser UpsertCampusUserGuessUser [(ldapPrimaryKey,[Text.encodeUtf8 persNo])]
--}
-
--- | Upsert User DB according to given LDAP data (does not query LDAP itself)
-upsertCampusUser :: forall m.
-                    ( MonadHandler m, HandlerSite m ~ UniWorX
-                    , MonadCatch m
-                    )
-                 => UpsertCampusUserMode -> Ldap.AttrList [] -> SqlPersistT m (Entity User)
-upsertCampusUser upsertMode ldapData = do
   now <- liftIO getCurrentTime
   userDefaultConf <- getsYesod $ view _appUserDefaults
 
-  (newUser,userUpdate) <- decodeUser now userDefaultConf upsertMode ldapData
+  (newUser,userUpdate) <- decodeUser now userDefaultConf upsertData
   --TODO: newUser should be associated with a company and company supervisor through Handler.Utils.Company.upsertUserCompany, but this is called by upsertAvsUser already - conflict?
 
-  oldUsers <- for (userLdapPrimaryKey newUser) $ \pKey -> selectKeysList [ UserLdapPrimaryKey ==. Just pKey ] []
+  oldUsers <- selectKeysList [ UserIdent ==. userIdent newUser ] []
 
-  user@(Entity userId userRec) <- case oldUsers of
+  user@(Entity userId _userRec) <- case oldUsers of
-    Just [oldUserId] -> updateGetEntity oldUserId userUpdate
+    [oldUserId] -> updateGetEntity oldUserId userUpdate
-    _other           -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
+    _other      -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate
-  unless (validDisplayName (newUser ^. _userTitle) 
-                           (newUser ^. _userFirstName)
-                           (newUser ^. _userSurname) 
-                           (userRec ^. _userDisplayName)) $
-    update userId [ UserDisplayName   =. (newUser ^. _userDisplayName) ]
-  when (validEmail' (userRec ^. _userEmail)) $ do 
-    let emUps =  [ UserDisplayEmail   =. (newUser ^. _userEmail)  | not (validEmail' (userRec ^. _userDisplayEmail))  ]
-              ++ [ UserAuthentication =. AuthLDAP                 | is _AuthNoLogin  (userRec ^. _userAuthentication) ]
-    unless (null emUps) $ update userId emUps
-    -- Attempt to update ident, too:
-    unless (validEmail' (userRec ^. _userIdent)) $
-      void $ maybeCatchAll (update userId [ UserIdent =. (newUser ^. _userEmail) ] >> return (Just ()))
 
   let
     userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions'
-    userSystemFunctions' = do
+    userSystemFunctions' = concat $ upsertData <&> \case
-      (k, v) <- ldapData
+      UpsertUserDataAzure{..} -> do
-      guard $ k == ldapAffiliation
+        (_k, v) <- upsertUserAzureData
-      v' <- v
+        v' <- v
-      Right str <- return $ Text.decodeUtf8' v'
+        Right str <- return $ Text.decodeUtf8' v'
-      assertM' (not . Text.null) $ Text.strip str
+        assertM' (not . Text.null) $ Text.strip str
+      UpsertUserDataLdap{..} -> do
+        (k, v) <- upsertUserLdapData
+        guard $ k == ldapAffiliation
+        v' <- v
+        Right str <- return $ Text.decodeUtf8' v'
+        assertM' (not . Text.null) $ Text.strip str
 
   iforM_ userSystemFunctions $ \func preset -> do
     memcachedByInvalidate (AuthCacheSystemFunctionList func) $ Proxy @(Set UserId)
     if | preset -> void $ upsert (UserSystemFunction userId func False False) []
        | otherwise -> deleteWhere [UserSystemFunctionUser ==. userId, UserSystemFunctionFunction ==. func, UserSystemFunctionIsOptOut ==. False, UserSystemFunctionManual ==. False]
 
-  return user
+  return $ Just user
 
-decodeUserTest :: (MonadHandler m, HandlerSite m ~ UniWorX, MonadCatch m)
+upsertUser :: forall m.
-        => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User]))
+              ( MonadHandler m
-decodeUserTest mbIdent ldapData = do
+              , HandlerSite m ~ UniWorX
-    now <- liftIO getCurrentTime
+              , MonadCatch m
-    userDefaultConf <- getsYesod $ view _appUserDefaults
+              )
-    let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent
+           => UpsertUserMode
-    try $ decodeUser now userDefaultConf mode ldapData
+           -> NonEmpty UpsertUserData
+           -> SqlPersistT m (Entity User)
+upsertUser upsertMode upsertData = maybeUpsertUser upsertMode (Just upsertData) >>= \case
+  Nothing -> error "upsertUser: No user result from maybeUpsertUser!"
+  Just user -> return user
 
 
-decodeUser :: (MonadThrow m) =>  UTCTime -> UserDefaultConf -> UpsertCampusUserMode -> Ldap.AttrList [] -> m (User,_)
+decodeUser :: ( MonadThrow m
-decodeUser now UserDefaultConf{..} upsertMode ldapData = do    
+              )
-    let
+           => UTCTime -- ^ Now
-      userTelephone             = decodeLdap ldapUserTelephone
+           -> UserDefaultConf
-      userMobile                = decodeLdap ldapUserMobile
+           -> NonEmpty UpsertUserData -- ^ Raw source data
-      userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer
+           -> m (User,_) -- ^ Data for new User entry and updating existing User entries
-      userCompanyDepartment     = decodeLdap ldapUserFraportAbteilung
+decodeUser now UserDefaultConf{..} upsertData = do
-
-      userAuthentication
-        | is _UpsertCampusUserLoginOther upsertMode
-                    = AuthNoLogin -- AuthPWHash (error "Non-LDAP logins should only work for users that are already known")
-        | otherwise = AuthLDAP
-      userLastAuthentication = guardOn isLogin now
-      isLogin = has (_UpsertCampusUserLoginLdap <> _UpsertCampusUserLoginOther . united) upsertMode
-
-      userTitle       = decodeLdap  ldapUserTitle     -- CampusUserInvalidTitle
-      userFirstName   = decodeLdap' ldapUserFirstName -- CampusUserInvalidGivenName
-      userSurname     = decodeLdap' ldapUserSurname   -- CampusUserInvalidSurname
-    userDisplayName <- decodeLdap1  ldapUserDisplayName  CampusUserInvalidDisplayName  <&> fixDisplayName -- do not check LDAP-given userDisplayName
-
-    --userDisplayName <- decodeLdap1 ldapUserDisplayName CampusUserInvalidDisplayName >>=
-    -- (maybeThrow CampusUserInvalidDisplayName . checkDisplayName userTitle userFirstName userSurname)
-
     userIdent <- if
-      | [bs] <- ldapMap !!! ldapUserPrincipalName
+      | Just azureData <- mbAzureData
-      , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs
+      , [(Text.decodeUtf8' -> Right azureUserPrincipalName')] <- azureData !!! azureUserPrincipalName
-      , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode
+      , Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName'
-        -> return userIdent'
+        -> return $ CI.mk azureUserPrincipalName''
-      | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent
+      | Just ldapData <- mbLdapData
-        -> return userIdent'
+      , [(Text.decodeUtf8' -> Right ldapPrimaryKey')] <- ldapData !!! ldapPrimaryKey
+      , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey'
+        -> return $ CI.mk ldapPrimaryKey''
       | otherwise
-        -> throwM CampusUserInvalidIdent
+        -> throwM DecodeUserInvalidIdent
-
-    userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E<number@fraport.de` here, too strong! Make Email-Field optional!
-      | userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-         -> return $ CI.mk userEmail
-      --   | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
-      --      -> return $ CI.mk userEmail
-      | otherwise
-        -> throwM CampusUserInvalidEmail
-        
-    userLdapPrimaryKey <- if
-      | [bs] <- ldapMap !!! ldapPrimaryKey
-      , Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
-      , Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-        -> return $ Just userLdapPrimaryKey'''
-      | otherwise
-        -> return Nothing
 
     let
+      (azureSurname, azureFirstName, azureDisplayName, azureEmail, azureTelephone, azureMobile, azureLanguages)
+        | Just azureData <- mbAzureData
+          = ( azureData `decodeAzure` azureUserSurname
+            , azureData `decodeAzure` azureUserGivenName
+            , azureData `decodeAzure` azureUserDisplayName
+            , azureData `decodeAzure` azureUserMail
+            , azureData `decodeAzure` azureUserTelephone
+            , azureData `decodeAzure` azureUserMobile
+            , Nothing -- azureData `decodeAzure` azureUserPreferredLanguage -- TODO: parse Languages from azureUserPreferredLanguage
+            )
+        | otherwise
+          = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
+
+      (ldapSurname, ldapFirstName, ldapDisplayName, ldapEmail, ldapTelephone, ldapMobile, ldapCompanyPersonalNumber, ldapCompanyDepartment)
+        | Just ldapData <- mbLdapData
+          = ( ldapData `decodeLdap` ldapUserSurname
+            , ldapData `decodeLdap` ldapUserFirstName
+            , ldapData `decodeLdap` ldapUserDisplayName
+            , ldapData `decodeLdap` (Ldap.Attr "mail") -- TODO: use ldapUserEmail?
+            , ldapData `decodeLdap` ldapUserTelephone
+            , ldapData `decodeLdap` ldapUserMobile
+            , ldapData `decodeLdap` ldapUserFraportPersonalnummer
+            , ldapData `decodeLdap` ldapUserFraportAbteilung
+            )
+        | otherwise
+          = ( Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing, Nothing )
+
+    -- TODO: throw on collisions?
+
+    -- TODO: use user-auth precedence from app config when implementing multi-source support
+    let
+      userSurname = fromMaybe mempty $ azureSurname <|> ldapSurname
+      userFirstName = fromMaybe mempty $ azureFirstName <|> ldapFirstName
+      userDisplayName = fromMaybe mempty $ azureDisplayName <|> ldapDisplayName
+      userEmail = maybe mempty CI.mk $ azureEmail <|> ldapEmail
+      userTelephone = azureTelephone <|> ldapTelephone
+      userMobile = azureMobile <|> ldapMobile
+      userLanguages = azureLanguages
+      userCompanyPersonalNumber = ldapCompanyPersonalNumber
+      userCompanyDepartment = ldapCompanyDepartment
+
       newUser = User
-        { userMaxFavourites           = userDefaultMaxFavourites
+        { userMaxFavourites         =  userDefaultMaxFavourites
-        , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
+        , userMaxFavouriteTerms     =  userDefaultMaxFavouriteTerms
-        , userTheme                   = userDefaultTheme
+        , userTheme                 =  userDefaultTheme
-        , userDateTimeFormat          = userDefaultDateTimeFormat
+        , userDateTimeFormat        =  userDefaultDateTimeFormat
-        , userDateFormat              = userDefaultDateFormat
+        , userDateFormat            =  userDefaultDateFormat
-        , userTimeFormat              = userDefaultTimeFormat
+        , userTimeFormat            =  userDefaultTimeFormat
-        , userDownloadFiles           = userDefaultDownloadFiles
+        , userDownloadFiles         =  userDefaultDownloadFiles
-        , userWarningDays             = userDefaultWarningDays
+        , userWarningDays           =  userDefaultWarningDays
-        , userShowSex                 = userDefaultShowSex
+        , userShowSex               =  userDefaultShowSex
-        , userSex                     = Nothing
+        , userSex                   =  Nothing
-        , userBirthday                = Nothing
+        , userBirthday              =  Nothing
-        , userExamOfficeGetSynced     = userDefaultExamOfficeGetSynced
+        , userTitle                 =  Nothing
-        , userExamOfficeGetLabels     = userDefaultExamOfficeGetLabels
+        , userExamOfficeGetSynced   =  userDefaultExamOfficeGetSynced
-        , userNotificationSettings    = def
+        , userExamOfficeGetLabels   =  userDefaultExamOfficeGetLabels
-        , userLanguages               = Nothing
+        , userNotificationSettings  =  def
-        , userCsvOptions              = def
+        , userCsvOptions            =  def
-        , userTokensIssuedAfter       = Nothing
+        , userTokensIssuedAfter     =  Nothing
-        , userCreated                 = now
+        , userDisplayEmail          =  userEmail
-        , userLastLdapSynchronisation = Just now
+        , userMatrikelnummer        =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
-        , userDisplayName             = userDisplayName
+        , userPostAddress           =  Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS
-        , userDisplayEmail            = userEmail
+        , userPostLastUpdate        =  Nothing
-        , userMatrikelnummer          = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+        , userPinPassword           =  Nothing -- must be derived via AVS
-        , userPostAddress             = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO
+        , userPrefersPostal         =  userDefaultPrefersPostal
-        , userPostLastUpdate          = Nothing
+        , userPasswordHash          =  Nothing
-        , userPinPassword             = Nothing -- must be derived via AVS
+        , userLastAuthentication    =  Nothing
-        , userPrefersPostal           = userDefaultPrefersPostal
+        , userCreated               =  now
+        , userLastSync              =  Just now
         , ..
         }
       userUpdate =
-        [ UserLastAuthentication      =. Just now  | isLogin ] ++
+        [ UserSurname               =. userSurname
-        [ UserEmail                   =. userEmail | validEmail' userEmail ] ++
+        , UserFirstName             =. userFirstName
-        [
+     -- , UserDisplayName           =. userDisplayName -- not updated, since users are allowed to change their DisplayName
-        -- UserDisplayName             =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272
+        , UserEmail                 =. userEmail
-          UserFirstName               =. userFirstName
+        , UserTelephone             =. userTelephone
-        , UserSurname                 =. userSurname                    
+        , UserMobile                =. userMobile
-        , UserLastLdapSynchronisation =. Just now
+        , UserCompanyPersonalNumber =. userCompanyPersonalNumber
-        , UserLdapPrimaryKey          =. userLdapPrimaryKey
+        , UserCompanyDepartment     =. userCompanyDepartment
-        , UserMobile                  =. userMobile
+        , UserLastSync              =. Just now
-        , UserTelephone               =. userTelephone
-        , UserCompanyPersonalNumber   =. userCompanyPersonalNumber
-        , UserCompanyDepartment       =. userCompanyDepartment
         ]
     return (newUser, userUpdate)
 
   where
-    ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString
+    mbAzureData :: Maybe (Map Text [ByteString])
-    ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null))
+    mbAzureData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData
+    mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString
+    mbLdapData = fmap (Map.fromListWith (++) . map (\(t,bs) -> (t, filter (not . ByteString.null) bs))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData
 
     -- just returns Nothing on error, pure
-    decodeLdap :: Ldap.Attr -> Maybe Text
+    decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text
-    decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr
+    decodeAzure azureData k = listToMaybe . rights $ Text.decodeUtf8' <$> azureData !!! k
+    decodeLdap :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Maybe Text
+    decodeLdap ldapData attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapData !!! attr
 
-    decodeLdap' :: Ldap.Attr -> Text
+    -- decodeAzure' :: Map Text [ByteString] -> Text -> Text
-    decodeLdap' = fromMaybe "" . decodeLdap
+    -- decodeAzure' azureData = fromMaybe "" . decodeAzure azureData
+    -- decodeLdap' :: Map Ldap.Attr [Ldap.AttrValue] -> Ldap.Attr -> Text
+    -- decodeLdap' ldapData = fromMaybe "" . decodeLdap ldapData
     -- accept the first successful decoding or empty; only throw an error if all decodings fail
     -- decodeLdap' :: (Exception e) => Ldap.Attr -> e -> m (Maybe Text)
     -- decodeLdap' attr err
@@ -462,11 +413,11 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
 
     -- only accepts the first successful decoding, ignoring all others, but failing if there is none
     -- decodeLdap1 :: (MonadThrow m, Exception e) => Ldap.Attr -> e -> m Text
-    decodeLdap1 attr err
+    -- decodeLdap1 ldapData attr err
-        | (h:_) <- rights vs  = return h
+    --     | (h:_) <- rights vs  = return h
-        | otherwise           = throwM err
+    --     | otherwise           = throwM err
-      where
+    --   where
-        vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
+    --     vs = Text.decodeUtf8' <$> (ldapData !!! attr)
 
     -- accept and merge one or more successful decodings, ignoring all others
     -- decodeLdapN attr err
@@ -476,6 +427,17 @@ decodeUser now UserDefaultConf{..} upsertMode ldapData = do
     --   where
     --     vs = Text.decodeUtf8' <$> (ldapMap !!! attr)
 
+decodeUserTest :: ( MonadHandler m
+                  , HandlerSite m ~ UniWorX
+                  , MonadCatch m
+                  )
+               => NonEmpty UpsertUserData
+               -> m (Either DecodeUserException (User, [Update User]))
+decodeUserTest decodeData = do
+  now <- liftIO getCurrentTime
+  userDefaultConf <- getsYesod $ view _appUserDefaults
+  try $ decodeUser now userDefaultConf decodeData
+
 
 associateUserSchoolsByTerms :: MonadIO m => UserId -> SqlPersistT m ()
 associateUserSchoolsByTerms uid = do
@@ -490,11 +452,14 @@ associateUserSchoolsByTerms uid = do
         , userSchoolIsOptOut = False
         }
 
-updateUserLanguage :: ( MonadHandler m, HandlerSite m ~ UniWorX
+
+updateUserLanguage :: ( MonadHandler m
+                      , HandlerSite m ~ UniWorX
                       , YesodAuth UniWorX
                       , UserId ~ AuthId UniWorX
                       )
-                   => Maybe Lang -> SqlPersistT m (Maybe Lang)
+                   => Maybe Lang
+                   -> SqlPersistT m (Maybe Lang)
 updateUserLanguage (Just lang) = do
   unless (lang `elem` appLanguages) $
     invalidArgs ["Unsupported language"]
@@ -525,7 +490,4 @@ updateUserLanguage Nothing = runMaybeT $ do
   setRegisteredCookie CookieLang lang
   return lang
 
-campusUserFailoverMode :: FailoverMode
+embedRenderMessage ''UniWorX ''DecodeUserException id
-campusUserFailoverMode = FailoverUnlimited
-
-embedRenderMessage ''UniWorX ''CampusUserConversionException id

src/Foundation/Yesod/ErrorHandler.hs

@@ -9,9 +9,9 @@ module Foundation.Yesod.ErrorHandler
 import Import.NoFoundation hiding (errorHandler)
 
 import Foundation.Type
--- import Foundation.I18n
+import Foundation.I18n
 import Foundation.Authorization
--- import Foundation.SiteLayout
+import Foundation.SiteLayout
 import Foundation.Routes
 import Foundation.DB
 
@@ -20,15 +20,15 @@ import qualified Data.Text as Text
 
 import qualified Network.Wai as W
   
--- import System.Exit -- DEBUG: just for testing
+import System.Exit -- DEBUG: just for testing
--- import System.Posix.Process -- DEBUG: just for testing
+import System.Posix.Process -- DEBUG: just for testing
 
 errorHandler :: ( MonadSecretBox (HandlerFor UniWorX)
-                -- , MonadSecretBox (WidgetFor UniWorX)
+                , MonadSecretBox (WidgetFor UniWorX)
                 , MonadSecretBox (ExceptT EncodedSecretBoxException (HandlerFor UniWorX))
                 , MonadAuth (HandlerFor UniWorX)
                 , BearerAuthSite UniWorX
-                -- , YesodPersistBackend UniWorX ~ SqlBackend
+                , YesodPersistBackend UniWorX ~ SqlBackend
                 )
              => ErrorResponse -> HandlerFor UniWorX TypedContent
 errorHandler err = do
@@ -72,39 +72,39 @@ errorHandler err = do
   setSessionJson SessionError sessErr
 
   selectRep $ do
-    -- provideRep $ do
+    provideRep $ do
-    --   mr <- getMessageRender
+      mr <- getMessageRender
-    --   let
+      let
-    --     encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
+        encrypted :: Text -> WidgetFor UniWorX () -> WidgetFor UniWorX ()
-    --     encrypted plaintextJson plaintext = do
+        encrypted plaintextJson plaintext = do
-    --       let displayEncrypted ciphertext = 
+          let displayEncrypted ciphertext = 
-    --             [whamlet|
+                [whamlet|
-    --               $newline never
+                  $newline never
-    --               <p>_{MsgErrorResponseEncrypted}
+                  <p>_{MsgErrorResponseEncrypted}
-    --               <pre .literal-error>
+                  <pre .literal-error>
-    --                 #{ciphertext}
+                    #{ciphertext}
-    --             |]
+                |]
-    --       if
+          if
-    --         | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
+            | isEncrypted && shouldEncrypt -> displayEncrypted plaintextJson
-    --         | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
+            | shouldEncrypt -> displayEncrypted =<< encodedSecretBox SecretBoxPretty plaintextJson
-    --         | otherwise -> plaintext
+            | otherwise -> plaintext
 
-    --     errPage = case err of
+        errPage = case err of
-    --       NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
+          NotFound -> [whamlet|<p>_{MsgErrorResponseNotFound}|]
-    --       InternalError err'
+          InternalError err'
-    --         | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
+            | "Crash Button" `isPrefixOf` err'   -> liftIO $ exitImmediately ExitSuccess -- DEBUG: just for Testing
-    --         | otherwise -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
+            | otherwise -> encrypted err' [whamlet|<p .literal-error>#{fromMaybe err' decrypted}|]
-    --       InvalidArgs errs -> [whamlet|
+          InvalidArgs errs -> [whamlet|
-    --           <ul>
+              <ul>
-    --             $forall err' <- errs
+                $forall err' <- errs
-    --               <li .literal-error>
+                  <li .literal-error>
-    --                 #{err'}
+                    #{err'}
-    --          |]
+             |]
-    --       NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
+          NotAuthenticated -> [whamlet|<p>_{MsgErrorResponseNotAuthenticated}|]
-    --       PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
+          PermissionDenied err' -> [whamlet|<p .errMsg>#{err'}|]
-    --       BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
+          BadMethod method -> [whamlet|<p>_{MsgErrorResponseBadMethod (decodeUtf8 method)}|]
-    --   siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
+      siteLayout (toWgt . mr $ ErrorResponseTitle err) $ do
-    --     errPage
+        errPage
     provideRep $ case err of
       PermissionDenied err' -> return err'
       InternalError err'

src/Handler/Admin.hs

@@ -1,4 +1,4 @@
--- 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-FileCopyrightText: 2022-2024 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
 
@@ -30,8 +30,7 @@ import Handler.Admin.ErrorMessage as Handler.Admin
 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.ExternalUser as Handler.Admin
-import Handler.Admin.OAuth2 as Handler.Admin
 
 
 getAdminR :: Handler Html

src/Handler/Admin/ExternalUser.hs

@@ -0,0 +1,74 @@
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Handler.Admin.ExternalUser
+  ( getAdminExternalUserR
+  , postAdminExternalUserR
+  ) where
+
+import Import
+
+import Foundation.Yesod.Auth (userLookupAndUpsert) -- decodeUserTest
+import Auth.OAuth2 (queryOAuth2User)
+import Auth.LDAP
+
+import Handler.Utils
+
+import Data.Aeson.Encode.Pretty (encodePretty)
+import qualified Data.Text.Lazy as Lazy
+import qualified Data.Text.Lazy.Encoding as Lazy
+
+
+getAdminExternalUserR,  postAdminExternalUserR :: Handler Html
+getAdminExternalUserR = postAdminExternalUserR
+postAdminExternalUserR = do
+  ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminExternalUserLookup"::Text) $ \html -> 
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
+
+  let
+    -- presentUtf8   v = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> v)
+    -- presentLatin1 v = Text.intercalate ", " (                 Text.decodeLatin1 <$> v)
+
+    procFormPerson :: Text -> Handler (Maybe [(AuthSourceIdent,Lazy.Text)]) -- (Maybe [(AuthSourceIdent, [(Text,(Int,Text,Text))])])
+    procFormPerson needle = getsYesod (view _appUserAuthConf) >>= \case
+      UserAuthConfSingleSource{..} -> case userAuthConfSingleSource of
+        AuthSourceConfAzureAdV2 AzureConf{..} -> do
+          -- only singleton results supported right now, i.e. lookups by email, userPrincipalName (aka fraport ident), or id
+          queryOAuth2User @Value needle >>= \case
+            Left _ -> addMessage Error (text2Html "Encountered UserDataException while Azure user query!") >> return Nothing
+            Right azureResponse -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) . Lazy.decodeUtf8 $ encodePretty azureResponse
+            -- Right azureData -> return . Just . singleton . (AuthSourceIdAzure azureConfTenantId,) $ azureData <&> \(k,vs) -> (k, (length vs, presentUtf8 vs, presentLatin1 vs))
+        AuthSourceConfLdap LdapConf{..} -> do
+          getsYesod (view _appLdapPool) >>= \case
+            Nothing -> addMessage Error (text2Html "LDAP Pool configuration missing!") >> return Nothing
+            Just pool -> do
+              ldapData <- ldapSearch pool needle
+              -- decodedErr <- decodeUserTest $ NonEmpty.singleton UpsertUserDataLdap{ upsertUserLdapHost = ldapConfSourceId, upsertUserLdapData = concat ldapData }
+              -- whenIsLeft decodedErr $ addMessageI Error
+              return . Just . singleton . (AuthSourceIdLdap ldapConfSourceId,) . Lazy.decodeUtf8 $ encodePretty ldapData
+              -- return . Just $ ldapData <&> \(Ldap.SearchEntry _dn attrs) -> (AuthSourceIdLdap{..}, (\(k,v) -> (tshow k, (length v, presentUtf8 v, presentLatin1 v))) <$> attrs)
+
+  mbData <- formResultMaybe presult procFormPerson
+
+
+  ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminExternalUserUpsert"::Text) $ \html -> 
+    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
+  let procFormUpsert :: Text -> Handler (Maybe (Entity User))
+      procFormUpsert lid = runDB (userLookupAndUpsert lid UpsertUserGuessUser)
+
+  mbUpsert <- formResultMaybe uresult procFormUpsert
+
+
+  actionUrl <- fromMaybe AdminExternalUserR <$> getCurrentRoute
+  siteLayoutMsg MsgMenuExternalUser $ do
+    setTitleI MsgMenuExternalUser
+    let personForm = wrapForm pwidget def
+                      { formAction = Just $ SomeRoute actionUrl
+                      , formEncoding = penctype
+                      }
+        upsertForm = wrapForm uwidget def 
+                      { formAction = Just $ SomeRoute actionUrl
+                      , formEncoding = uenctype
+                      }
+    $(widgetFile "admin/external-user")

src/Handler/Admin/Ldap.hs

@@ -1,69 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-
-
-module Handler.Admin.Ldap
-  ( getAdminLdapR
-  , postAdminLdapR
-  ) where
-
-import Import
--- import qualified Control.Monad.State.Class as State
--- import Data.Aeson (encode)
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
--- import qualified Data.Set  as Set
-import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException())
-import Handler.Utils
-
-import qualified Ldap.Client as Ldap
-import Auth.LDAP
-
-
-getAdminLdapR,  postAdminLdapR :: Handler Html
-getAdminLdapR = postAdminLdapR
-postAdminLdapR = do
-  ((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html -> 
-    flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
-
-  let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
-      procFormPerson lid = do
-        ldapPool' <- getsYesod $ view _appLdapPool
-        case ldapPool' of 
-          Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
-          Just ldapPool -> do 
-            addMessage Info  $ text2Html "Input for LDAP test received."
-            ldapData <- campusUser'' ldapPool campusUserFailoverMode lid                      
-            decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
-            whenIsLeft decodedErr $ addMessageI Error
-            return ldapData
-  mbLdapData <- formResultMaybe presult procFormPerson
-
-
-  ((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::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 AdminLdapR <$> getCurrentRoute
-  siteLayoutMsg MsgMenuLdap $ do
-    setTitleI MsgMenuLdap
-    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 "ldap")
-

src/Handler/Admin/OAuth2.hs

@@ -1,59 +0,0 @@
--- 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/Admin/Test.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-2024 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
 
@@ -321,8 +321,8 @@ postAdminTestR = do
         <dl .deflist>
           <dt .deflist__dt>        appJobCronInterval
           <dd .deflist__dd>#{tshow appJobCronInterval}
-          <dt .deflist__dt>        appSynchroniseLdapUsersWithin
+          <dt .deflist__dt>        appUserSyncWithin
-          <dd .deflist__dd>#{tshow appSynchroniseLdapUsersWithin}
+          <dd .deflist__dd>#{tshow appUserSyncWithin}
           <dt .deflist__dt>        appSynchroniseAvsUsersWithin
           <dd .deflist__dd>#{tshow appSynchroniseAvsUsersWithin}
     |]

src/Handler/Course/Users.hs

@@ -204,7 +204,6 @@ data UserTableCsv = UserTableCsv
   , csvUserSex :: Maybe Sex
   , csvUserBirthday :: Maybe Day
   , csvUserMatriculation :: Maybe UserMatriculation
-  , csvUserEPPN :: Maybe UserEduPersonPrincipalName
   , csvUserEmail :: UserEmail
   , csvUserQualifications :: [QualificationName]
   , csvUserSubmissionGroup :: Maybe SubmissionGroupName
@@ -224,7 +223,6 @@ instance Csv.ToNamedRecord UserTableCsv where
     , "sex" Csv..= csvUserSex
     , "birthday" Csv..= csvUserBirthday
     , "matriculation" Csv..= csvUserMatriculation
-    , "eduPersonPrincipalName" Csv..= csvUserEPPN
     , "email" Csv..= csvUserEmail
     , "qualifications" Csv..= CsvSemicolonList csvUserQualifications
     , "submission-group" Csv..= csvUserSubmissionGroup
@@ -286,7 +284,6 @@ data UserTableJson = UserTableJson
   , jsonUserName :: UserDisplayName
   , jsonUserSex :: Maybe (Maybe Sex)
   , jsonUserMatriculation :: Maybe UserMatriculation
-  , jsonUserEPPN :: Maybe UserEduPersonPrincipalName
   , jsonUserEmail :: UserEmail
   , jsonUserQualifications :: Set QualificationName
   , jsonUserSubmissionGroup :: Maybe SubmissionGroupName
@@ -323,7 +320,6 @@ instance ToJSON UserTableJson where
     , pure $ "name" JSON..= jsonUserName
     , ("sex" JSON..=) <$> jsonUserSex
     , ("matriculation" JSON..=) <$> jsonUserMatriculation
-    , ("eduPersonPrincipalName" JSON..=) <$> jsonUserEPPN
     , pure $ "email" JSON..= jsonUserEmail
     , ("qualifications" JSON..=) <$> assertM' (not . onull) jsonUserQualifications
     , ("submission-group" JSON..=) <$> jsonUserSubmissionGroup
@@ -566,7 +562,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
                   <*> view (hasUser . _userSex)
                   <*> view (hasUser . _userBirthday)
                   <*> view (hasUser . _userMatrikelnummer)
-                  <*> view (hasUser . _userLdapPrimaryKey)
                   <*> view (hasUser . _userEmail)
                   <*> (over traverse (qualificationName . entityVal) <$> view _userQualifications)
                   <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)
@@ -598,7 +593,6 @@ makeCourseUserTable cid acts restrict colChoices psValidator csvColumns = do
               <*> view  (hasUser . _userDisplayName)
               <*> views (hasUser . _userSex) (guardOn showSex)
               <*> view  (hasUser . _userMatrikelnummer)
-              <*> view  (hasUser . _userLdapPrimaryKey)
               <*> view  (hasUser . _userEmail)
               <*> view (_userQualifications . folded . to (Set.singleton . qualificationName . entityVal))
               <*> preview (_userSubmissionGroup . _entityVal . _submissionGroupName)

src/Handler/Exam/Users.hs

@@ -187,7 +187,6 @@ data ExamUserTableCsv = ExamUserTableCsv
   , csvEUserFirstName :: Maybe Text
   , csvEUserName :: Maybe Text
   , csvEUserMatriculation :: Maybe Text
-  , csvEUserEPPN :: Maybe UserEduPersonPrincipalName
   , csvEUserStudyFeatures :: UserTableStudyFeatures
   , csvEUserOccurrence :: Maybe (CI Text)
   , csvEUserExercisePoints :: Maybe (Maybe Points)
@@ -208,7 +207,6 @@ instance ToNamedRecord ExamUserTableCsv where
     , "first-name" Csv..= csvEUserFirstName
     , "name" Csv..= csvEUserName
     , "matriculation" Csv..= csvEUserMatriculation
-    , "eduPersonPrincipalName" Csv..= csvEUserEPPN
     , "study-features" Csv..= csvEUserStudyFeatures
     , "occurrence" Csv..= csvEUserOccurrence
     ] ++ catMaybes
@@ -234,7 +232,6 @@ instance FromNamedRecord ExamUserTableCsv where
       <*> csv .:?? "first-name"
       <*> csv .:?? "name"
       <*> csv .:?? "matriculation"
-      <*> csv .:?? "eduPersonPrincipalName"
       <*> pure mempty
       <*> csv .:?? "occurrence"
       <*> fmap Just (csv .:?? "exercise-points")
@@ -277,7 +274,7 @@ examUserTableCsvHeader :: ( MonoFoldable mono
                        => SheetGradeSummary -> Bool -> mono -> Csv.Header
 examUserTableCsvHeader allBoni doBonus pNames = Csv.header $
   [ "surname", "first-name", "name"
-  , "matriculation", "eduPersonPrincipalName"
+  , "matriculation"
   , "study-features"
   , "course-note"
   , "occurrence"
@@ -615,7 +612,6 @@ postEUsersR tid ssh csh examn = do
                 <*> view (resultUser . _entityVal . _userFirstName . to Just)
                 <*> view (resultUser . _entityVal . _userDisplayName . to Just)
                 <*> view (resultUser . _entityVal . _userMatrikelnummer)
-                <*> view (resultUser . _entityVal . _userLdapPrimaryKey)
                 <*> view resultStudyFeatures
                 <*> preview (resultExamOccurrence . _entityVal . _examOccurrenceName)
                 <*> fmap (bool (const Nothing) Just showPoints) (preview $ resultUser . _entityKey . to (examBonusAchieved ?? bonus) . _achievedPoints . _Wrapped)
@@ -939,7 +935,6 @@ postEUsersR tid ssh csh examn = do
               guessUser' ExamUserTableCsv{..} = do
                 let criteria = PredDNF . maybe Set.empty Set.singleton . fromNullable . Set.fromList . fmap PLVariable $ catMaybes
                       [ GuessUserMatrikelnummer <$> csvEUserMatriculation
-                      , GuessUserEduPersonPrincipalName <$> csvEUserEPPN
                       , GuessUserDisplayName <$> csvEUserName
                       , GuessUserSurname <$> csvEUserSurname
                       , GuessUserFirstName <$> csvEUserFirstName

src/Handler/Firm.hs

@@ -248,7 +248,7 @@ addDefaultSupervisors cid employees = do
       (spr :& usr) <- E.from $ E.table @UserCompany `E.crossJoin` E.toValues employees
       E.where_ $ spr E.^. UserCompanyCompany E.==. E.val cid
           E.&&.  spr E.^. UserCompanySupervisor
-      return $ UserSupervisor
+      E.distinct $ return $ UserSupervisor
         E.<#  (spr E.^. UserCompanyUser)
         E.<&>  usr
         E.<&> (spr E.^. UserCompanySupervisorReroute)
@@ -272,7 +272,7 @@ addDefaultSupervisorsFor mbSuperId mutualSupervision cids = do
                             , spr E.^. UserCompanyCompany `E.in_` E.vals cids
                             , usr E.^. UserCompanyCompany `E.in_` E.vals cids
                             ]
-      return $ UserSupervisor
+      E.distinct $ return $ UserSupervisor
         E.<#  (spr E.^. UserCompanyUser)
         E.<&> (usr E.^. UserCompanyUser)
         E.<&> (spr E.^. UserCompanySupervisorReroute)
@@ -291,7 +291,7 @@ addDefaultSupervisorsAll mutualSupervision cids = do
                             , spr E.^. UserCompanyCompany `E.in_` E.vals cids
                             , usr E.^. UserCompanyCompany `E.in_` E.vals cids
                             ]
-      return $ UserSupervisor
+      E.distinct $ return $ UserSupervisor
         E.<#  (spr E.^. UserCompanyUser)
         E.<&> (usr E.^. UserCompanyUser)
         E.<&> (spr E.^. UserCompanySupervisorReroute)
@@ -468,7 +468,7 @@ mkFirmAllTable isAdmin uid = do
                   -- , cmpy & firmCountActiveReroutes'             -- 10
                   )
         dbtRowKey = (E.^. CompanyId)
-        dbtProj = dbtProjId
+        dbtProj = dbtProjFilteredPostId
         dbtColonnade = formColonnade $ mconcat
           [ dbSelect (applying _2) id (return . view (resultAllCompanyEntity . _entityKey))
           , sortable (Just "name")          (i18nCell MsgTableCompany)                 $ \(view resultAllCompany -> firm) ->
@@ -517,24 +517,136 @@ mkFirmAllTable isAdmin uid = do
                   E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val criterion)
                 )
             )
-          , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
+          -- THIS WAS WAY TOO SLOW:
+          -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
+          --     (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 ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
+          --     usr <- E.from $ E.table @User
+          --     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.exists (do
+          --             usrCmp <- E.from $ E.table @UserCompany
+          --             E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
+          --               E.&&. usrCmp E.^. UserCompanySupervisor
+          --               E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
+          --           ) E.||. E.exists (do
+          --             usrSpr <- E.from $ E.table @UserSupervisor
+          --             E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
+          --               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 ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  --  too slow
+          --     usr <- E.from $ E.table @User
+          --     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.exists (do
+          --             usrCmp <- E.from $ E.table @UserCompany
+          --             E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
+          --               E.&&. (( usrCmp E.^. UserCompanySupervisor
+          --                 E.&&.  usrCmp E.^. UserCompanyUser              E.==. usr E.^. UserId
+          --               ) E.||. E.exists (do
+          --                 usrSpr <- E.from $ E.table @UserSupervisor
+          --                 E.where_ $ usrSpr E.^. UserSupervisorUser       E.==. usrCmp E.^. UserCompanyUser
+          --                     E.&&.  usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
+          --               ))
+          --       )
+          --   )
+          -- , single ("is-supervisor", FilterColumn $ \row (getLast -> criterion) -> 
+          --     case criterion of
+          --       Nothing -> E.true
+          --       (Just (crit::Text)) -> E.exists $ do
+          --             usr <- E.from $ E.table @User
+          --             E.where_ $ ((usr E.^. UserDisplayName  `E.hasInfix` E.val crit)
+          --                   E.||. (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
+          --                   E.||. (usr E.^. UserSurname      `E.hasInfix` E.val crit)
+          --               ) E.&&. E.exists (do
+          --                     usrCmp <- E.from $ E.table @UserCompany
+          --                     E.where_ $ usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
+          --                       E.&&. (( usrCmp E.^. UserCompanySupervisor
+          --                         E.&&.  usrCmp E.^. UserCompanyUser              E.==. usr E.^. UserId
+          --                       ) E.||. E.exists (do
+          --                         usrSpr <- E.from $ E.table @UserSupervisor
+          --                         E.where_ $ usrSpr E.^. UserSupervisorUser       E.==. usrCmp E.^. UserCompanyUser
+          --                             E.&&.  usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
+          --                       ))
+          --               )
+          --   )
+          , single ("is-supervisor", mkFilterProjectedPost $ \(getLast -> criterion) dbr -> 
+              case criterion of
+                Nothing -> return True :: DB Bool
+                (Just (crit::Text)) -> do
+                  critFirms <- memcachedBy (Just . Right $ 5 * diffMinute) ("svr:"<>crit) $ fmap (Set.fromAscList . fmap E.unValue) $ E.select $ E.distinct $ do
+                    (usr :& cmp) <- E.from  $ E.table @User `E.innerJoin` E.table @Company
+                      `E.on` (\(usr :& cmp) -> E.exists (do
+                        usrCmp <- E.from $ E.table @UserCompany
+                        E.where_ $ usr E.^. UserId E.==. usrCmp E.^. UserCompanyUser
+                          E.&&. usrCmp E.^. UserCompanySupervisor
+                          E.&&. usrCmp E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
+                      ) E.||. E.exists (do
+                        usrSpr <- E.from $ E.table @UserSupervisor
+                        E.where_ $ usr E.^. UserId E.==. usrSpr E.^. UserSupervisorSupervisor
+                          E.&&. E.exists (do
+                            usrSub <- E.from $ E.table @UserCompany
+                            E.where_ $ usrSub E.^. UserCompanyUser    E.==. usrSpr E.^. UserSupervisorUser
+                                E.&&.  usrSub E.^. UserCompanyCompany E.==. cmp E.^. CompanyId
+                          )
+                      ))
+                    E.where_ $ (usr E.^. UserDisplayName  `E.hasInfix` E.val crit)
+                        E.||.  (usr E.^. UserDisplayEmail `E.hasInfix` E.val (CI.mk crit))
+                        E.||.  (usr E.^. UserSurname      `E.hasInfix` E.val crit)
+                    E.orderBy [E.asc $ cmp E.^. CompanyId]
+                    return $ cmp E.^. CompanyId
+                  let cid = dbr ^. resultAllCompanyEntity . _entityKey
+                  return $ Set.member cid critFirms
+            )
+          -- , single ("is-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do  -- too slow
+          --     (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 :& usrSub) <- E.from $ E.table @UserSupervisor `E.innerJoin` E.table @UserCompany `E.on` (\(usrSpr :& usrSub) -> usrSpr E.^. UserSupervisorUser E.==.  usrSub E.^. UserCompanyUser)
+          --               E.where_ $ usrSpr E.^. UserSupervisorSupervisor E.==. usr E.^. UserId
+          --                 E.&&.    usrSub E.^. UserCompanyCompany       E.==. queryAllCompany row E.^. CompanyId
+          --             )
+          --       )
+          --   )
+          , single ("is-default-supervisor" , FilterColumn . E.mkExistsFilter $ \row (criterion :: Text) -> do
               (usr :& usrCmp) <- E.from $ E.table @User
-                `E.leftJoin` E.table @UserCompany
+                `E.innerJoin` E.table @UserCompany
-                `E.on` (\(usr :& usrCmp) -> usr E.^. UserId E.=?. usrCmp E.?. UserCompanyUser)
+                `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.&&. usrCmp E.^. UserCompanySupervisor
-                    E.||. E.exists (do
+                  E.&&. usrCmp E.^. UserCompanyCompany E.==. queryAllCompany row E.^. CompanyId
-                        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
@@ -570,8 +682,10 @@ mkFirmAllTable isAdmin uid = do
         dbtFilterUI mPrev = mconcat
           [ 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 "is-supervisor0")                             mPrev $ aopt textField (fslI MsgTableSupervisor)
+          , prismAForm (singletonFilter "is-supervisor")                              mPrev $ aopt textField (fslI MsgTableSupervisor)
+          , prismAForm (singletonFilter "is-default-supervisor")                      mPrev $ aopt textField (fslI MsgFirmSuperDefault)
           , 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)
           ]

src/Handler/LMS/Fake.hs

@@ -67,7 +67,7 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
         let pw = "123.456"
         PWHashConf{..} <- getsYesod $ view _appAuthPWHash
         pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
-        return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
+        return $ TEnc.decodeUtf8 pwHash
     theSupervisor <- selectKeysList [UserSurname ==. "Jost", UserFirstName ==. "Steffen"] [Asc UserCreated, LimitTo 1]
     let addSupervisor = case theSupervisor of 
           [s] -> \suid k -> case k of 
@@ -83,15 +83,14 @@ fakeQualificationUsers (Entity qid Qualification{qualificationRefreshWithin}) (u
         fakeUser :: ([Text], UserSurname, (Maybe Languages, DateTimeFormat, DateTimeFormat, DateTimeFormat), Bool, Int) -> User
         fakeUser (firstNames, userSurname, (userLanguages, userDateTimeFormat, userDateFormat, userTimeFormat), userPrefersPostal, _isSupervised) =
           let userIdent = CI.mk $ Text.intercalate "." (take 1 firstNames ++ (Text.take 1 <$> drop 1 firstNames) ++ [userSurname]) <> "@example.com"
+              userPasswordHash = Just pwSimple
+              userLastAuthentication = Nothing
               userEmail = userIdent
               userDisplayEmail = userIdent
               userDisplayName = Text.unwords $ firstNames <> [userSurname]
               userMatrikelnummer = Just "TESTUSER"
-              userAuthentication = pwSimple
-              userLastAuthentication = Nothing
               userCreated = now
-              userLastLdapSynchronisation = Nothing
+              userLastSync = Just now
-              userLdapPrimaryKey = Nothing
               userTokensIssuedAfter = Nothing
               userFirstName = Text.unwords firstNames
               userTitle = Nothing

src/Handler/Profile.hs

@@ -584,6 +584,8 @@ makeProfileData :: Entity User -> DB Widget
 makeProfileData (Entity uid User{..}) = do
   now <- liftIO getCurrentTime
   avsId <- entityVal <<$>> getBy (UniqueUserAvsUser uid)
+  externalUsers <- (\(Entity _ ExternalUser{..}) -> (externalUserUser, externalUserSource, externalUserLastSync)) <<$>> selectList [ ExternalUserUser ==. userIdent ] []
+
   -- avsCards <- maybe (pure mempty) (\a -> selectList [UserAvsCardPersonId ==. userAvsPersonId a] []) avsId
   functions <- Map.fromListWith Set.union . map (\(Entity _ UserFunction{..}) -> (userFunctionFunction, Set.singleton userFunctionSchool)) <$> selectList [UserFunctionUser ==. uid] []
   lecture_corrector <- E.select $ E.distinct $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do

src/Handler/SAP.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -17,11 +17,9 @@ 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 ((:&)(..))
 import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
--- import qualified Database.Esqueleto.Legacy as E
 import qualified Database.Esqueleto.PostgreSQL as E
 import qualified Database.Esqueleto.Utils as E
 
@@ -97,7 +95,15 @@ getQualificationSAPDirectR :: Handler TypedContent
 getQualificationSAPDirectR = do
   now   <- liftIO getCurrentTime  
   fdate <- formatTime' "%Y%m%d_%H-%M" now
-  let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now
+  userAuthConf <- getsYesod $ view _appUserAuthConf
+
+  let
+    ldapSources = case userAuthConf of
+      UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
+        -> singleton $ AuthSourceIdLdap ldapConfSourceId
+      _other -> mempty
+    ldapCutoff = addDiffDaysRollOver (fromMonths $ -3) now
+
   qualUsers <- runDB $ E.select $ do
     (qual :& qualUser :& user :& qualBlock) <- 
       E.from $ E.table @Qualification 
@@ -111,9 +117,12 @@ getQualificationSAPDirectR = do
           E.&&.   E.val now                         E.>~. qualBlock E.?. QualificationUserBlockFrom
         )
     E.where_ $ E.isJust (qual E.^. QualificationSapId)
-        E.&&.  E.isJust (user E.^. UserCompanyPersonalNumber)
+         E.&&. E.isJust (user E.^. UserCompanyPersonalNumber)
-        E.&&.  E.isJust (user E.^. UserLastLdapSynchronisation)
+    E.where_ . E.exists $ do
-        E.&&.  (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation)
+      externalUser <- E.from $ E.table @ExternalUser
+      E.where_ $ externalUser E.^. ExternalUserUser     E.==.  user E.^. UserIdent
+           E.&&. externalUser E.^. ExternalUserSource  `E.in_` E.valList ldapSources
+           E.&&. externalUser E.^. ExternalUserLastSync E.>=.  E.val ldapCutoff
     E.groupBy ( user      E.^. UserCompanyPersonalNumber
               , qualUser  E.^. QualificationUserFirstHeld
               , qualUser  E.^. QualificationUserValidUntil                

src/Handler/Users.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -11,14 +11,11 @@ module Handler.Users
 import Import
 
 import Jobs
--- import Data.Text
 import Handler.Utils
 import Handler.Utils.Users
 import Handler.Utils.Invitations
 import Handler.Utils.Avs
 
-import qualified Auth.LDAP as Auth
-
 import qualified Data.CaseInsensitive as CI
 
 import qualified Data.Set as Set
@@ -35,8 +32,6 @@ import qualified Data.ByteString.Base64 as Base64
 
 import Data.Aeson hiding (Result(..))
 
--- import Handler.Users.Add as Handler.Users
-
 import qualified Data.Conduit.List as C
 
 import qualified Data.HashSet as HashSet
@@ -129,8 +124,9 @@ postUsersR = do
                   (\(usr, E.Value reroutCom) -> linkUserWidget ForProfileDataR usr <> bool mempty icnReroute reroutCom) <$> supervisors'
                 icnReroute = text2widget " " <> toWgt (icon IconLetter)
             pure $ mconcat supervisors
-      , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication
+      , sortable (Just "last-login") (i18nCell MsgLastLogin)  $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication
-      , sortable (Just "ldap-sync") (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation
+      -- , sortable (Just "auth-ldap")  (i18nCell MsgAuthMode)   $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication -- TODO: reintroduce via ExternalUser
+      -- , sortable (Just "ldap-sync")  (i18nCell MsgLdapSynced) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastLdapSynchronisation -- TODO: reintroduce via ExternalUser
       , flip foldMap universeF $ \function ->
           sortable (Just $ SortingKey $ CI.mk $ toPathPiece function) (i18nCell function) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
             schools <- liftHandler . runDB . E.select . E.from $ \(school `E.InnerJoin` userFunction) -> do
@@ -225,12 +221,15 @@ postUsersR = do
           , ( "company-department"
             , SortColumn $ \user -> user E.^. UserCompanyDepartment
             )
-          , ( "auth-ldap"
+          -- , ( "auth-ldap"
-            , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
+          --   , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP
-            )
+          --   ) -- TODO: reintroduce via ExternalUser
-          , ( "ldap-sync"
+          , ( "last-login"
-            , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
+            , SortColumn $ \user -> user E.^. UserLastAuthentication
             )
+          -- , ( "ldap-sync"
+          --   , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation
+          --   ) -- TODO: reintroduce via ExternalUser
           , ( "user-company"
             , SortColumn $ \user -> E.subSelect $ E.from $ \(usrComp `E.InnerJoin` comp) -> do
                 E.on $ usrComp E.^. UserCompanyCompany E.==. comp E.^. CompanyId
@@ -272,24 +271,24 @@ postUsersR = do
                  | Set.null criteria -> E.true -- TODO: why can this be eFalse and work still?
                  | otherwise         -> E.any (\c -> user E.^. UserCompanyDepartment `E.hasInfix` E.val c) criteria
             )
-          , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if
+          -- , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if
-                | Just crit <- getLast criterion
+          --       | Just crit <- getLast criterion
-                  -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
+          --         -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit
-                | otherwise
+          --       | otherwise
-                  -> E.true
+          --         -> E.true
-            )
+          --   ) -- TODO: reintroduce via ExternalUser
           , ( "school", FilterColumn $ \user criterion -> if
                 | Set.null criterion -> E.val True :: E.SqlExpr (E.Value Bool)
                 | otherwise          -> let schools = E.valList (Set.toList criterion) in
                     E.exists . E.from $ \ufunc -> E.where_ $ ufunc E.^. UserFunctionUser E.==. user E.^. UserId
                                                        E.&&. ufunc E.^. UserFunctionFunction `E.in_` schools
             )
-          , ( "ldap-sync", FilterColumn $ \user criteria -> if
+          -- , ( "ldap-sync", FilterColumn $ \user criteria -> if
-                | Just criteria' <- fromNullable criteria
+          --       | Just criteria' <- fromNullable criteria
-                  -> let minTime = minimum (criteria' :: NonNull (Set UTCTime))
+          --         -> let minTime = minimum (criteria' :: NonNull (Set UTCTime))
-                      in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
+          --             in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation
-                | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
+          --       | otherwise -> E.val True :: E.SqlExpr (E.Value Bool)
-            )
+          --   ) -- TODO: reintroduce via ExternalUser
           , ( "user-company", FilterColumn . E.mkExistsFilter $ \user criterion ->
                 E.from $ \(usrComp `E.InnerJoin` comp) -> do 
                   let testname = (E.val criterion :: E.SqlExpr (E.Value (CI Text))) `E.isInfixOf`
@@ -331,8 +330,8 @@ postUsersR = do
           , prismAForm (singletonFilter "user-supervisor")    mPrev $ aopt textField (fslI MsgTableSupervisor)
           , prismAForm (singletonFilter "school")             mPrev $ aopt (lift `hoistField` selectFieldList schoolOptions) (fslI MsgCourseSchool)
           , prismAForm (singletonFilter "is-supervisor" . maybePrism _PathPiece) mPrev $ aopt (boolField . Just $ SomeMessage MsgBoolIrrelevant) (fslI MsgUserIsSupervisor)
-          , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode)          
+          -- , prismAForm (singletonFilter "auth-ldap"     . maybePrism _PathPiece) mPrev $ aopt (lift `hoistField` selectFieldList [(MsgAuthPWHash "", False), (MsgAuthLDAP, True)]) (fslI MsgAuthMode) -- TODO: reintroduce via ExternalUser
-          , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore)
+          -- , prismAForm (singletonFilter "ldap-sync"     . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) -- TODO: reintroduce via ExternalUser
           ]
       , dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
       , dbtParams    = DBParamsForm
@@ -360,8 +359,8 @@ postUsersR = do
       | Set.null usersSet && isNotSetSupervisor act ->
           addMessageI Info MsgActionNoUsersSelected          
     (UserLdapSyncData, userSet) -> do
-      forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid
+      forM_ userSet $ queueJob' . JobSynchroniseUser
-      addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet      
+      addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet
       redirectKeepGetParams UsersR
     (UserAvsSyncData, userSet) -> do
       forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing
@@ -396,8 +395,8 @@ postUsersR = do
 
   formResult allUsersRes $ \case
     AllUsersLdapSync -> do
-      runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey)
+      runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUser . entityKey)
-      addMessageI Success MsgSynchroniseLdapAllUsersQueued
+      addMessageI Success MsgSynchroniseUserdbAllUsersQueued
       redirect UsersR
   let allUsersWgt' = wrapForm allUsersWgt def
         { formSubmit = FormNoSubmit
@@ -502,7 +501,7 @@ postAdminUserR uuid = do
           return (result, $(widgetFile "widgets/user-rights-form/user-rights-form"))
         userAuthenticationForm :: Form ButtonAuthMode
         userAuthenticationForm = buttonForm' $ if
-          | userAuthentication == AuthLDAP -> [BtnAuthPWHash]
+          | is _Nothing userPasswordHash -> [BtnAuthPWHash]
           | otherwise -> [BtnAuthLDAP, BtnPasswordReset]
         systemFunctionsForm' = funcForm systemFuncForm (fslI MsgUserSystemFunctions) False
           where systemFuncForm func = apopt checkBoxField (fslI func) . Just $ systemFunctions func
@@ -528,33 +527,41 @@ postAdminUserR uuid = do
           redirect $ AdminUserR uuid
 
         userAuthenticationAction = \case
-          BtnAuthLDAP -> do
+          BtnAuthLDAP -> do -- TODO: Reformulate messages and constructors to "remove pw hash" or "external login only"
-            let
+            -- let
-              campusHandler :: MonadPlus m => Auth.CampusUserException -> m a
+            --   ldapHandler :: MonadPlus m => Auth.LdapUserException -> m a
-              campusHandler _ = mzero
+            --   ldapHandler _ = mzero
-            campusResult <- runMaybeT . handle campusHandler $ do
+            -- ldapResult <- runMaybeT . handle ldapHandler $ do
-                Just pool <- getsYesod $ view _appLdapPool
+            --     Just pool <- getsYesod $ view _appLdapPool
-                void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) []
+            --     void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) []
-            case campusResult of
+            -- case ldapResult of
-              Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
+            --   Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup
-              _other
+            --   _other
-                | is _AuthLDAP userAuthentication
+            --     | is _AuthLDAP userAuthentication
-                  -> addMessageI Info MsgAuthLDAPAlreadyConfigured
+            --       -> addMessageI Info MsgAuthLDAPAlreadyConfigured
-              Just () -> do
+            --   Just () -> do
-                runDBJobs $ do
+            --     runDBJobs $ do
-                  update uid [ UserAuthentication =. AuthLDAP ]
+            --       update uid [ UserAuthentication =. AuthLDAP ]
-                  queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
+            --       queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
 
+            --     addMessageI Success MsgAuthLDAPConfigured
+            -- TODO: check current auth sources and warn if user cannot login using any source
+            case userPasswordHash of
+              Nothing -> addMessageI Error MsgAuthLDAPAlreadyConfigured
+              Just _ -> do
+                runDBJobs $ do
+                  update uid [ UserPasswordHash =. Nothing ]
+                  queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
                 addMessageI Success MsgAuthLDAPConfigured
             redirect $ AdminUserR uuid
           BtnAuthPWHash -> do
             if
-              | is _AuthPWHash userAuthentication
+              | is _Just userPasswordHash
                 -> addMessageI Info MsgAuthPWHashAlreadyConfigured
               | otherwise
                 -> do
                   runDBJobs $ do
-                    update uid [ UserAuthentication =. AuthPWHash "" ]
+                    update uid [ UserPasswordHash =. Just "" ]
                     queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
                     queueDBJob $ JobSendPasswordReset uid
 
@@ -714,18 +721,18 @@ postUserPasswordR cID = do
   isAdmin <- hasWriteAccessTo $ AdminUserR cID
 
   requireCurrent <- maybeT (return True) $ asum
-    [ False <$ guard (isn't _AuthPWHash userAuthentication)
+    [ False <$ guard (isn't _Just userPasswordHash)
     , False <$ guard isAdmin
     , do
         authMode <- Base64.decodeLenient . encodeUtf8 <$> MaybeT maybeCurrentBearerRestrictions
-        unless (authMode `constEq` computeUserAuthenticationDigest userAuthentication) . lift $
+        unless (authMode `constEq` computeUserAuthenticationDigest userPasswordHash) . lift $
           invalidArgsI [MsgUnauthorizedPasswordResetToken]
         return False
     ]
 
   ((passResult, passFormWidget), passEnctype) <- runFormPost . formEmbedBearerPost . renderAForm FormStandard . wFormToAForm $ do
     currentResult <- if
-      | AuthPWHash (encodeUtf8 -> pwHash) <- userAuthentication
+      | Just (encodeUtf8 -> pwHash) <- userPasswordHash
       , requireCurrent
         -> wreq
              (checkMap (bool (Left MsgCurrentPasswordInvalid) (Right ()) . flip (PWStore.verifyPasswordWith pwHashAlgorithm (2^)) pwHash . encodeUtf8) (const "") passwordField)
@@ -742,7 +749,7 @@ postUserPasswordR cID = do
 
   formResultModal passResult (bool ProfileR (UserPasswordR cID) isAdmin) $ \newPass -> do
     newHash <- fmap decodeUtf8 . liftIO $ PWStore.makePasswordWith pwHashAlgorithm newPass pwHashStrength
-    liftHandler . runDB $ update tUid [ UserAuthentication =. AuthPWHash newHash ]
+    liftHandler . runDB $ update tUid [ UserPasswordHash =. Just newHash ]
     tell . pure =<< messageI Success MsgPasswordChangedSuccess
 
   siteLayout [whamlet|_{MsgUserPasswordHeadingFor} ^{userEmailWidget usr}|] $

src/Handler/Users/Add.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2023 Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor@kleen.consulting>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -35,20 +35,18 @@ adminUserForm template = renderAForm FormStandard
   <*> aopt (textField & cfStrip)        (fslI MsgAdminUserPinPassword)      (audPinPassword <$> template)
   <*> areq (emailField & cfCI)          (fslI MsgAdminUserEmail)            (audEmail <$> template)
   <*> areq (textField & cfStrip & cfCI) (fslI MsgAdminUserIdent)            (audIdent <$> template)
-  <*> areq (selectField optionsFinite)  (fslI MsgAdminUserAuth & setTooltip MsgAdminUserAuthTooltip) (audAuth <$> template <|> Just AuthKindLDAP)
+  <*> aopt passwordField                (fslI MsgAdminUserPassword)         (audPassword <$> template)
 
--- | Like `addNewUser`, but starts background jobs and tries to notify users, if applicable (i.e. /= AuthNoLogin )
+-- | Like `addNewUser`, but starts background jobs and tries to notify users
 addNewUserNotify :: AddUserData -> Handler (Maybe UserId)
 addNewUserNotify aud = do
   mbUid <- addNewUser aud
   case mbUid of
     Nothing -> return Nothing
     Just uid -> runDBJobs $ do
-      queueDBJob $ JobSynchroniseLdapUser uid
+      queueDBJob $ JobSynchroniseUser uid
-      let authKind = audAuth aud
+      when (is _Just $ audPassword aud) $ do
-      when (authKind /= AuthKindNoLogin) $
         queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid
-      when (authKind == AuthKindPWHash) $
         queueDBJob $ JobSendPasswordReset uid
       return $ Just uid
 

src/Handler/Utils/Avs.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -35,8 +35,7 @@ import qualified Data.Set             as Set
 import qualified Data.Map             as Map
 import qualified Data.Text            as Text
 import qualified Data.CaseInsensitive as CI
--- import Auth.LDAP (ldapUserPrincipalName)
+import Foundation.Yesod.Auth (userLookupAndUpsert)
-import Foundation.Yesod.Auth (ldapLookupAndUpsert) -- , CampusUserConversionException())
 
 import Handler.Utils.Company
 import Handler.Utils.Qualification
@@ -79,7 +78,7 @@ instance Exception AvsException
     Connect AVS query to LDAP queries for automatic synchronisation:
     - add query to Auth.LDAP.campusUserMatr
     - add query to Auth.LDAP.campusLogin
-    - jobs.Handler.dispatchJobSynchroniseLdap
+    - jobs.Handler.dispatchJobSynchroniseUserdb
 
 -}
 
@@ -355,12 +354,12 @@ guessAvsUser someid = do
             [Entity uid _] -> return $ Just uid
             _              -> return Nothing
         uid -> return uid
-    Nothing -> try (runDB $ ldapLookupAndUpsert someid) >>= \case
+    Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case
-      Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> 
+      Right (Just Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> 
         maybeM (return $ Just uid) (return . Just) (maybeUpsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo))
-      Right Entity{entityKey=uid} -> return $ Just uid
+      Right (Just Entity{entityKey=uid}) -> return $ Just uid
       other -> do -- attempt to recover by trying other ids
-        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
+        whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser external error " <> tshow err) -- this line primarily forces exception type to catch-all      
         runDB . runMaybeT $ 
           let someIdent = stripCI someid
           in    MaybeT (getKeyBy $ UniqueEmail          someIdent)
@@ -370,8 +369,8 @@ guessAvsUser someid = do
 upsertAvsUser :: Text -> Handler (Maybe UserId) -- TODO: change to Entity
 upsertAvsUser (discernAvsCardPersonalNo -> Just someid) = maybeCatchAll $ upsertAvsUserByCard someid    -- Note: Right case is any number; it could be AvsCardNumber or AvsInternalPersonalNumber; we cannot know, but the latter is much more likely and useful to users!
 upsertAvsUser otherId = -- attempt LDAP lookup to find by eMail
-  try (runDB $ ldapLookupAndUpsert otherId) >>= \case
+  try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case
-    Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
+    Right (Just Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}}) -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo)
     other -> do -- attempt to recover by trying other ids
       whenIsLeft other (\(err::SomeException) -> $logInfoS "AVS" $ "upsertAvsUser LDAP error " <> tshow err) -- this line primarily forces exception type to catch-all      
       apid <- runDB . runMaybeT $ do
@@ -420,13 +419,16 @@ upsertAvsUserById api = do
               [uid] -> $logInfoS "AVS" "Matching user found, linking." >> insertUniqueEntity (UserAvs api uid avsPersonPersonNo now Nothing)
               (_:_) -> throwM $ AvsUserAmbiguous api
               [] -> do
-                upsRes :: Either SomeException (Entity User)
+                upsRes :: Either SomeException (Maybe (Entity User))
-                  <- try $ ldapLookupAndUpsert persNo
+                  <- try $ userLookupAndUpsert persNo UpsertUserGuessUser -- TODO: do azure lookup and upsert if appropriate
                 $logInfoS "AVS" $ "No matching existing user found. Attempted LDAP upsert returned: " <> tshow upsRes
                 case upsRes of
-                  Right Entity{entityKey=uid} -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
+                  Right (Just Entity{entityKey=uid}) -> insertUniqueEntity $ UserAvs api uid avsPersonPersonNo now Nothing -- pin/addr are updated in next step anyway
+                  Right Nothing -> do
+                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases"
+                    return mbuid -- == Nothing -- user could not be created somehow
                   Left err -> do 
-                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in LDAP: " <> tshow err
+                    $logWarnS "AVS" $ "AVS user with avsInternalPersonalNo " <> tshow persNo <> " not found in external databases: " <> tshow err
                     return mbuid -- == Nothing -- user could not be created somehow
       (Just Entity{ entityKey = uaid }, _) -> do
         update uaid [ UserAvsLastSynch =. now, UserAvsLastSynchError =. Nothing ] -- mark as updated early, to prevent failed users to clog the synch
@@ -460,9 +462,10 @@ upsertAvsUserById api = do
             , audPinPassword      = userPin
             , audEmail = fakeNo    -- Email is unknown in this version of the avs query, to be updated later (FUTURE TODO)
             , audIdent = fakeIdent -- use AvsPersonId instead
-            , audAuth  = maybe AuthKindNoLogin (const AuthKindLDAP) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
+            , audPassword = Nothing
+          --, audAuth  = maybe AuthKindNoLogin (const AuthKindAzure) avsPersonInternalPersonalNo -- FUTURE TODO: if email is known, use AuthKinfPWHash for email invite, if no internal personnel number is known
             }
-      mbUid <- addNewUser newUsr -- triggers JobSynchroniseLdapUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
+      mbUid <- addNewUser newUsr -- triggers JobSynchroniseUserdbUser, JobSendPasswordReset and NotificationUserAutoModeUpdate -- TODO: check if these are failsafe
       whenIsJust mbUid $ \uid -> runDB $ do        
         insert_ $ UserAvs avsPersonPersonID uid avsPersonPersonNo now Nothing
         forM_ avsPersonPersonCards $ -- save all cards for later comparisons whether an update occurred

src/Handler/Utils/StudyFeatures.hs

@@ -137,7 +137,7 @@ cacheStudyFeatureRelevance fFilter = do
         E.on E.true
         E.where_ $ fFilter studyFeatures
         E.where_ $ isRelevantStudyFeature (E.val now) TermId term studyFeatures
-        return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
+        E.distinct $ return $ RelevantStudyFeatures E.<# (term E.^. TermId) E.<&> (studyFeatures E.^. StudyFeaturesId)
     )
     ( \_current _excluded -> [] )
 

src/Handler/Utils/Table/Pagination.hs

@@ -769,7 +769,7 @@ dbtProjFilteredPostId :: forall fs r r'.
                       => ReaderT (DBTProjCtx fs r) (MaybeT (ReaderT SqlBackend (HandlerFor UniWorX))) r'
 dbtProjFilteredPostId = withFilteredPost dbtProjId'
 
--- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergeniszeilen in Haskell transformieren und filtern
+-- | Kombination aus `dbtProjFilteredPostId` und `dbtProjSimple`, d.h. Ergebniszeilen in Haskell transformieren und filtern
 dbtProjFilteredPostSimple :: forall fs r r' r''.
                              ( fs ~ DBTProjFilterPost r', DBRow r'' ~ r' )
                           => (r -> DB r'')

src/Handler/Utils/Users.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -24,8 +24,7 @@ module Handler.Utils.Users
   ) where
 
 import Import
-import Auth.LDAP (campusUserMatr')
+import Foundation.Yesod.Auth (userLookupAndUpsert)
-import Foundation.Yesod.Auth (upsertCampusUser)
 
 import Crypto.Hash (hashlazy)
 
@@ -37,7 +36,6 @@ import qualified Data.Aeson as JSON
 import qualified Data.Aeson.Types as JSON
 
 import qualified Data.Set as Set
--- import qualified Data.List as List
 import qualified Data.CaseInsensitive as CI
 
 import           Database.Esqueleto.Experimental ((:&)(..))
@@ -131,15 +129,13 @@ getSupervisees = do
   return $ Set.insert uid $ Set.fromAscList svs 
 
 
-computeUserAuthenticationDigest :: AuthenticationMode -> Digest SHA3_256
+computeUserAuthenticationDigest :: Maybe Text -> Digest SHA3_256
 computeUserAuthenticationDigest = hashlazy . JSON.encode
 
 
 data GuessUserInfo
   = GuessUserMatrikelnummer
     { guessUserMatrikelnummer         :: UserMatriculation          }
-  | GuessUserEduPersonPrincipalName
-    { guessUserEduPersonPrincipalName :: UserEduPersonPrincipalName }
   | GuessUserDisplayName
     { guessUserDisplayName            :: UserDisplayName            }
   | GuessUserSurname
@@ -191,12 +187,11 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
 
     toSql user pl = bool id E.not_ (is _PLNegated pl) $ case pl ^. _plVar of
       GuessUserMatrikelnummer         userMatriculation' -> user E.^. UserMatrikelnummer  E.==.          E.val (Just userMatriculation')
-      GuessUserEduPersonPrincipalName userEPPN'          -> user E.^. UserLdapPrimaryKey  E.==.          E.val (Just userEPPN')
       GuessUserDisplayName            userDisplayName'   -> user E.^. UserDisplayName    `containsAsSet` userDisplayName'
       GuessUserSurname                userSurname'       -> user E.^. UserSurname        `containsAsSet` userSurname'
       GuessUserFirstName              userFirstName'     -> user E.^. UserFirstName      `containsAsSet` userFirstName'
 
-    go didLdap = do
+    go didUpsert = do
       let retrieveUsers = E.select . EL.from $ \user -> do
             E.where_ . E.or $ map (E.and . map (toSql user)) criteria
             when (is _Just mQueryLimit) $ (E.limit . fromJust) mQueryLimit
@@ -238,11 +233,7 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
             | EQ <- x `closeness` x' = x : takeClosest (x':xs)
             | otherwise = [x]
 
-          doLdap userMatr = do
+          doUpsert = flip userLookupAndUpsert UpsertUserGuessUser
-            ldapPool' <- getsYesod $ view _appLdapPool
-            fmap join . for ldapPool' $ \ldapPool -> do
-              ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr
-              for ldapData $ upsertCampusUser UpsertCampusUserGuessUser
 
       let
         getTermMatr :: [PredLiteral GuessUserInfo] -> Maybe UserMatriculation
@@ -258,25 +249,25 @@ guessUser (((Set.toList . toNullable) <$>) . Set.toList . dnfTerms -> criteria)
             | otherwise                        = Nothing
           getTermMatrAux acc (_:xs) = getTermMatrAux acc xs
 
-        convertLdapResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
+        convertUpsertResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User))
-        convertLdapResults []  = Nothing
+        convertUpsertResults []  = Nothing
-        convertLdapResults [x] = Just $ Right x
+        convertUpsertResults [x] = Just $ Right x
-        convertLdapResults xs  = Just $ Left $ NonEmpty.fromList xs
+        convertUpsertResults xs  = Just $ Left $ NonEmpty.fromList xs
 
       if
         | [x] <- users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
           -> return $ Just $ Right x
         | x : x' : _ <- users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
         , GT <- x `closeness` x'
           -> return $ Just $ Right x
         | xs@(x:_:_) <- takeClosest users'
-        , Just True == matchesMatriculation x || didLdap
+        , Just True == matchesMatriculation x || didUpsert
           -> return $ Just $ Left $ NonEmpty.fromList xs
-        | not didLdap
+        | not didUpsert
         , userMatrs <- (Set.toList . Set.fromList . catMaybes) $ getTermMatr <$> criteria
-          -> mapM doLdap userMatrs >>= maybe (go True) (return . Just) . convertLdapResults . catMaybes
+          -> mapM doUpsert userMatrs >>= maybe (go True) (return . Just) . convertUpsertResults . catMaybes
         | otherwise
           -> return Nothing
 
@@ -912,8 +903,7 @@ assimilateUser newUserId oldUserId = mapReaderT execWriterT $ do
       mergeMaybe = mergeBy (\oldV newV -> isNothing newV && isJust oldV)
 
   update newUserId $ catMaybes          -- NOTE: persist does shortcircuit null updates as expected
-      [ mergeMaybe UserLdapPrimaryKey
+      [ mergeMaybe  UserPasswordHash
-      , mergeBy (<) UserAuthentication
       , mergeBy (>) UserLastAuthentication
       , mergeBy (<) UserCreated
       , toMaybe (not (validEmail' (newUser ^. _userEmail       )) && validEmail' (oldUser ^. _userEmail))

src/Import/NoModel.hs

@@ -252,6 +252,7 @@ import Data.Encoding.UTF8 as Import (UTF8(UTF8))
 
 import GHC.TypeLits as Import (KnownSymbol)
 
+import Data.Word as Import (Word16)
 import Data.Word.Word24 as Import
 
 import Data.Kind as Import (Type, Constraint)

src/Jobs.hs

@@ -71,7 +71,7 @@ import Jobs.Handler.SendCourseCommunication
 import Jobs.Handler.Invitation
 import Jobs.Handler.SendPasswordReset
 import Jobs.Handler.TransactionLog
-import Jobs.Handler.SynchroniseLdap
+import Jobs.Handler.SynchroniseUser
 import Jobs.Handler.SynchroniseAvs
 import Jobs.Handler.PruneInvitations
 import Jobs.Handler.ChangeUserDisplayEmail
@@ -493,7 +493,7 @@ handleJobs' wNum = C.mapM_ $ \jctl -> hoist delimitInternalState . withJobWorker
       , Exc.Handler $ \case
           MailNotAvailable -> return $ Right ()
           e                -> return . Left $ SomeException e
-      , Exc.Handler $ \SynchroniseLdapNoLdap -> return $ Right ()
+      , Exc.Handler $ \SynchroniseUserNoSource -> return $ Right ()
 #endif
       , Exc.Handler $ \(e :: SomeException) -> return $ Left e
       ] . fmap Right

src/Jobs/Crontab.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -310,15 +310,14 @@ determineCrontab = execWriterT $ do
           return (nextEpoch, nextInterval, nextIntervalTime, numIntervals)
 
     if
-      | is _Just appLdapConf
+      | Just syncWithin <- appUserSyncWithin
-      , Just syncWithin <- appSynchroniseLdapUsersWithin
+      , Just cInterval  <- appJobCronInterval
-      , Just cInterval <- appJobCronInterval
         -> do
-          nextIntervals <- getNextIntervals syncWithin appSynchroniseLdapUsersInterval cInterval
+          nextIntervals <- getNextIntervals syncWithin appUserSyncInterval cInterval
 
           forM_ nextIntervals $ \(nextEpoch, nextInterval, nextIntervalTime, numIntervals) -> do
             tell $ HashMap.singleton
-              (JobCtlQueue JobSynchroniseLdap
+              (JobCtlQueue JobSynchroniseUsers
                  { jEpoch         = fromInteger nextEpoch
                  , jNumIterations = fromInteger numIntervals
                  , jIteration     = fromInteger nextInterval
@@ -326,8 +325,8 @@ determineCrontab = execWriterT $ do
               Cron
                 { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ $ toTimeOfDay 23 30 0 $ utctDay nextIntervalTime
                 , cronRepeat    = CronRepeatNever
-                , cronRateLimit = appSynchroniseLdapUsersInterval
+                , cronRateLimit = appUserSyncInterval
-                , cronNotAfter  = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appSynchroniseLdapUsersInterval nextIntervalTime
+                , cronNotAfter  = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appUserSyncInterval nextIntervalTime
                 }
       | otherwise
        -> return ()
@@ -445,28 +444,26 @@ determineCrontab = execWriterT $ do
                         )
       .| C.fold collateSubmissionsByCorrector Map.empty
 
-    submissionRatedNotificationsSince <- lift $ getMigrationTime Migration20210318CrontabSubmissionRatedNotification 
+    let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do
-    whenIsJust submissionRatedNotificationsSince $ \notifySince
+          E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
-      -> let submissionsSelect = E.selectSource . E.from $ \(submission `E.InnerJoin` sheet) -> do
+          E.where_ $ sqlSubmissionRatingDone submission
-               E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
+              E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal (toMidnight $ fromGregorian 2024 1 1) -- no submissions used in FRADrive as of this date, previously cut off by an old legacy migration
-               E.where_ $ sqlSubmissionRatingDone submission
+          return (submission, sheet E.^. SheetType)
-                    E.&&. submission E.^. SubmissionRatingTime E.>=. E.justVal notifySince
+        submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do
-               return (submission, sheet E.^. SheetType)
+          examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do
-             submissionJobs (Entity subId Submission{..}, E.Value sType) = maybeT_ $ do
+            ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
-               examFinishedTime <- hoist lift . for (sType ^? _examPart . from _SqlKey) $ \epId -> do
+            Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
-                 ExamPart{examPartExam} <- MaybeT . $cachedHereBinary epId $ get epId
+            return examFinished
-                 Exam{..} <- MaybeT . $cachedHereBinary examPartExam $ get examPartExam
+          notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime 
-                 return examFinished
+          tell $ HashMap.singleton
-               notifyTime <- hoistMaybe . nBot $ maybe NTop (max `on` NTop) examFinishedTime submissionRatingTime 
+            (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
-               tell $ HashMap.singleton
+            Cron
-                 (JobCtlQueue . JobQueueNotification $ NotificationSubmissionRated subId)
+              { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime
-                 Cron
+              , cronRepeat    = CronRepeatNever
-                   { cronInitial   = CronTimestamp $ utcToLocalTimeTZ appTZ notifyTime
+              , cronRateLimit = appNotificationRateLimit
-                   , cronRepeat    = CronRepeatNever
+              , cronNotAfter  = Left appNotificationExpiration
-                   , cronRateLimit = appNotificationRateLimit
+              }
-                   , cronNotAfter  = Left appNotificationExpiration
+    runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs
-                   }
-          in runConduit $ transPipe lift submissionsSelect .| C.mapM_ submissionJobs
 
     let
       examSelect = E.selectSource . E.from $ \(exam `E.InnerJoin` course `E.InnerJoin` school) -> do

src/Jobs/Handler/SendNotification/UserAuthModeUpdate.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-2024 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
 

src/Jobs/Handler/SendPasswordReset.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -36,7 +36,7 @@ dispatchJobSendPasswordReset jRecipient = JobHandlerException . userMailT jRecip
 
   resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
   let resetBearer = resetBearer'
-        & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
+        & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userPasswordHash)
   encodedBearer <- encodeBearer resetBearer
    
   resetUrl <- toTextUrl (UserPasswordR cID, [(toPathPiece GetBearer, toPathPiece encodedBearer)])

src/Jobs/Handler/SynchroniseLdap.hs

@@ -1,64 +0,0 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
---
--- SPDX-License-Identifier: AGPL-3.0-or-later
-
-module Jobs.Handler.SynchroniseLdap
-  ( dispatchJobSynchroniseLdap, dispatchJobSynchroniseLdapUser
-  , SynchroniseLdapException(..)
-  ) where
-
-import Import
-
-import qualified Data.CaseInsensitive as CI
-import qualified Data.Conduit.List as C
-
-import Auth.LDAP
-import Foundation.Yesod.Auth (CampusUserConversionException, upsertCampusUser)
-
-import Jobs.Queue
-
-
-data SynchroniseLdapException
-  = SynchroniseLdapNoLdap
-  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
-instance Exception SynchroniseLdapException
-
-dispatchJobSynchroniseLdap :: Natural -> Natural -> Natural -> JobHandler UniWorX
-dispatchJobSynchroniseLdap numIterations epoch iteration
-  = JobHandlerAtomic . runConduit $
-      readUsers .| filterIteration .| sinkDBJobs
-  where
-    readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
-    readUsers = selectKeys [] []
-
-    filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
-    filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
-      let
-        userIteration, currentIteration :: Integer
-        userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
-        currentIteration = toInteger iteration `mod` toInteger numIterations
-      $logDebugS "SynchroniseLdap" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
-      guard $ userIteration == currentIteration
-
-      return $ JobSynchroniseLdapUser userId
-
-dispatchJobSynchroniseLdapUser :: UserId -> JobHandler UniWorX
-dispatchJobSynchroniseLdapUser jUser = JobHandlerException $ do
-  UniWorX{..} <- getYesod
-  case appLdapPool of
-    Just ldapPool ->
-      runDB . void . runMaybeT . handleExc $ do
-        user@User{userIdent,userLdapPrimaryKey} <- MaybeT $ get jUser
-        let upsertIdent = maybe userIdent CI.mk userLdapPrimaryKey 
-        $logInfoS "SynchroniseLdap" [st|Synchronising #{upsertIdent}|]
-
-        reTestAfter <- getsYesod $ view _appLdapReTestFailover
-        ldapAttrs <- MaybeT $ campusUserReTest' ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited user
-        void . lift $ upsertCampusUser (UpsertCampusUserLdapSync upsertIdent) ldapAttrs
-    Nothing ->
-      throwM SynchroniseLdapNoLdap
-  where
-    handleExc :: MaybeT DB a -> MaybeT DB a
-    handleExc
-      = catchMPlus (Proxy @CampusUserException)
-      . catchMPlus (Proxy @CampusUserConversionException)

src/Jobs/Handler/SynchroniseUser.hs

@@ -0,0 +1,48 @@
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Jobs.Handler.SynchroniseUser
+  ( dispatchJobSynchroniseUsers, dispatchJobSynchroniseUser
+  , SynchroniseUserException(..)
+  ) where
+
+import Import
+
+import Foundation.Yesod.Auth (userLookupAndUpsert)
+
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Conduit.List as C
+
+import Jobs.Queue
+
+
+data SynchroniseUserException
+  = SynchroniseUserNoSource
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
+instance Exception SynchroniseUserException
+
+dispatchJobSynchroniseUsers :: Natural -> Natural -> Natural -> JobHandler UniWorX
+dispatchJobSynchroniseUsers numIterations epoch iteration
+  = JobHandlerAtomic . runConduit $
+      readUsers .| filterIteration .| sinkDBJobs
+  where
+    readUsers :: ConduitT () UserId (YesodJobDB UniWorX) ()
+    readUsers = selectKeys [] []
+
+    filterIteration :: ConduitT UserId Job (YesodJobDB UniWorX) ()
+    filterIteration = C.mapMaybeM $ \userId -> runMaybeT $ do
+      let
+        userIteration, currentIteration :: Integer
+        userIteration = toInteger (hash epoch `hashWithSalt` userId) `mod` toInteger numIterations
+        currentIteration = toInteger iteration `mod` toInteger numIterations
+      $logDebugS "SynchroniseUsers" [st|User ##{tshow (fromSqlKey userId)}: sync on #{tshow userIteration}/#{tshow numIterations}, now #{tshow currentIteration}|]
+      guard $ userIteration == currentIteration
+
+      return $ JobSynchroniseUser userId
+
+dispatchJobSynchroniseUser :: UserId -> JobHandler UniWorX
+dispatchJobSynchroniseUser jUser = JobHandlerException . runDB $ do
+  User{userIdent = upsertUserIdent} <- getJust jUser
+  $logInfoS "SynchroniseUser" [st|Synchronising #{upsertUserIdent} with external sources|]
+  void $ userLookupAndUpsert (CI.original upsertUserIdent) UpsertUserSync{..}

src/Jobs/HealthReport.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-2024 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
 
@@ -107,23 +107,31 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _
     getsYesod $ (== clusterId) . appClusterID
 
 
+-- TODO: generalize health check
 dispatchHealthCheckLDAPAdmins :: Handler HealthReport
 dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
   ldapPool' <- getsYesod appLdapPool
-  reTestAfter <- getsYesod $ view _appLdapReTestFailover
+  userAuthConf <- getsYesod $ view _appUserAuthConf
   case ldapPool' of
     Just ldapPool -> do
+      let currentLdapSources = case userAuthConf of
+            UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
+              -> singleton $ AuthSourceIdLdap ldapConfSourceId
+            _other -> mempty
       ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
         E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
         E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
-        E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
+        E.where_ . E.exists . E.from $ \externalUser -> E.where_ $
+                externalUser E.^. ExternalUserUser E.==. user E.^. UserIdent
+          E.&&. externalUser E.^. ExternalUserSource `E.in_` E.valList currentLdapSources
         return $ user E.^. UserIdent
       for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
         let numAdmins = genericLength ldapAdminUsers
         Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) ->
-          let hCampusExc :: CampusUserException -> Handler (Sum Integer)
+          let hLdapExc :: LdapUserException -> Handler (Sum Integer)
-              hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err)
+              hLdapExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err)
-           in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds apLdap adminIdent [])
+           in handle hLdapExc $ Sum 1 <$ ldapUser ldapPool (Creds apLdap adminIdent [])
+         --in handle hLdapExc $ Sum 1 <$ ldapUserReTest ldapPool (const True) FailoverUnlimited (Creds apLdap adminIdent [])
         if
           | numAdmins >= 1 -> return $ numResolved % numAdmins
           | otherwise      -> return 0

src/Jobs/Types.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -92,11 +92,11 @@ data Job
   | JobTruncateTransactionLog
   | JobPruneInvitations
   | JobDeleteTransactionLogIPs
-  | JobSynchroniseLdap        { jNumIterations
+  | JobSynchroniseUsers       { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
                               }
-  | JobSynchroniseLdapUser    { jUser :: UserId }
+  | JobSynchroniseUser        { jUser :: UserId }
   | JobSynchroniseAvs         { jNumIterations
                               , jEpoch
                               , jIteration :: Natural
@@ -348,8 +348,8 @@ jobNoQueueSame = \case
   JobTruncateTransactionLog{}         -> Just JobNoQueueSame
   JobPruneInvitations{}               -> Just JobNoQueueSame
   JobDeleteTransactionLogIPs{}        -> Just JobNoQueueSame
-  JobSynchroniseLdap{}                -> Just JobNoQueueSame
+  JobSynchroniseUsers{}               -> Just JobNoQueueSame
-  JobSynchroniseLdapUser{}            -> Just JobNoQueueSame
+  JobSynchroniseUser{}                -> Just JobNoQueueSame
   JobSynchroniseAvs{}                 -> Just JobNoQueueSame
   JobSynchroniseAvsUser{}             -> Just JobNoQueueSame
   JobSynchroniseAvsId{}               -> Just JobNoQueueSame

src/Ldap/Client/Instances.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -9,7 +9,53 @@ module Ldap.Client.Instances
   ) where
 
 import ClassyPrelude
+
+import Data.Aeson.TH
+import Data.Data (Data)
+
+import Database.Persist.TH (derivePersistField)
+
+import Utils.PathPiece (derivePathPiece)
+
 import Ldap.Client
 
+import Network.HTTP.Types.Method.Instances () -- for FromJSON instance for ByteString
 
+
+deriving instance Ord Attr
+deriving instance Ord Dn
+deriving instance Ord Password
 deriving instance Ord ResultCode
+deriving instance Ord Scope
+
+deriving instance Read Attr
+deriving instance Read Dn
+deriving instance Read Password
+deriving instance Read Scope
+
+deriving instance Data Attr
+deriving instance Data Dn
+deriving instance Data Password
+deriving instance Data Scope
+
+deriving instance Generic Attr
+deriving instance Generic Dn
+deriving instance Generic Password
+deriving instance Generic Scope
+
+deriving anyclass instance NFData Attr
+deriving anyclass instance NFData Dn
+deriving anyclass instance NFData Password
+deriving instance NFData Scope
+
+derivePathPiece ''Dn id "--"
+derivePathPiece ''Scope id "--"
+
+derivePersistField "Dn"
+derivePersistField "Password"
+derivePersistField "Scope"
+
+deriveJSON defaultOptions ''Attr
+deriveJSON defaultOptions ''Dn
+deriveJSON defaultOptions ''Scope
+deriveJSON defaultOptions ''SearchEntry

src/Ldap/Client/Pool.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 

src/Model/Migration.hs

@@ -31,59 +31,20 @@ import Control.Monad.Except (MonadError(..))
 
 import Web.ServerSession.Backend.Persistent.Memcached (migrateMemcachedSqlStorage)
   
-import qualified Control.Monad.State.Class as State
+-- import qualified Control.Monad.State.Class as State
 
 
-_manualMigration :: Fold (Legacy.MigrationVersion, Legacy.Version) ManualMigration
+-- _manualMigration :: Fold (Legacy.Migration Version, Legacy.Version) ManualMigration
-_manualMigration = folding $ \case
+-- _manualMigration = folding $ \case
-  ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|])  -> Just Migration20180813SimplifyUserTheme
+--   ([Legacy.migrationVersion|initial|], [Legacy.version|0.0.0|])  -> Just Migration20180813SimplifyUserTheme
-  ([Legacy.migrationVersion|0.0.0|],   [Legacy.version|1.0.0|])  -> Just Migration20180813SheetJSONB
+--   ([Legacy.migrationVersion|44.0.0|],  [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
-  ([Legacy.migrationVersion|1.0.0|],   [Legacy.version|2.0.0|])  -> Just Migration20180823SchoolShorthandPrimaryKey
+--   _other -> Nothing
-  ([Legacy.migrationVersion|2.0.0|],   [Legacy.version|3.0.0|])  -> Just Migration20180918SheetCorrectorLoadJSON
-  ([Legacy.migrationVersion|3.0.0|],   [Legacy.version|3.1.0|])  -> Just Migration20180918UserSurnames
-  ([Legacy.migrationVersion|3.1.0|],   [Legacy.version|3.2.0|])  -> Just Migration20180918SheetUploadMode
-  ([Legacy.migrationVersion|3.2.0|],   [Legacy.version|4.0.0|])  -> Just Migration20180928UserAuthentication
-  ([Legacy.migrationVersion|4.0.0|],   [Legacy.version|5.0.0|])  -> Just Migration20181011UserNotificationSettings
-  ([Legacy.migrationVersion|5.0.0|],   [Legacy.version|6.0.0|])  -> Just Migration20181031SheetTypeRefactor
-  ([Legacy.migrationVersion|6.0.0|],   [Legacy.version|7.0.0|])  -> Just Migration20181129EncodedSecretBoxes
-  ([Legacy.migrationVersion|7.0.0|],   [Legacy.version|8.0.0|])  -> Just Migration20181130SheetTypeRefactor
-  ([Legacy.migrationVersion|8.0.0|],   [Legacy.version|9.0.0|])  -> Just Migration20190319CourseParticipantField
-  ([Legacy.migrationVersion|9.0.0|],   [Legacy.version|10.0.0|]) -> Just Migration20190320BetterStudyShorthands
-  ([Legacy.migrationVersion|10.0.0|],  [Legacy.version|11.0.0|]) -> Just Migration20190421MixedSheetSubmissions
-  ([Legacy.migrationVersion|11.0.0|],  [Legacy.version|12.0.0|]) -> Just Migration20190429Tutorials
-  ([Legacy.migrationVersion|12.0.0|],  [Legacy.version|13.0.0|]) -> Just Migration20190515Exams
-  ([Legacy.migrationVersion|13.0.0|],  [Legacy.version|14.0.0|]) -> Just Migration20190715ExamOccurrenceName
-  ([Legacy.migrationVersion|14.0.0|],  [Legacy.version|15.0.0|]) -> Just Migration20190726UserFirstNamesTitles
-  ([Legacy.migrationVersion|15.0.0|],  [Legacy.version|16.0.0|]) -> Just Migration20190806TransactionLogIds
-  ([Legacy.migrationVersion|18.0.0|],  [Legacy.version|19.0.0|]) -> Just Migration20190828UserFunction
-  ([Legacy.migrationVersion|19.0.0|],  [Legacy.version|20.0.0|]) -> Just Migration20190912UserDisplayEmail
-  ([Legacy.migrationVersion|20.0.0|],  [Legacy.version|21.0.0|]) -> Just Migration20190916ExamPartNumber
-  ([Legacy.migrationVersion|21.0.0|],  [Legacy.version|22.0.0|]) -> Just Migration20190918ExamRulesRefactor
-  ([Legacy.migrationVersion|22.0.0|],  [Legacy.version|23.0.0|]) -> Just Migration20190919ExamBonusRounding
-  ([Legacy.migrationVersion|23.0.0|],  [Legacy.version|24.0.0|]) -> Just Migration20191002FavouriteReason
-  ([Legacy.migrationVersion|26.0.0|],  [Legacy.version|27.0.0|]) -> Just Migration20191125UserLanguages
-  ([Legacy.migrationVersion|27.0.0|],  [Legacy.version|28.0.0|]) -> Just Migration20191126ExamPartCorrector
-  ([Legacy.migrationVersion|28.0.0|],  [Legacy.version|29.0.0|]) -> Just Migration20191128StudyFeaturesSuperField
-  ([Legacy.migrationVersion|29.0.0|],  [Legacy.version|30.0.0|]) -> Just Migration20200111ExamOccurrenceRuleRefactor
-  ([Legacy.migrationVersion|30.0.0|],  [Legacy.version|31.0.0|]) -> Just Migration20200218ExamResultPassedGrade
-  ([Legacy.migrationVersion|31.0.0|],  [Legacy.version|32.0.0|]) -> Just Migration20200218ExamGradingModeMixed
-  ([Legacy.migrationVersion|32.0.0|],  [Legacy.version|33.0.0|]) -> Just Migration20200218ExternalExamGradingModeMixed
-  ([Legacy.migrationVersion|34.0.0|],  [Legacy.version|35.0.0|]) -> Just Migration20200424SubmissionGroups
-  ([Legacy.migrationVersion|35.0.0|],  [Legacy.version|36.0.0|]) -> Just Migration20200504CourseParticipantState
-  ([Legacy.migrationVersion|36.0.0|],  [Legacy.version|37.0.0|]) -> Just Migration20200506SessionFile
-  ([Legacy.migrationVersion|37.0.0|],  [Legacy.version|38.0.0|]) -> Just Migration20200627FileRefactor
-  ([Legacy.migrationVersion|39.0.0|],  [Legacy.version|40.0.0|]) -> Just Migration20200825StudyFeaturesFirstObserved
-  ([Legacy.migrationVersion|40.0.0|],  [Legacy.version|41.0.0|]) -> Just Migration20200902FileChunking
-  ([Legacy.migrationVersion|41.0.0|],  [Legacy.version|42.0.0|]) -> Just Migration20200916ExamMode
-  ([Legacy.migrationVersion|43.0.0|],  [Legacy.version|44.0.0|]) -> Just Migration20201106StoredMarkup
-  ([Legacy.migrationVersion|44.0.0|],  [Legacy.version|45.0.0|]) -> Just Migration20201119RoomTypes
-  _other -> Nothing
-
 
+-- AppliedMigrationMigration changed vom ManualMigration to Text (via PathPiece) so that removed extra migrations within DB are harmless (before achieved through where-clause)
 share [mkPersist sqlSettings, mkMigrate "migrateDBVersioning"]
   [persistLowerCase|
     AppliedMigration json
-      migration ManualMigration
+      migration Text
       time UTCTime
       Primary migration
       deriving Show Eq Ord
@@ -99,7 +60,7 @@ migrateAll' = sequence_
 migrateAll :: ( MonadLogger m
               , MonadResource m
               , MonadUnliftIO m
-              , MonadReader UniWorX m
+              -- , MonadReader UniWorX m
               )
            => ReaderT SqlBackend m ()
 migrateAll = do
@@ -108,8 +69,9 @@ migrateAll = do
 
   missingMigrations <- getMissingMigrations
   let
-    doCustomMigration acc appliedMigrationMigration migration = acc <* do
+    doCustomMigration acc manualMigration migration = acc <* do
-      $logInfoS "Migration" $ toPathPiece appliedMigrationMigration
+      let appliedMigrationMigration = toPathPiece manualMigration
+      $logInfoS "Migration" appliedMigrationMigration
       appliedMigrationTime <- liftIO getCurrentTime
       _ <- migration
       insert AppliedMigration{..}
@@ -154,9 +116,9 @@ initialMigration = do
   mapM_ migrateEnableExtension ["citext", "pgcrypto"]
   lift . lift . hoist runResourceT . whenM (columnExists "applied_migration" "from") $ do
     let getAppliedMigrations = [queryQQ|SELECT "from", "to", "time" FROM "applied_migration"|]
-        migrateAppliedMigration [ fromPersistValue -> Right (fromV :: Legacy.MigrationVersion), fromPersistValue -> Right (toV :: Legacy.Version), fromPersistValue -> Right (time :: UTCTime) ] = do
+        migrateAppliedMigration [ fromPersistValue -> Right (fromV :: Legacy.MigrationVersion), fromPersistValue -> Right (toV :: Legacy.Version), fromPersistValue -> Right (_time :: UTCTime) ] = do
           lift [executeQQ|DELETE FROM "applied_migration" WHERE "from" = #{fromV} AND "to" = #{toV}|]
-          State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV)
+          -- State.modify . Map.unionWith min . Map.fromSet (const time) $ setOf _manualMigration (fromV, toV)
         migrateAppliedMigration _ = return ()
         insertMigrations ms = do
           [executeQQ|
@@ -174,14 +136,16 @@ getMissingMigrations :: forall m m'.
                         ( MonadLogger m
                         , MonadIO m
                         , MonadResource m'
-                        , MonadReader UniWorX m'
+                        -- , MonadReader UniWorX 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    
     return $ appliedMigration E.^. AppliedMigrationMigration
-  return $ customMigrations `Map.withoutKeys` Set.fromList appliedMigrations
+  let migNotDone m _ = toPathPiece m `Set.notMember` Set.fromList appliedMigrations
+  return $ Map.filterWithKey migNotDone customMigrations
+    
 
 getMigrationTime :: ( MonadIO m
                     , BaseBackend backend ~ SqlBackend
@@ -189,4 +153,4 @@ getMigrationTime :: ( MonadIO m
                     )
                  => ManualMigration
                  -> ReaderT backend m (Maybe UTCTime)
-getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey
+getMigrationTime = fmap (fmap appliedMigrationTime) . get . AppliedMigrationKey . toPathPiece

src/Model/Migration/Definitions.hs

@@ -2,6 +2,8 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
+{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
+
 module Model.Migration.Definitions
   ( ManualMigration(..)
   , migrateManual
@@ -14,8 +16,8 @@ import Import.NoModel hiding (Max(..), Last(..))
 import Model
 import Model.Types.TH.PathPiece
 import Settings
-import Foundation.Type
+-- import Foundation.Type
-import Audit.Types
+-- import Audit.Types
 import qualified Model.Migration.Types as Legacy
 import qualified Data.Map as Map
 
@@ -28,16 +30,14 @@ import qualified Data.Conduit.List as C
 import Database.Persist.Sql
 import Database.Persist.Sql.Raw.QQ
 
-import Text.Read (readMaybe)
+-- import Text.Read (readMaybe)
 
-import Network.IP.Addr
+-- import Network.IP.Addr
 
-import qualified Data.Char as Char
+-- import qualified Data.Char as Char
-import qualified Data.CaseInsensitive as CI
+-- import qualified Data.CaseInsensitive as CI
 
-import qualified Data.Aeson as Aeson
+-- import qualified Data.Aeson as Aeson
-
-import Data.Conduit.Algorithms.FastCDC (FastCDCParameters(fastCDCMinBlockSize))
 
 import Data.Time.Format.ISO8601 (iso8601Show)
 import Data.Time.Format
@@ -47,53 +47,9 @@ import qualified Data.Time.Zones as TZ
 
 
 data ManualMigration
-  = Migration20180813SimplifyUserTheme
+  = Migration20230524QualificationUserBlock
-  | Migration20180813SheetJSONB
-  | Migration20180823SchoolShorthandPrimaryKey
-  | Migration20180918SheetCorrectorLoadJSON
-  | Migration20180918UserSurnames
-  | Migration20180918SheetUploadMode
-  | Migration20180928UserAuthentication
-  | Migration20181011UserNotificationSettings
-  | Migration20181031SheetTypeRefactor
-  | Migration20181129EncodedSecretBoxes
-  | Migration20181130SheetTypeRefactor
-  | Migration20190319CourseParticipantField
-  | Migration20190320BetterStudyShorthands
-  | Migration20190421MixedSheetSubmissions
-  | Migration20190429Tutorials
-  | Migration20190515Exams
-  | Migration20190715ExamOccurrenceName
-  | Migration20190726UserFirstNamesTitles
-  | Migration20190806TransactionLogIds
-  | Migration20190828UserFunction
-  | Migration20190912UserDisplayEmail
-  | Migration20190916ExamPartNumber
-  | Migration20190918ExamRulesRefactor
-  | Migration20190919ExamBonusRounding
-  | Migration20191002FavouriteReason
-  | Migration20191125UserLanguages
-  | Migration20191126ExamPartCorrector
-  | Migration20191128StudyFeaturesSuperField
-  | Migration20200111ExamOccurrenceRuleRefactor
-  | Migration20200218ExamResultPassedGrade
-  | Migration20200218ExamGradingModeMixed
-  | Migration20200218ExternalExamGradingModeMixed
-  | Migration20200424SubmissionGroups
-  | Migration20200504CourseParticipantState
-  | Migration20200506SessionFile
-  | Migration20200627FileRefactor
-  | Migration20200825StudyFeaturesFirstObserved
-  | Migration20200902FileChunking
-  | Migration20200916ExamMode
-  | Migration20201106StoredMarkup
-  | Migration20201119RoomTypes
-  | Migration20210115ExamPartsFrom
-  | Migration20210208StudyFeaturesRelevanceCachedUUIDs
-  | Migration20210318CrontabSubmissionRatedNotification
-  | Migration20210608SeparateTermActive
-  | Migration20230524QualificationUserBlock
   | Migration20230703LmsUserStatus
+  | Migration20240312OAuth2
   deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
   deriving anyclass (Universe, Finite)
 
@@ -125,7 +81,7 @@ migrateManual = do
     , ("user_lower_ident",                    "CREATE INDEX user_lower_ident ON \"user\" (lower(ident))"                                 )
     , ("submission_sheet",                    "CREATE INDEX submission_sheet ON submission (sheet)"                                      )
     , ("submission_edit_submission",          "CREATE INDEX submission_edit_submission ON submission_edit (submission)"                  )
-    , ("user_ldap_primary_key",               "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)"                        )
+--  , ("user_ldap_primary_key",               "CREATE INDEX user_ldap_primary_key ON \"user\" (ldap_primary_key)"                        ) -- TODO: reintroduce
     , ("file_content_entry_chunk_hash",       "CREATE INDEX file_content_entry_chunk_hash ON \"file_content_entry\" (chunk_hash)"        )
     , ("sent_mail_bounce_secret",             "CREATE INDEX sent_mail_bounce_secret ON \"sent_mail\" (bounce_secret) WHERE bounce_secret IS NOT NULL")
     , ("sent_mail_recipient",                 "CREATE INDEX sent_mail_recipient ON \"sent_mail\" (recipient) WHERE recipient IS NOT NULL")
@@ -179,692 +135,10 @@ migrateAlwaysSafe = do
 
 customMigrations :: forall m.
                     ( MonadResource m
-                    , MonadReader UniWorX m
+                    -- , MonadReader UniWorX m
                     )
                  => Map ManualMigration (ReaderT SqlBackend m ())
 customMigrations = mapF $ \case
-  Migration20180813SimplifyUserTheme -> whenM (columnExists "user" "theme") $ do -- New theme format
-    userThemes <- [sqlQQ| SELECT "id", "theme" FROM "user"; |]
-    forM_ userThemes $ \(uid, Single str) -> case stripPrefix "theme--" str of
-      Just v
-        | Just theme <- fromPathPiece v -> update uid [UserTheme =. theme]
-      other -> error $ "Could not parse theme: " <> show other
-
-  Migration20180813SheetJSONB -> whenM (tableExists "sheet") -- Better JSON encoding
-    [executeQQ|
-      ALTER TABLE "sheet" ALTER COLUMN "type" TYPE jsonb USING "type"::jsonb;
-      ALTER TABLE "sheet" ALTER COLUMN "grouping" TYPE jsonb USING "grouping"::jsonb;
-    |]
-
-  Migration20180823SchoolShorthandPrimaryKey -> whenM (columnExists "school" "id") $ do -- SchoolId is the Shorthand CI Text now
-    -- Read old table into memory
-    schoolTable <- [sqlQQ| SELECT "id", "shorthand" FROM "school"; |]
-    let _sT = schoolTable :: [(Single Int64, Single (CI Text))] -- Types needed
-    -- Convert columns containing SchoolId
-    whenM (tableExists "user_admin") $ do
-        [executeQQ|
-          ALTER TABLE "user_admin" DROP CONSTRAINT "user_admin_school_fkey";
-          ALTER TABLE "user_admin" ALTER COLUMN "school" TYPE citext USING "school"::citext;
-          |]
-        forM_ schoolTable $ \(Single idnr, Single ssh) ->
-          [executeQQ|
-            UPDATE "user_admin" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
-          |]
-        [executeQQ|
-          ALTER TABLE "user_admin" ADD CONSTRAINT "user_admin_school_fkey"
-            FOREIGN KEY (school) REFERENCES school(shorthand);
-          |]
-    whenM (tableExists "user_lecturer") $ do
-        [executeQQ|
-          ALTER TABLE "user_lecturer" DROP CONSTRAINT "user_lecturer_school_fkey";
-          ALTER TABLE "user_lecturer" ALTER COLUMN "school" TYPE citext USING "school"::citext;
-          |]
-        forM_ schoolTable $ \(Single idnr, Single ssh) ->
-          [executeQQ|
-            UPDATE "user_lecturer" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
-          |]
-        [executeQQ|
-          ALTER TABLE "user_lecturer" ADD CONSTRAINT "user_lecturer_school_fkey"
-              FOREIGN KEY (school) REFERENCES school(shorthand);
-          |]
-    whenM (tableExists "course") $ do
-        [executeQQ|
-          ALTER TABLE "course" DROP CONSTRAINT "course_school_fkey";
-          ALTER TABLE "course" ALTER COLUMN "school" TYPE citext USING "school"::citext;
-          |]
-        forM_ schoolTable $ \(Single idnr, Single ssh) ->
-          [executeQQ|
-            UPDATE "course" SET "school" = #{ssh} WHERE "school" = #{tshow idnr};
-          |]
-        [executeQQ|
-          ALTER TABLE "course" ADD CONSTRAINT "course_school_fkey"
-              FOREIGN KEY (school) REFERENCES school(shorthand);
-          |]
-    [executeQQ|
-      ALTER TABLE "school" DROP COLUMN "id";
-      ALTER TABLE "school" ADD PRIMARY KEY (shorthand);
-    |]
-
-  Migration20180918SheetCorrectorLoadJSON -> whenM (tableExists "sheet_corrector") $ do -- Load is encoded as JSON now.
-    correctorLoads <- [sqlQQ| SELECT "id", "load" FROM "sheet_corrector"; |]
-    forM_ correctorLoads $ \(uid, Single str) -> case readMaybe str of
-      Just load -> update uid [SheetCorrectorLoad =. load]
-      _other -> error $ "Could not parse Load: " <> show str
-    [executeQQ|
-      ALTER TABLE "sheet_corrector" ALTER COLUMN "load" TYPE jsonb USING "load"::jsonb;
-    |]
-
-  Migration20180918UserSurnames -> whenM (tableExists "user") $ do
-    userDisplayNames <- [sqlQQ| SELECT "id", "display_name" FROM "user"; |]
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "surname" text DEFAULT '';
-    |]
-    forM_ userDisplayNames $ \(uid, Single str) -> case lastMaybe $ words str of
-      Just name -> update uid [UserSurname =. name]
-      _other    -> error "Empty userDisplayName found"
-
-  Migration20180918SheetUploadMode -> whenM (tableExists "sheet")
-    [executeQQ|
-      ALTER TABLE "sheet" ADD COLUMN IF NOT EXISTS "upload_mode" jsonb DEFAULT '{ "tag": "Upload", "unpackZips": true }';
-    |]
-
-  Migration20180928UserAuthentication -> whenM (columnExists "user" "plugin")
-    -- <> is standard sql for /=
-    [executeQQ|
-      DELETE FROM "user" WHERE "plugin" <> 'LDAP';
-      ALTER TABLE "user" DROP COLUMN "plugin";
-      ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "authentication" jsonb DEFAULT '"ldap"';
-    |]
-
-  Migration20181011UserNotificationSettings -> whenM (tableExists "user")
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "notification_settings" jsonb NOT NULL DEFAULT '[]';
-    |]
-
-  Migration20181031SheetTypeRefactor -> whenM (tableExists "sheet") $ do
-    sheets <- [sqlQQ| SELECT "id", "type" FROM "sheet"; |]
-    forM_ sheets $ \(sid, Single lsty) -> update sid [SheetType =. Legacy.sheetType lsty]
-  
-  Migration20181129EncodedSecretBoxes -> whenM (tableExists "cluster_config")
-    [executeQQ|
-       UPDATE "cluster_config" SET "setting" = 'secret-box-key' WHERE "setting" = 'error-message-key';
-    |]
-
-  Migration20181130SheetTypeRefactor -> whenM (tableExists "sheet")
-    [executeQQ|
-       UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', "type"->'') WHERE jsonb_exists("type", '');
-       UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points')) WHERE ("type"->'grading'->'type') = '"points"' AND jsonb_exists("type"->'grading', 'points');
-       UPDATE "sheet" SET "type" = json_build_object('type', "type"->'type', 'grading', json_build_object('type', "type"->'grading'->'type', 'max', "type"->'grading'->'points', 'passing', 0)) WHERE ("type"->'grading'->'type') = '"pass-points"' AND jsonb_exists("type"->'grading', 'points');
-    |]
-
-  Migration20190319CourseParticipantField -> whenM ((\a b c -> a && b && not c) <$> tableExists "study_features" <*> tableExists "course_participant" <*> columnExists "course_participant" "field") $ do
-    [executeQQ|
-      ALTER TABLE "course_participant" ADD COLUMN "field" bigint DEFAULT null REFERENCES study_features(id);
-      ALTER TABLE "study_features" ADD COLUMN IF NOT EXISTS "valid" boolean NOT NULL DEFAULT true;
-    |]
-    users <- [sqlQQ| SELECT DISTINCT ON ("user"."id") "user"."id", "study_features"."id" FROM "user", "study_features" WHERE "study_features"."user" = "user"."id" AND "study_features"."valid" AND "study_features"."type" = 'FieldPrimary' ORDER BY "user"."id", random(); |]
-    forM_ users $ \(uid :: UserId, sfid :: StudyFeaturesId) -> [executeQQ| UPDATE "course_participant" SET "field" = #{sfid} WHERE "user" = #{uid} AND "field" IS NULL; |]
-
-  Migration20190320BetterStudyShorthands -> do
-    whenM (columnExists "study_degree" "shorthand") [executeQQ| UPDATE "study_degree" SET "shorthand" = NULL WHERE "shorthand" = '' |]
-    whenM (columnExists "study_degree" "name") [executeQQ| UPDATE "study_degree" SET "name" = NULL WHERE "shorthand" = '' |]
-    whenM (columnExists "study_terms" "shorthand") [executeQQ| UPDATE "study_terms" SET "shorthand" = NULL WHERE "shorthand" = '' |]
-    whenM (columnExists "study_terms" "name") [executeQQ| UPDATE "study_terms" SET "name" = NULL WHERE "shorthand" = '' |]
-
-  Migration20190421MixedSheetSubmissions -> whenM ((&&) <$> columnExists "sheet" "upload_mode" <*> columnExists "sheet" "submission_mode") $ do
-    sheetModes <- [sqlQQ| SELECT "id", "upload_mode", "submission_mode" FROM "sheet"; |]
-    [executeQQ|
-      ALTER TABLE "sheet" DROP COLUMN "upload_mode";
-      ALTER TABLE "sheet" ALTER COLUMN "submission_mode" DROP DEFAULT;
-      ALTER TABLE "sheet" ALTER COLUMN "submission_mode" TYPE jsonb USING 'null'::jsonb;
-    |]
-    forM_ sheetModes $ \(shid :: SheetId, unSingle -> uploadMode :: Legacy.UploadMode, unSingle -> submissionMode :: Legacy.SheetSubmissionMode ) -> do
-      let submissionMode' = case (submissionMode, uploadMode) of
-            ( Legacy.NoSubmissions       , _                   ) -> SubmissionMode False Nothing
-            ( Legacy.CorrectorSubmissions, _                   ) -> SubmissionMode True Nothing
-            ( Legacy.UserSubmissions     , Legacy.NoUpload     ) -> SubmissionMode False (Just NoUpload)
-            ( Legacy.UserSubmissions     , Legacy.Upload True  ) -> SubmissionMode False (Just $ UploadAny True defaultExtensionRestriction True)
-            ( Legacy.UserSubmissions     , Legacy.Upload False ) -> SubmissionMode False (Just $ UploadAny False defaultExtensionRestriction True)
-      [executeQQ| UPDATE "sheet" SET "submission_mode" = #{submissionMode'} WHERE "id" = #{shid}; |]
-
-  Migration20190429Tutorials -> whenM ((&&) <$> tableExists "tutorial" <*> tableExists "tutorial_user") $ do -- Tutorials were an unused stub before
-    tableDropEmpty "tutorial"
-    tableDropEmpty "tutorial_user"
-
-  Migration20190515Exams -> whenM (tableExists "exam") $ -- Exams were an unused stub before
-    tableDropEmpty "exam"
-
-  Migration20190715ExamOccurrenceName -> whenM ((&&) <$> tableExists "exam_occurrence" <*> (not <$> columnExists "exam_occurrence" "name")) $ do
-    examOccurrences <- [sqlQQ| SELECT "id" FROM "exam_occurrence" ORDER BY "exam"; |]
-    [executeQQ|
-      ALTER TABLE "exam_occurrence" ADD COLUMN "name" citext DEFAULT null;
-    |]
-    forM_ (zip [0..] examOccurrences) $ \(n :: Natural, Single eoId :: Single ExamOccurrenceId) -> do
-      let name = [st|occ-#{tshow n}|]
-      [executeQQ| UPDATE "exam_occurrence" SET "name" = #{name} WHERE "id" = #{eoId} |]
-    [executeQQ|
-      ALTER TABLE "exam_occurrence" ALTER COLUMN "name" DROP DEFAULT;
-      ALTER TABLE "exam_occurrence" ALTER COLUMN "name" SET NOT NULL;
-    |]
-
-  Migration20190726UserFirstNamesTitles -> whenM (tableExists "user") $ do
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN "first_name" text NOT NULL DEFAULT '';
-      ALTER TABLE "user" ADD COLUMN "title" text DEFAULT null;
-    |]
-    let getUsers = rawQuery [st|SELECT "id", "display_name", "surname" FROM "user"|] []
-        updateUser (uid, firstName) = [executeQQ|UPDATE "user" SET "first_name" = #{firstName} WHERE "id" = #{uid}|]
-        splitFirstName :: [PersistValue] -> Maybe (UserId, Text)
-        splitFirstName [fromPersistValue -> Right uid, fromPersistValue -> Right displayName, fromPersistValue -> Right surname] = Just . (uid, ) $ if
-          | Just givenName <- Text.stripSuffix surname displayName
-                          <|> Text.stripPrefix surname displayName
-            -> Text.strip givenName
-          | otherwise
-            -> Text.replace surname "…" displayName
-        splitFirstName _ = Nothing
-    runConduit $ getUsers .| C.mapMaybe splitFirstName .| C.mapM_ updateUser
-
-  Migration20190806TransactionLogIds -> whenM (tableExists "transaction_log") $ do
-    [executeQQ|
-      UPDATE transaction_log SET remote = null WHERE remote = #{IPv4 loopbackIP4 :: IP} OR remote = #{IPv6 loopbackIP6 :: IP}
-    |]
-
-    [executeQQ|
-      ALTER TABLE transaction_log ADD COLUMN "initiator_id" bigint DEFAULT null;
-    |]
-
-    whenM (tableExists "user")
-      [executeQQ|
-        UPDATE transaction_log SET initiator_id = "user".id FROM "user" WHERE transaction_log.initiator = "user".ident;
-      |]
-
-    [executeQQ|
-      ALTER TABLE transaction_log DROP COLUMN initiator;
-      ALTER TABLE transaction_log RENAME COLUMN initiator_id TO initiator;
-      ALTER TABLE transaction_log ALTER COLUMN initiator DROP DEFAULT;
-    |]
-
-    let getLogEntries = rawQuery [st|SELECT id, info FROM transaction_log|] []
-        updateTransactionInfo [fromPersistValue -> Right lid, fromPersistValue -> Right (oldT :: Legacy.Transaction)] = do
-          newT <- case oldT of
-            Legacy.TransactionTermEdit tid
-              -> return . Just . TransactionTermEdit $ TermKey tid
-            Legacy.TransactionExamRegister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident
-              -> runMaybeT $ do
-                guardM . lift $ tablesExist ["user", "exam", "course"]
-
-                cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-                eid <- MaybeT . getKeyBy $ UniqueExam cid examn
-                uid <- MaybeT . getKeyBy $ UniqueAuthentication uident
-                return $ TransactionExamRegister eid uid
-            Legacy.TransactionExamDeregister (TermKey -> tid) (SchoolKey -> ssh) csh examn uident
-              -> runMaybeT $ do
-                guardM . lift $ tablesExist ["user", "exam", "course"]
-
-                cid <- MaybeT . getKeyBy $ TermSchoolCourseShort tid ssh csh
-                eid <- MaybeT . getKeyBy $ UniqueExam cid examn
-                uid <- MaybeT . getKeyBy $ UniqueAuthentication uident
-                return $ TransactionExamRegister eid uid
-          whenIsJust newT $ \newT' ->
-            update lid [ TransactionLogInfo =. toJSON newT' ]
-        updateTransactionInfo _ = return ()
-    runConduit $ getLogEntries .| C.mapM_ updateTransactionInfo
-
-  Migration20190828UserFunction -> do
-    [executeQQ|
-      CREATE TABLE IF NOT EXISTS "user_function" ( "id" serial8 primary key, "user" bigint, "school" citext, "function" text );
-    |]
-
-    whenM (tableExists "user_admin") $ do
-      let getAdminEntries = rawQuery [st|SELECT user_admin.id, user_admin.user, user_admin.school FROM user_admin;|] []
-          moveAdminEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
-            [executeQQ|
-              INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolAdmin});
-              DELETE FROM "user_admin" WHERE "id" = #{eId};
-            |]
-          moveAdminEntry _ = return ()
-      runConduit $ getAdminEntries .| C.mapM_ moveAdminEntry
-      tableDropEmpty "user_admin"
-    whenM (tableExists "user_lecturer") $ do
-      let getLecturerEntries = rawQuery [st|SELECT user_lecturer.id, user_lecturer.user, user_lecturer.school FROM user_lecturer;|] []
-          moveLecturerEntry [fromPersistValue -> Right (eId :: Int64), fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (sid :: SchoolId)] =
-            [executeQQ|
-              INSERT INTO "user_function" ("user", "school", "function") VALUES (#{uid}, #{sid}, #{SchoolLecturer});
-              DELETE FROM "user_lecturer" WHERE "id" = #{eId};
-            |]
-          moveLecturerEntry _ = return ()
-      runConduit $ getLecturerEntries .| C.mapM_ moveLecturerEntry
-      tableDropEmpty "user_lecturer"
-    whenM (tableExists "invitation") $ do
-      [executeQQ|
-        DELETE FROM "invitation" WHERE "for"->'junction' = '"UserLecturer"';
-      |]
-
-  Migration20190912UserDisplayEmail -> whenM (tableExists "user") $ do
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN IF NOT EXISTS "display_email" citext;
-      UPDATE "user" SET "display_email" = "email" WHERE "display_email" IS NULL;
-      ALTER TABLE "user" ALTER COLUMN "display_email" SET NOT NULL;
-    |]
-
-  Migration20190916ExamPartNumber -> whenM (tableExists "exam_part") $ do
-    [executeQQ|
-      ALTER TABLE "exam_part" ADD COLUMN IF NOT EXISTS "number" citext;
-    |]
-
-    let getExamEntries = rawQuery [st|SELECT DISTINCT exam FROM exam_part ORDER BY exam;|] []
-        renameExamParts [fromPersistValue -> Right (eId :: ExamId)] = do
-          partNames' <- [sqlQQ|SELECT id, name FROM "exam_part" WHERE exam = #{eId};|]
-          let
-            partNames :: [(ExamPartId, ExamPartName)]
-            partNames = foldMap (\(Single epId, Single pName) -> singletonMap epId pName) partNames'
-
-            partsSorted = partNames
-              & sortOn ( map (\x -> maybe (Left x) Right (readMay x :: Maybe Integer))
-                       . groupBy ((==) `on` Char.isDigit)
-                       . CI.foldedCase
-                       . snd
-                       )
-              & map fst
-          forM_ (zip [_ExamPartNumber' # 1..] partsSorted) $ \(num :: ExamPartNumber, pId) ->
-            [executeQQ|
-              UPDATE "exam_part" SET "number" = #{num} WHERE "id" = #{pId};
-            |]
-        renameExamParts _ = return ()
-    runConduit $ getExamEntries .| C.mapM_ renameExamParts
-
-  Migration20190918ExamRulesRefactor -> whenM (tableExists "exam") $ do
-    oldVersion <- columnExists "exam" "grading_key"
-    if
-      | oldVersion -> do
-        -- Major changes happend to the structure of exams without appropriate
-        -- migration, try to remedy that here
-        tableDropEmpty "exam_part_corrector"
-        tableDropEmpty "exam_corrector"
-        tableDropEmpty "exam_result"
-        tableDropEmpty "exam_registration"
-        tableDropEmpty "exam_occurrence"
-        tableDropEmpty "exam_part"
-        tableDropEmpty "exam"
-      | otherwise ->
-        [executeQQ|
-          ALTER TABLE "exam" ALTER COLUMN "grading_rule" DROP NOT NULL;
-          ALTER TABLE "exam" ALTER COLUMN "bonus_rule" DROP NOT NULL;
-          ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" DROP NOT NULL;
-
-          UPDATE "exam" SET "grading_rule" = NULL WHERE "grading_rule"->>'rule' = 'manual';
-          UPDATE "exam" SET "bonus_rule" = NULL WHERE "bonus_rule"->>'rule' = 'no-bonus';
-          UPDATE "exam" SET "occurrence_rule" = NULL WHERE "occurrence_rule" = '"manual"';
-
-          UPDATE "exam" SET "occurrence_rule" = json_build_object('rule', "occurrence_rule");
-        |]
-
-  Migration20190919ExamBonusRounding -> whenM (tableExists "exam")
-    [executeQQ|
-      UPDATE "exam" SET "bonus_rule" = jsonb_insert("bonus_rule", '{round}' :: text[], '0.01' :: jsonb) WHERE "bonus_rule"->>'rule' = 'bonus-points';
-    |]
-
-  Migration20191002FavouriteReason -> whenM (tableExists "course_favourite")
-    [executeQQ|
-      ALTER TABLE "course_favourite" RENAME COLUMN "time" TO "last_visit";
-      ALTER TABLE "course_favourite" ADD COLUMN "reason" jsonb DEFAULT '"visited"'::jsonb;
-    |]
-
-  Migration20191125UserLanguages -> whenM (tableExists "user")
-    [executeQQ|
-      ALTER TABLE "user" ADD COLUMN "languages" jsonb;
-      UPDATE "user" SET "languages" = "mail_languages" where "mail_languages" <> '[]';
-      ALTER TABLE "user" DROP COLUMN "mail_languages";
-    |]
-
-  Migration20191126ExamPartCorrector -> whenM (tableExists "exam_part_corrector") $
-    tableDropEmpty "exam_part_corrector"
-
-  Migration20191128StudyFeaturesSuperField -> whenM (tableExists "study_features")
-    [executeQQ|
-      ALTER TABLE "study_features" ADD COLUMN "super_field" bigint;
-      UPDATE "study_features" SET "super_field" = "field", "field" = "sub_field" WHERE NOT ("sub_field" IS NULL);
-      ALTER TABLE "study_features" DROP COLUMN "sub_field";
-    |]
-
-  Migration20200111ExamOccurrenceRuleRefactor -> whenM (tableExists "exam")
-    [executeQQ|
-      UPDATE "exam" SET "occurrence_rule" = #{ExamRoomManual} WHERE "occurrence_rule" IS NULL;
-      ALTER TABLE "exam" ALTER COLUMN "occurrence_rule" SET NOT NULL;
-    |]
-
-  Migration20200218ExamResultPassedGrade -> whenM ((&&) <$> tableExists "exam" <*> tableExists "exam_result") $ do
-    queryRes <- [sqlQQ|SELECT exam_result.id, exam_result.result FROM exam_result INNER JOIN exam ON exam_result.exam = exam.id WHERE NOT exam.show_grades;|]
-    forM_ queryRes $ \(resId :: ExamResultId, Single (res :: ExamResultGrade)) ->
-      let res' :: ExamResultPassedGrade
-          res' = Left . view passingGrade <$> res
-       in [executeQQ|UPDATE exam_result SET result = #{res'} WHERE id = #{resId};|]
-
-  Migration20200218ExamGradingModeMixed -> whenM (tableExists "exam")
-    [executeQQ|
-      ALTER TABLE "exam" ADD COLUMN "grading_mode" character varying;
-      UPDATE "exam" SET "grading_mode" = 'grades' WHERE "show_grades";
-      UPDATE "exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades";
-      ALTER TABLE "exam" DROP COLUMN "show_grades";
-      ALTER TABLE "exam" ALTER COLUMN "grading_mode" SET NOT NULL;
-    |]
-
-  Migration20200218ExternalExamGradingModeMixed -> whenM (tableExists "external_exam")
-    [executeQQ|
-      ALTER TABLE "external_exam" ADD COLUMN "grading_mode" character varying;
-      UPDATE "external_exam" SET "grading_mode" = 'grades' WHERE "show_grades";
-      UPDATE "external_exam" SET "grading_mode" = 'pass' WHERE NOT "show_grades";
-      ALTER TABLE "external_exam" DROP COLUMN "show_grades";
-      ALTER TABLE "external_exam" ALTER COLUMN "grading_mode" SET NOT NULL;
-    |]
-
-  Migration20200424SubmissionGroups -> do
-    whenM (tableExists "submission_group") $
-      tableDropEmpty "submission_group"
-    whenM (tableExists "submission_group_edit") $
-      tableDropEmpty "submission_group_edit"
-
-  Migration20200504CourseParticipantState -> whenM (tableExists "course_participant") $ do
-    [executeQQ|
-      ALTER TABLE "course_participant" ADD COLUMN "state" text NOT NULL DEFAULT 'active';
-      ALTER TABLE "course_participant" ALTER COLUMN "state" DROP DEFAULT;
-    |]
-    let getAuditLog = rawQuery [st|SELECT DISTINCT ON ("info") "info", max("time") FROM "transaction_log" GROUP BY "info" ORDER BY "info";|] []
-        ensureParticipant :: [PersistValue] -> ReaderT SqlBackend m ()
-        ensureParticipant [fmap Aeson.fromJSON . fromPersistValue -> Right (Aeson.Success TransactionCourseParticipantEdit{..}), fromPersistValue -> Right (time :: UTCTime)] = do
-          whenM (existsKey transactionCourse `and2M` existsKey transactionUser)
-            [executeQQ|INSERT INTO "course_participant" ("course", "user", "registration", "state") VALUES (#{transactionCourse}, #{transactionUser}, #{time}, #{CourseParticipantInactive False}) ON CONFLICT DO NOTHING;|]
-        ensureParticipant _ = return ()
-    runConduit $ getAuditLog .| C.mapM_ ensureParticipant
-
-  Migration20200506SessionFile -> whenM (tableExists "session_file") $
-    tableDropEmpty "session_file"
-
-  Migration20200627FileRefactor -> whenM (tableExists "file") $ do
-    [executeQQ|
-      ALTER TABLE "file" ADD COLUMN "hash" BYTEA;
-      UPDATE "file" SET "hash" = digest("content", 'sha3-512');
-    |]
-
-    let
-      migrateFromFile :: forall fRef.
-                         ( HasFileReference fRef
-                         , PersistRecordBackend fRef SqlBackend
-                         )
-                      => ([PersistValue] -> (Key fRef, FileReferenceResidual fRef))
-                      -> (Entity fRef -> ReaderT SqlBackend m ())
-                      -> [PersistValue]
-                      -> ReaderT SqlBackend m ()
-      migrateFromFile toResidual doUpdate ((fromPersistValue -> Right (fId :: Int64)):rest) = do
-        let (fRefKey, residual) = toResidual rest
-        fileDat <- [sqlQQ|
-          SELECT "file".title, "file".modified, "file".hash FROM "file" WHERE "id" = #{fId};
-        |]
-        forM_ fileDat $ \case
-          (fromPersistValue . unSingle -> Right (fileReferenceTitle' :: FilePath), fromPersistValue . unSingle -> Right fileReferenceModified, fromPersistValue . unSingle -> Right fileReferenceContent) -> do
-            let fileRef fileReferenceTitle = _FileReference # (FileReference{..}, residual)
-                candidateTitles = fileReferenceTitle' : [ fName <.> ("old-" <> show n) <.> ext | n <- [1..1000] ]
-                  where (fName, ext) = splitExtension fileReferenceTitle'
-            validTitles <- dropWhileM (fmap (is _Just) . checkUnique . fileRef) candidateTitles
-            case validTitles of
-              fTitle : _ -> doUpdate . Entity fRefKey $ fileRef fTitle
-              _other -> error "Could not make validTitle"
-          _other -> return ()
-      migrateFromFile _ _ _ = return ()
-
-    whenM (tableExists "submission_file") $ do
-      [executeQQ|
-        ALTER TABLE "submission_file" ADD COLUMN "title" VARCHAR;
-        ALTER TABLE "submission_file" ADD COLUMN "content" BYTEA NULL;
-        ALTER TABLE "submission_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
-        ALTER TABLE "submission_file" DROP CONSTRAINT "unique_submission_file";
-        ALTER TABLE "submission_file" ADD CONSTRAINT "unique_submission_file" UNIQUE("submission", "title", "is_update");
-      |]
-      let getSubmissionFiles = [queryQQ|SELECT "file", "submission_file"."id", "submission", "is_update", "is_deletion" FROM "submission_file" LEFT OUTER JOIN "file" ON "submission_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
-          toResidual [ fromPersistValue -> Right sfId
-                     , fromPersistValue -> Right submissionFileResidualSubmission
-                     , fromPersistValue -> Right submissionFileResidualIsUpdate
-                     , fromPersistValue -> Right submissionFileResidualIsDeletion
-                     ]
-                     = (sfId, SubmissionFileResidual{..})
-          toResidual _ = error "Could not convert SubmissionFile to residual"
-      runConduit $ getSubmissionFiles .| C.mapM_ (migrateFromFile @SubmissionFile toResidual replaceEntity)
-      [executeQQ|
-        ALTER TABLE "submission_file" DROP COLUMN "file";
-      |]
-
-    whenM (tableExists "sheet_file") $ do
-      [executeQQ|
-        ALTER TABLE "sheet_file" ADD COLUMN "title" VARCHAR;
-        ALTER TABLE "sheet_file" ADD COLUMN "content" BYTEA NULL;
-        ALTER TABLE "sheet_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
-        ALTER TABLE "sheet_file" DROP CONSTRAINT "unique_sheet_file";
-        ALTER TABLE "sheet_file" ADD CONSTRAINT "unique_sheet_file" UNIQUE("sheet", "type", "title");
-      |]
-      let getSheetFiles = [queryQQ|SELECT "file", "sheet_file"."id", "sheet", "type" FROM "sheet_file" LEFT OUTER JOIN "file" ON "sheet_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
-          toResidual [ fromPersistValue -> Right shfId
-                     , fromPersistValue -> Right sheetFileResidualSheet
-                     , fromPersistValue -> Right sheetFileResidualType
-                     ]
-                     = (shfId, SheetFileResidual{..})
-          toResidual _ = error "Could not convert SheetFile to residual"
-      runConduit $ getSheetFiles .| C.mapM_ (migrateFromFile @SheetFile toResidual replaceEntity)
-      [executeQQ|
-        ALTER TABLE "sheet_file" DROP COLUMN "file";
-      |]
-
-    whenM (tableExists "course_news_file") $ do
-      [executeQQ|
-        ALTER TABLE "course_news_file" ADD COLUMN "title" VARCHAR;
-        ALTER TABLE "course_news_file" ADD COLUMN "content" BYTEA NULL;
-        ALTER TABLE "course_news_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
-        ALTER TABLE "course_news_file" DROP CONSTRAINT "unique_course_news_file";
-        ALTER TABLE "course_news_file" ADD CONSTRAINT "unique_course_news_file" UNIQUE("news", "title");
-      |]
-      let getCourseNewsFiles = [queryQQ|SELECT "file", "course_news_file"."id", "news" FROM "course_news_file" LEFT OUTER JOIN "file" ON "course_news_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
-          toResidual [ fromPersistValue -> Right cnfId
-                     , fromPersistValue -> Right courseNewsFileResidualNews
-                     ]
-                     = (cnfId, CourseNewsFileResidual{..})
-          toResidual _ = error "Could not convert CourseNewsFile to residual"
-      runConduit $ getCourseNewsFiles .| C.mapM_ (migrateFromFile @CourseNewsFile toResidual replaceEntity)
-      [executeQQ|
-        ALTER TABLE "course_news_file" DROP COLUMN "file";
-      |]
-
-    whenM (tableExists "material_file") $ do
-      [executeQQ|
-        ALTER TABLE "material_file" ADD COLUMN "title" VARCHAR;
-        ALTER TABLE "material_file" ADD COLUMN "content" BYTEA NULL;
-        ALTER TABLE "material_file" ADD COLUMN "modified" TIMESTAMP WITH TIME ZONE;
-        ALTER TABLE "material_file" DROP CONSTRAINT "unique_material_file";
-        ALTER TABLE "material_file" ADD CONSTRAINT "unique_material_file" UNIQUE("material", "title");
-      |]
-      let getMaterialFiles = [queryQQ|SELECT "file", "material_file"."id", "material" FROM "material_file" LEFT OUTER JOIN "file" ON "material_file"."file" = "file".id ORDER BY "file"."modified" DESC;|]
-          toResidual [ fromPersistValue -> Right shfId
-                     , fromPersistValue -> Right materialFileResidualMaterial
-                     ]
-                     = (shfId, MaterialFileResidual{..})
-          toResidual _ = error "Could not convert MaterialFile to residual"
-      runConduit $ getMaterialFiles .| C.mapM_ (migrateFromFile @MaterialFile toResidual replaceEntity)
-      [executeQQ|
-        ALTER TABLE "material_file" DROP COLUMN "file";
-      |]
-
-    whenM (tableExists "session_file")
-      [executeQQ|
-        ALTER TABLE "session_file" ADD COLUMN "content" BYTEA;
-        UPDATE "session_file" SET "content" = (SELECT "hash" FROM "file" WHERE "file".id = "session_file"."file");
-        ALTER TABLE "session_file" DROP COLUMN "file";
-      |]
-
-    [executeQQ|
-      ALTER TABLE "file" RENAME TO "file_content";
-      DELETE FROM "file_content" WHERE "content" IS NULL OR "hash" IS NULL;
-    |]
-    [executeQQ|
-      DELETE FROM "file_content"
-      WHERE "id" IN (
-          SELECT
-              "id"
-          FROM (
-              SELECT
-                  "id",
-                  ROW_NUMBER() OVER w AS rnum
-              FROM "file_content"
-              WINDOW w AS (
-                  PARTITION BY "hash"
-                  ORDER BY "id"
-              )
-          ) as t
-      WHERE t.rnum > 1);
-    |]
-    [executeQQ|
-      ALTER TABLE "file_content" DROP COLUMN "title";
-      ALTER TABLE "file_content" DROP COLUMN "modified";
-      ALTER TABLE "file_content" DROP COLUMN "id";
-    |]
-
-  Migration20200825StudyFeaturesFirstObserved -> whenM (tableExists "study_features")
-    [executeQQ|
-      ALTER TABLE study_features RENAME updated TO last_observed;
-      ALTER TABLE study_features ADD COLUMN first_observed timestamp with time zone;
-      UPDATE study_features SET first_observed = (SELECT MAX(last_observed) FROM study_features as other WHERE other."user" = study_features."user" AND other.degree = study_features.degree AND other.field = study_features.field AND other.type = study_features.type AND other.semester = study_features.semester - 1);
-    |]
-
-  Migration20200902FileChunking -> whenM (tableExists "file_content") $ do
-    chunkingParams <- lift $ view _appFileChunkingParams
-
-    [executeQQ|
-      ALTER TABLE file_content RENAME TO file_content_chunk;
-      ALTER INDEX file_content_pkey RENAME TO file_content_chunk_pkey;
-
-      CREATE TABLE file_content_chunk_unreferenced (id bigserial, hash bytea NOT NULL, since timestamp with time zone NOT NULL);
-      INSERT INTO file_content_chunk_unreferenced (since, hash) (SELECT unreferenced_since as since, hash FROM file_content_chunk WHERE NOT (unreferenced_since IS NULL));
-      ALTER TABLE file_content_chunk DROP COLUMN unreferenced_since;
-
-      ALTER TABLE file_content_chunk ADD COLUMN content_based boolean NOT NULL DEFAULT false;
-      UPDATE file_content_chunk SET content_based = true WHERE length(content) <= #{fastCDCMinBlockSize chunkingParams};
-
-      CREATE TABLE file_content_entry (id bigserial NOT NULL PRIMARY KEY, hash bytea NOT NULL, ix bigint NOT NULL, chunk_hash bytea NOT NULL);
-      INSERT INTO file_content_entry (hash, chunk_hash, ix) (SELECT hash, hash as chunk_hash, 0 as ix FROM file_content_chunk);
-    |]
-
-  Migration20200916ExamMode -> do
-    whenM (tableExists "exam")
-      [executeQQ|
-        ALTER TABLE exam ADD COLUMN "exam_mode" jsonb NOT NULL DEFAULT #{ExamMode Nothing Nothing Nothing Nothing};
-      |]
-    whenM (tableExists "school")
-      [executeQQ|
-        ALTER TABLE school ADD COLUMN "exam_discouraged_modes" jsonb NOT NULL DEFAULT #{ExamModeDNF predDNFFalse};
-      |]
-
-  Migration20201106StoredMarkup ->
-    [executeQQ|
-      SET client_min_messages TO WARNING;
-      ALTER TABLE IF EXISTS ^{Course} ALTER COLUMN @{CourseDescription} TYPE jsonb USING (CASE WHEN @{CourseDescription} IS NOT NULL THEN to_json(@{CourseDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{CourseEvent} ALTER COLUMN @{CourseEventNote} TYPE jsonb USING (CASE WHEN @{CourseEventNote} IS NOT NULL THEN to_json(@{CourseEventNote}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{CourseUserNote} ALTER COLUMN @{CourseUserNoteNote} TYPE jsonb USING (CASE WHEN @{CourseUserNoteNote} IS NOT NULL THEN to_json(@{CourseUserNoteNote}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{Material} ALTER COLUMN @{MaterialDescription} TYPE jsonb USING (CASE WHEN @{MaterialDescription} IS NOT NULL THEN to_json(@{MaterialDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsContent} TYPE jsonb USING (CASE WHEN @{CourseNewsContent} IS NOT NULL THEN to_json(@{CourseNewsContent}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{CourseNews} ALTER COLUMN @{CourseNewsSummary} TYPE jsonb USING (CASE WHEN @{CourseNewsSummary} IS NOT NULL THEN to_json(@{CourseNewsSummary}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{Exam} ALTER COLUMN @{ExamDescription} TYPE jsonb USING (CASE WHEN @{ExamDescription} IS NOT NULL THEN to_json(@{ExamDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{ExamOccurrence} ALTER COLUMN @{ExamOccurrenceDescription} TYPE jsonb USING (CASE WHEN @{ExamOccurrenceDescription} IS NOT NULL THEN to_json(@{ExamOccurrenceDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetDescription} TYPE jsonb USING (CASE WHEN @{SheetDescription} IS NOT NULL THEN to_json(@{SheetDescription}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{Sheet} ALTER COLUMN @{SheetMarkingText} TYPE jsonb USING (CASE WHEN @{SheetMarkingText} IS NOT NULL THEN to_json(@{SheetMarkingText}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageContent} TYPE jsonb USING (CASE WHEN @{SystemMessageContent} IS NOT NULL THEN to_json(@{SystemMessageContent}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{SystemMessage} ALTER COLUMN @{SystemMessageSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageSummary} IS NOT NULL THEN to_json(@{SystemMessageSummary}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationContent} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationContent} IS NOT NULL THEN to_json(@{SystemMessageTranslationContent}) ELSE NULL END);
-      ALTER TABLE IF EXISTS ^{SystemMessageTranslation} ALTER COLUMN @{SystemMessageTranslationSummary} TYPE jsonb USING (CASE WHEN @{SystemMessageTranslationSummary} IS NOT NULL THEN to_json(@{SystemMessageTranslationSummary}) ELSE NULL END);
-      SET client_min_messages TO NOTICE;
-    |]
-
-  Migration20201119RoomTypes -> do
-    whenM (tableExists "exam_occurrence") $ do
-      [executeQQ|ALTER TABLE "exam_occurrence" ADD COLUMN "room_json" jsonb|]
-      let getExamOccurrences = [queryQQ|SELECT "id", "room" FROM "exam_occurrence"|]
-          migrateExamOccurrence [ fromPersistValue -> Right (eoId :: ExamOccurrenceId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "exam_occurrence" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{eoId}|]
-          migrateExamOccurrence _ = return ()
-       in runConduit $ getExamOccurrences .| C.mapM_ migrateExamOccurrence
-      [executeQQ|
-        ALTER TABLE "exam_occurrence" DROP COLUMN "room";
-        ALTER TABLE "exam_occurrence" RENAME COLUMN "room_json" TO "room";
-      |]
-    whenM (tableExists "tutorial") $ do
-      [executeQQ|ALTER TABLE "tutorial" ADD COLUMN "room_json" jsonb|]
-      let getTutorials = [queryQQ|SELECT "id", "room" FROM "tutorial"|]
-          migrateTutorial [ fromPersistValue -> Right (tutId :: TutorialId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "tutorial" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{tutId}|]
-          migrateTutorial _ = return ()
-       in runConduit $ getTutorials .| C.mapM_ migrateTutorial
-      [executeQQ|
-        ALTER TABLE "tutorial" DROP COLUMN "room";
-        ALTER TABLE "tutorial" RENAME COLUMN "room_json" TO "room";
-      |]
-    whenM (tableExists "course_event") $ do
-      [executeQQ|ALTER TABLE "course_event" ADD COLUMN "room_json" jsonb|]
-      let getCourseEvents = [queryQQ|SELECT "id", "room" FROM "course_event"|]
-          migrateCourseEvent [ fromPersistValue -> Right (ceId :: CourseEventId), fromPersistValue -> Right roomText ] = [executeQQ|UPDATE "course_event" SET "room_json" = #{RoomReferenceSimple roomText} WHERE "id" = #{ceId}|]
-          migrateCourseEvent _ = return ()
-       in runConduit $ getCourseEvents .| C.mapM_ migrateCourseEvent
-      [executeQQ|
-        ALTER TABLE "course_event" DROP COLUMN "room";
-        ALTER TABLE "course_event" RENAME COLUMN "room_json" TO "room";
-      |]
-    whenM (tableExists "course") $ do
-      let getCourses = [queryQQ|SELECT "id", "link_external" FROM "course"|]
-          migrateCourse [ fromPersistValue -> Right (cId :: CourseId), fromPersistValue -> Right (uriText :: Maybe Text) ]
-            | Just uri <- parseURI . unpack =<< uriText = [executeQQ|UPDATE "course" SET "link_external" = #{uri} WHERE "id" = #{cId}|]
-            | otherwise = [executeQQ|UPDATE "course" SET "link_external" = NULL WHERE "id" = #{cId}|]
-          migrateCourse _ = return ()
-       in runConduit $ getCourses .| C.mapM_ migrateCourse
-
-  Migration20210115ExamPartsFrom -> do
-    whenM (tableExists "exam") $ do
-      [executeQQ|ALTER TABLE "exam" ADD COLUMN "parts_from" timestamp with time zone|]
-      let getExam = [queryQQ|SELECT "id", "finished" FROM "exam"|]
-          migrateExam [ fromPersistValue -> Right (eId :: ExamId), fromPersistValue -> Right (finished :: Maybe UTCTime) ] = [executeQQ|UPDATE "exam" SET "parts_from" = #{finished} WHERE "id" = #{eId}|]
-          migrateExam _ = return ()
-       in runConduit $ getExam .| C.mapM_ migrateExam
-
-  Migration20210208StudyFeaturesRelevanceCachedUUIDs ->
-    whenM (tableExists "study_features") $ do
-      [executeQQ|
-        ALTER TABLE "study_features" ADD COLUMN "relevance_cached_uuid" uuid
-      |]
-
-      let getStudyFeatures = [queryQQ|SELECT "id" FROM "study_features" WHERE relevance_cached|]
-          migrateStudyFeatures genUUID lift' [ fromPersistValue -> Right (sfId :: StudyFeaturesId) ] = do
-            uuid <- genUUID
-            lift' [executeQQ|UPDATE "study_features" SET "relevance_cached_uuid" = #{uuid} WHERE "id" = #{sfId}|]
-          migrateStudyFeatures _ _ _ = return ()
-       in runConduit $ getStudyFeatures .| randUUIDC (\genUUID lift' -> C.mapM_ $ migrateStudyFeatures genUUID lift')
-
-      [executeQQ|
-        ALTER TABLE "study_features" DROP COLUMN "relevance_cached";
-        ALTER TABLE "study_features" RENAME COLUMN "relevance_cached_uuid" TO "relevance_cached";
-      |]
-
-  -- Placeholder to inform crontab generation when switchover happened so old submissions don't get notified as corrected
-  Migration20210318CrontabSubmissionRatedNotification -> return ()
-
-  Migration20210608SeparateTermActive -> do
-    now <- liftIO getCurrentTime
-
-    whenM (and2M (tableExists "term") (not <$> tableExists "term_active")) $ do
-      [executeQQ|
-        CREATE TABLE "term_active" ("id" SERIAL8 PRIMARY KEY UNIQUE, "term" numeric(5,1) NOT NULL, "from" timestamp with time zone NOT NULL)
-      |]
-
-      let getTerms = [queryQQ|SELECT "name", "active" FROM "term"|]
-          migrateTerms [ fromPersistValue -> Right (tid :: TermId), fromPersistValue -> Right (isActive :: Bool) ] = when isActive
-            [executeQQ|INSERT INTO term_active (term, "from") VALUES (#{tid}, #{now})|]
-          migrateTerms _ = return ()
-       in runConduit $ getTerms .| C.mapM_ migrateTerms
-
-      [executeQQ|
-        ALTER TABLE "term" DROP COLUMN "active";
-      |]
 
   Migration20230524QualificationUserBlock ->
     whenM (andM [ not <$> tableExists "qualification_user_block"
@@ -904,6 +178,23 @@ customMigrations = mapF $ \case
         ;  
       |]
 
+  Migration20240312OAuth2 -> whenM (andM [ columnNotExists "user" "password_hash", columnExists "user" "authentication", columnExists "user" "last_ldap_synchronisation", columnNotExists "user" "last_sync", columnExists "user" "ldap_primary_key" ]) $ do
+    [executeQQ|
+      ALTER TABLE "user" ADD COLUMN "password_hash" VARCHAR NULL;
+    |]
+    let getPWHashes = [queryQQ| SELECT "id", "authentication"->'pw-hash' FROM "user" WHERE "authentication"->'pw-hash' IS NOT NULL; |]
+        migratePWHash [ fromPersistValue -> Right (uid :: UserId), fromPersistValue -> Right (pwHash :: Text) ] = [executeQQ| UPDATE "user" SET "password_hash" = #{pwHash} WHERE "id" = #{uid}; |]
+        migratePWHash _ = return ()
+     in runConduit $ getPWHashes .| C.mapM_ migratePWHash
+    [executeQQ|
+      ALTER TABLE "user" DROP COLUMN "authentication";
+    |]
+
+    [executeQQ|
+      ALTER TABLE "user" RENAME COLUMN "last_ldap_synchronisation" TO "last_sync";
+      ALTER TABLE "user" DROP COLUMN "ldap_primary_key";
+    |]
+
 
 tableExists :: MonadIO m => Text -> ReaderT SqlBackend m Bool
 tableExists table = do

src/Model/Types.hs

@@ -6,6 +6,7 @@ module Model.Types
   ( module Types
   ) where
 
+import Model.Types.Auth as Types
 import Model.Types.Common as Types
 import Model.Types.Course as Types
 import Model.Types.DateTime as Types
@@ -13,7 +14,6 @@ import Model.Types.Exam as Types
 import Model.Types.ExamOffice as Types
 import Model.Types.Health as Types
 import Model.Types.Mail as Types
-import Model.Types.Security as Types
 import Model.Types.Sheet as Types
 import Model.Types.Submission as Types
 import Model.Types.Misc as Types

src/Model/Types/Auth.hs

@@ -1,75 +1,103 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 {-|
-Module: Model.Types.Security
+Module: Model.Types.Auth
 Description: Types for authentication and authorisation
 -}
 
-module Model.Types.Security
+module Model.Types.Auth
-  ( module Model.Types.Security
+  ( module Model.Types.Auth
   ) where
 
 import ClassyPrelude.Yesod hiding (derivePersistFieldJSON, Proxy(..))
 
-import Utils
-
-import Data.Aeson
-import Data.Aeson.TH
 import Model.Types.TH.JSON
-import Data.Universe
+import Model.Types.TH.PathPiece
-import Data.Universe.Instances.Reverse ()
+
-import Data.Proxy
+import Utils
-import Data.Data (Data)
+import Utils.Lens.TH
 
 import Control.Lens
 
-import qualified Data.Set as Set
+import Data.Aeson
-
+import Data.Aeson.TH
-import qualified Data.Text as Text
-
-import qualified Data.HashMap.Strict as HashMap
-
 import qualified Data.Aeson.Types as Aeson
-
+import qualified Data.Binary as Binary
-import Data.CaseInsensitive (CI)
+import Data.Binary (Binary)
+import Data.Binary.Instances.UnorderedContainers ()
 import qualified Data.CaseInsensitive as CI
+import Data.CaseInsensitive (CI)
 import Data.CaseInsensitive.Instances ()
-
+import Data.Data (Data)
-import Data.Set.Instances ()
+import qualified Data.HashMap.Strict as HashMap
 import Data.NonNull.Instances ()
+import Data.Proxy
+import qualified Data.Set as Set
+import Data.Set.Instances ()
+import qualified Data.Text as Text
+import Data.Universe
+import Data.Universe.Instances.Reverse ()
 import Data.Universe.Instances.Reverse.MonoTraversable ()
+import Data.UUID (UUID)
 
-import Model.Types.TH.PathPiece
 import Database.Persist.Sql
 
 import Servant.Docs (ToSample(..), samples)
-import Utils.Lens.TH
-
-import Data.Binary (Binary)
-import qualified Data.Binary as Binary
-import Data.Binary.Instances.UnorderedContainers ()
 
 
-data AuthenticationMode = AuthLDAP
+----------------------------------
-                        | AuthPWHash { authPWHash :: Text }
+----- Authentication Sources -----
-                        | AuthNoLogin
+----------------------------------
-  deriving (Eq, Ord, Read, Show, Generic)
 
-instance Hashable AuthenticationMode
+type AzureScopes = Set Text
-instance NFData AuthenticationMode
+
+-- Note: Ldap.Host also stores TLS settings, which we will generate ad-hoc based on AuthSourceLdapTls field instead. We therefore use Text to store the hostname only
+-- newtype LdapHost = LdapHost { ldapHost :: Text }
+--   deriving (Eq, Ord, Read, Show, Generic, Data)
+--   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql)
+-- instance E.SqlString LdapHost
+-- makeLenses_ ''LdapHost
+
+-- Note: Ldap.PortNumber comes from Network.Socket, which does not export the constructor of the newtype. Hence, no Data and Generic instances can be derived. But PortNumber is a member of Num, so we will use Word16 instead (Word16 is also used for storing the port number inside PortNumber)
+-- newtype LdapPort = LdapPort { ldapPort :: Word16 }
+--   deriving (Eq, Ord, Read, Show, Generic, Data)
+--   deriving newtype (NFData, PathPiece, PersistField, PersistFieldSql)
+-- instance E.SqlString LdapPort
+-- makeLenses_ ''LdapPort
+
+type UserEduPersonPrincipalName = Text
+
+-- | Subset of the configuration settings of an authentication source that uniquely identify a given source
+-- | Used for uniquely storing ExternalUser entries per user and source
+data AuthSourceIdent
+  = AuthSourceIdAzure
+    { authSourceIdAzureClientId :: UUID -- FIXME: use tenant id instead
+    }
+  | AuthSourceIdLdap
+    { authSourceIdLdapHost :: Text -- normally either just the hostname, or hostname and port
+    }
+  deriving (Eq, Ord, Read, Show, Data, Generic)
+  deriving anyclass (NFData)
 
 deriveJSON defaultOptions
-  { constructorTagModifier  = camelToPathPiece' 1
+  { fieldLabelModifier     = camelToPathPiece' 3
-  , fieldLabelModifier      = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 3
-  , sumEncoding             = UntaggedValue
+  , sumEncoding            = UntaggedValue
-  } ''AuthenticationMode
+  } ''AuthSourceIdent
 
-derivePersistFieldJSON ''AuthenticationMode
+derivePersistFieldJSON ''AuthSourceIdent
 
+makeLenses_ ''AuthSourceIdent
+makePrisms ''AuthSourceIdent
+
+
+-------------------
+----- AuthTag -----
+-------------------
 
 data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer
   = AuthAdmin
@@ -105,8 +133,8 @@ data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prä
   | AuthRegisterGroup
   | AuthEmpty
   | AuthSelf
-  | AuthIsLDAP
+  | AuthIsExternal -- TODO: maybe distinguish between AuthenticationProtocols
-  | AuthIsPWHash
+  | AuthIsInternal
   | AuthAuthentication
   | AuthNoEscalation
   | AuthRead
@@ -179,6 +207,11 @@ _ReducedActiveAuthTags = iso toReducedActiveAuthTags fromReducedActiveAuthTags
     fromReducedActiveAuthTags (ReducedActiveAuthTags hm) = AuthTagActive $ \n -> fromMaybe (authTagIsActive def n) $ HashMap.lookup n hm
 
 
+-------------------
+----- PredDNF -----
+-------------------
+-- TODO: Use external PredDNF instead: https://github.com/savau/haskell-nf
+
 data PredLiteral a = PLVariable { plVar :: a } | PLNegated { plVar :: a }
   deriving (Eq, Ord, Read, Show, Data, Generic)
   deriving anyclass (Hashable, Binary, NFData)
@@ -220,7 +253,6 @@ parsePredDNF start = fmap (PredDNF . Set.mapMonotonic impureNonNull) . ofoldM pa
       | otherwise
         = Left t
 
-
 $(return [])
 
 instance ToJSON a => ToJSON (PredDNF a) where

src/Model/Types/Exam.hs

@@ -73,7 +73,7 @@ import qualified Data.Foldable
 
 import Data.Aeson (genericToJSON, genericParseJSON)
 
-import Model.Types.Security
+import Model.Types.Auth
 
 {-# ANN module ("HLint: ignore Use newtype instead of data" :: String) #-}
 

src/Model/Types/User.hs

@@ -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>
+-- SPDX-FileCopyrightText: 2022-2024 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>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -8,9 +8,6 @@ import Import.NoModel
 import Model.Types.TH.PathPiece
 
 
-type UserEduPersonPrincipalName = Text
-
-
 data SystemFunction
   = SystemExamOffice
   | SystemFaculty

src/Settings.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
+-- SPDX-FileCopyrightText: 2022-2024 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>,David Mosbach <david.mosbach@uniworx.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -13,10 +13,13 @@
 module Settings
   ( module Settings
   , module Settings.Cluster
-  , module Settings.Mime
   , module Settings.Cookies
+  , module Settings.Ldap
   , module Settings.Log
   , module Settings.Locale
+  , module Settings.Mime
+  , module Settings.OAuth2
+  , module Settings.ResourcePool
   ) where
 
 import           Import.NoModel
@@ -41,12 +44,8 @@ import           Language.Haskell.TH.Syntax  (Exp, Q)
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
 import qualified Data.Scientific as Scientific
-import Data.Word (Word16)
 
 import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-
-import qualified Ldap.Client as Ldap
 
 import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
 import qualified Network.Socket as HaskellNet
@@ -56,11 +55,15 @@ import Network.Mail.Mime.Instances ()
 import qualified Database.Memcached.Binary.Types as Memcached
 
 import Model
+
 import Settings.Cluster
-import Settings.Mime
 import Settings.Cookies
+import Settings.Ldap
 import Settings.Log
 import Settings.Locale
+import Settings.Mime
+import Settings.OAuth2
+import Settings.ResourcePool
 
 import qualified System.FilePath as FilePath
 
@@ -73,8 +76,6 @@ import qualified Web.ServerSession.Core as ServerSession
 
 import Text.Show (showParen, showString)
 
-import qualified Data.List.PointedList as P
-
 import qualified Network.Minio as Minio
 
 import Data.Conduit.Algorithms.FastCDC
@@ -84,6 +85,361 @@ import Utils.Lens.TH
 import qualified Data.Set as Set
 
 
+data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
+             | JobsOffload
+             | JobsDrop
+               { jobsAcceptOffload :: Bool
+               , jobsWriteFakeLastExec :: Bool
+               }
+  deriving (Eq, Ord, Read, Show, Generic)
+  deriving anyclass (Hashable)
+
+data ApprootScope = ApprootUserGenerated | ApprootDefault
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+  deriving anyclass (Universe, Finite, Hashable)
+
+
+newtype ServerSessionSettings
+  = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
+
+instance Show ServerSessionSettings where
+  showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"
+
+data UserDefaultConf = UserDefaultConf
+  { userDefaultTheme :: Theme
+  , userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int
+  , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
+  , userDefaultDownloadFiles :: Bool
+  , userDefaultWarningDays :: NominalDiffTime
+  , userDefaultShowSex :: Bool
+  , userDefaultExamOfficeGetSynced :: Bool
+  , userDefaultExamOfficeGetLabels :: Bool
+  , userDefaultPrefersPostal :: Bool
+  } deriving (Show)
+
+data PWHashConf = PWHashConf
+  { pwHashAlgorithm :: PWHashAlgorithm
+  , pwHashStrength :: Int
+  }
+
+instance Show PWHashConf where
+  show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }"
+
+instance FromJSON PWHashConf where
+  parseJSON = withObject "PWHashConf" $ \o -> do
+    pwHashAlgorithm' <- o .: "algorithm" :: Aeson.Parser Text
+    pwHashAlgorithm <- if
+      | pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
+      | pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2
+      | otherwise -> fail "Unsupported hash algorithm"
+    pwHashStrength <- o .: "strength"
+
+    return PWHashConf{..}
+
+
+data AuthSourceConf = AuthSourceConfLdap LdapConf | AuthSourceConfAzureAdV2 AzureConf
+  deriving (Show)
+
+data UserAuthConf =
+      UserAuthConfSingleSource -- ^ use only one specific source
+      { userAuthConfSingleSource :: AuthSourceConf
+      }
+  -- TODO: other modes yet to be implemented
+  -- | UserAuthConfFailover  -- ^ use only one user source at a time, but failover to the next-best database if the current source is unavailable
+  --   { userAuthConfFailoverSources :: PointedList UserSource
+  --   , userAuthConfFailoverRetest  :: NominalDiffTime
+  --   }
+  -- | UserAuthConfMultiSource  -- ^ Multiple coequal user sources
+  --   { userAuthConfMultiSources :: Set UserSource
+  --   }
+  -- | UserAuthConfNoSource -- ^ allow no external sources at all -- TODO: either this, or make user-auth in settings.yml optional
+  deriving (Show)
+
+mkAuthSourceIdent :: AuthSourceConf -> AuthSourceIdent
+mkAuthSourceIdent = \case
+  AuthSourceConfAzureAdV2 AzureConf{..} -> AuthSourceIdAzure azureConfClientId
+  AuthSourceConfLdap      LdapConf{..}  -> AuthSourceIdLdap  ldapConfSourceId
+
+data LmsConf = LmsConf
+  { lmsUploadHeader       :: Bool
+  , lmsUploadDelimiter    :: Maybe Char
+  , lmsDownloadHeader     :: Bool
+  , lmsDownloadDelimiter  :: Char
+  , lmsDownloadCrLf       :: Bool
+  , lmsDeletionDays       :: Int
+  } deriving (Show)
+
+data AvsConf = AvsConf
+  { avsHost :: String
+  , avsPort :: Int
+  , avsUser :: ByteString
+  , avsPass :: ByteString
+  } deriving (Show)
+
+data LprConf = LprConf
+  { lprHost :: String
+  , lprPort :: Int
+  , lprQueue:: String
+  } deriving (Show)
+
+data SmtpConf = SmtpConf
+  { smtpHost :: HaskellNet.HostName
+  , smtpPort :: HaskellNet.PortNumber
+  , smtpAuth :: Maybe SmtpAuthConf
+  , smtpSsl  :: SmtpSslMode
+  , smtpPool :: ResourcePoolConf
+  } deriving (Show)
+
+data WidgetMemcachedConf = WidgetMemcachedConf
+  { widgetMemcachedConf :: MemcachedConf
+  , widgetMemcachedBaseUrl :: Text
+  } deriving (Show)
+
+data MemcachedConf = MemcachedConf
+  { memcachedConnectInfo :: Memcached.ConnectInfo
+  , memcachedExpiry      :: Maybe NominalDiffTime
+  } deriving (Show)
+
+instance FromJSON Memcached.Auth where
+  parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
+
+instance FromJSON MemcachedConf where
+  parseJSON = withObject "MemcachedConf" $ \o -> do
+    connectHost <- o .:? "host" .!= ""
+    connectPort <- o .: "port"
+    connectAuth <- o .: "auth"
+    numConnection <- o .: "limit"
+    connectionIdleTime <- o .: "timeout"
+    memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
+
+    return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
+
+instance FromJSON WidgetMemcachedConf where
+  parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do
+    widgetMemcachedConf <- parseJSON v
+    widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
+    return WidgetMemcachedConf{..}
+
+data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls
+  deriving (Show)
+
+data SmtpAuthConf = SmtpAuthConf
+  { smtpAuthType :: HaskellNet.AuthType
+  , smtpAuthUsername :: HaskellNet.UserName
+  , smtpAuthPassword :: HaskellNet.Password
+  } deriving (Show)
+
+data TokenBucketConf = TokenBucketConf
+  { tokenBucketDepth :: Word64
+  , tokenBucketInvRate :: NominalDiffTime
+  , tokenBucketInitialValue :: Int64
+  } deriving (Eq, Ord, Show, Generic)
+
+data VerpMode = VerpNone
+              | Verp { verpPrefix :: Text, verpSeparator :: Char }
+  deriving (Eq, Show, Read, Generic)
+
+data ARCConf w = ARCConf
+  { arccMaximumGhost :: Int
+  , arccMaximumWeight :: w
+  } deriving (Eq, Ord, Read, Show, Generic)
+
+data PrewarmCacheConf = PrewarmCacheConf
+  { precMaximumWeight :: Int
+  , precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@
+  , precSteps :: Natural
+  , precMaxSpeedup :: Rational
+  } deriving (Eq, Ord, Read, Show, Generic)
+
+data SettingBotMitigation
+  = SettingBotMitigationOnlyLoggedInTableSorting
+  | SettingBotMitigationUnauthorizedFormHoneypots
+  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
+  deriving anyclass (Universe, Finite)
+
+data LegalExternal = LegalExternal
+  { externalLanguage :: Lang 
+  , externalImprint :: Text
+  , externalDataProtection :: Text
+  , externalTermsOfUse :: Text
+  , externalPayments :: Text    
+  }
+  deriving (Eq, Ord, Read, Show, Generic)
+makeLenses_ ''LegalExternal
+
+
+nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1
+pathPieceJSON ''ApprootScope
+pathPieceJSONKey ''ApprootScope
+pathPieceBinary ''ApprootScope
+pathPieceHttpApiData ''ApprootScope
+
+deriveJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 1
+  , fieldLabelModifier = camelToPathPiece' 1
+  , sumEncoding = UntaggedValue
+  } ''VerpMode
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 2
+  } ''TokenBucketConf
+
+deriveFromJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 2
+  } ''UserDefaultConf
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  , constructorTagModifier = camelToPathPiece' 1
+  } ''JobMode
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''ARCConf
+
+deriveJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''PrewarmCacheConf
+
+makeLenses_ ''PrewarmCacheConf
+
+nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3
+pathPieceJSON ''SettingBotMitigation
+pathPieceJSONKey ''SettingBotMitigation
+
+makePrisms ''JobMode
+makeLenses_ ''JobMode
+
+makePrisms ''AuthSourceConf
+makeLenses_ ''UserAuthConf
+makePrisms ''UserAuthConf
+
+deriveFromJSON defaultOptions
+  { constructorTagModifier = toLower . dropPrefix "AuthSourceConf"
+  , sumEncoding = TaggedObject "protocol" "config"
+  } ''AuthSourceConf
+
+deriveFromJSON defaultOptions
+  { constructorTagModifier = camelToPathPiece' 3
+  , fieldLabelModifier = camelToPathPiece' 3
+  , sumEncoding = UntaggedValue -- TaggedObject "mode" "config"
+  , unwrapUnaryRecords = True
+  } ''UserAuthConf
+
+instance FromJSON HaskellNet.PortNumber where
+  parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of
+    Just int -> return $ fromIntegral (int :: Word16)
+    Nothing -> fail "Expected whole number of plausible size to denote port"
+
+deriveFromJSON defaultOptions
+  { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack
+  , allNullaryToStringTag = True
+  } ''HaskellNet.AuthType
+
+instance FromJSON LmsConf where
+  parseJSON = withObject "LmsConf" $ \o -> do
+    lmsUploadHeader       <- o .:  "upload-header"
+    lmsUploadDelimiter    <- o .:? "upload-delimiter"
+    lmsDownloadHeader     <- o .:  "download-header"
+    lmsDownloadDelimiter  <- o .:  "download-delimiter"    
+    lmsDownloadCrLf       <- o .:  "download-cr-lf"
+    lmsDeletionDays       <- o .:  "deletion-days"
+    return LmsConf{..}
+
+makeLenses_ ''LmsConf
+
+instance FromJSON AvsConf where
+  parseJSON = withObject "AvsConf" $ \o -> do
+    avsHost <- o .: "host"
+    avsPort <- o .: "port"
+    avsUser <- o .: "user"
+    avsPass <- o .:? "pass" .!= ""
+    return AvsConf{..}
+
+instance FromJSON LprConf where
+  parseJSON = withObject "LprConf" $ \o -> do
+    lprHost  <- o .: "host"
+    lprPort  <- o .: "port"
+    lprQueue <- o .: "queue"
+    return LprConf{..}
+
+instance FromJSON SmtpConf where
+  parseJSON = withObject "SmtpConf" $ \o -> do
+    smtpHost <- o .:? "host" .!= ""
+    smtpPort <- o .: "port"
+    smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth"
+    smtpSsl <- o .: "ssl"
+    smtpPool <- o .: "pool"
+    return SmtpConf{..}
+
+deriveFromJSON
+  defaultOptions
+    { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
+    , allNullaryToStringTag = True
+    }
+  ''SmtpSslMode
+
+instance FromJSON SmtpAuthConf where
+  parseJSON = withObject "SmtpAuthConf" $ \o -> do
+    smtpAuthType <- o .: "type"
+    smtpAuthUsername <- o .:? "user" .!= ""
+    smtpAuthPassword <- o .:? "pass" .!= ""
+    return SmtpAuthConf{..}
+
+instance FromJSON JwtEncoding where
+  parseJSON v@(String _) = JwsEncoding <$> parseJSON v
+  parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
+    [ do
+        alg <- obj .: "alg"
+        return $ JwsEncoding alg
+    , do
+        alg <- obj .: "alg"
+        enc <- obj .: "enc"
+        return $ JweEncoding alg enc
+    ]
+
+instance FromJSON Minio.ConnectInfo where
+  parseJSON v@(String _) = fromString <$> parseJSON v
+  parseJSON v = flip (withObject "ConnectInfo") v $ \o -> do
+    connectHost <- o .:? "host" .!= ""
+    connectPort <- o .: "port"
+    connectAccessKey <- o .:? "access-key" .!= ""
+    connectSecretKey <- o .:? "secret-key" .!= ""
+    connectIsSecure <- o .: "is-secure"
+    connectRegion <- o .:? "region" .!= ""
+    connectAutoDiscoverRegion <- o .:? "auto-discover-region" .!= True
+    connectDisableTLSCertValidation <- o .:? "disable-cert-validation" .!= False
+    return Minio.ConnectInfo{..}
+
+instance FromJSON ServerSessionSettings where
+  parseJSON = withObject "ServerSession.State" $ \o -> do
+    idleTimeout <- o .:? "idle-timeout"
+    absoluteTimeout <- o .:? "absolute-timeout"
+    timeoutResolution <- o .:? "timeout-resolution"
+    persistentCookies <- o .:? "persistent-cookies"
+    return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes
+      [ pure $ ServerSession.setIdleTimeout idleTimeout
+      , pure $ ServerSession.setAbsoluteTimeout absoluteTimeout
+      , pure $ ServerSession.setTimeoutResolution timeoutResolution
+      , ServerSession.setPersistentCookies <$> persistentCookies
+      ])
+
+instance FromJSON LegalExternal where 
+  parseJSON = withObject "LegalExternal" $ \o -> do
+    externalLanguage <- o .: "language"
+    externalImprint <- o .: "imprint"
+    externalDataProtection <- o .: "data-protection"
+    externalTermsOfUse<- o .: "terms-of-use"
+    externalPayments <- o .: "payments"
+    return LegalExternal{..}
+
+submissionBlacklist :: [Pattern]
+submissionBlacklist = $$(patternFile compDefault "config/submission-blacklist")
+
+personalisedSheetFilesCollatable :: Map Text Pattern
+personalisedSheetFilesCollatable = $$(patternFile' compDefault "config/personalised-sheet-files-collate")
+
+
 -- | Runtime settings to configure this application. These settings can be
 -- loaded from various sources: defaults, environment variables, config files,
 -- theoretically even a database.
@@ -96,14 +452,13 @@ data AppSettings = AppSettings
     , appDatabaseConf           :: PostgresConf
     -- ^ Configuration settings for accessing the database.
     , appAutoDbMigrate          :: Bool
+    , appUserAuthConf           :: UserAuthConf
     , appSingleSignOn           :: Bool
     -- ^ Enable OIDC single sign-on
-    , appLdapConf               :: Maybe (PointedList LdapConf)
-    -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System)
     , appLmsConf                :: LmsConf
-    -- ^ Configuration settings for accessing the LDAP-directory
+    -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) -- TODO, TODISCUSS: reimplement as user-auth source?
     , appAvsConf                :: Maybe AvsConf
-    -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System)
+    -- ^ Configuration settings for accessing AVS Server (= Ausweis Verwaltungs System) -- TODO, TODISCUSS: reimplement as user-auth source?
     , appLprConf                :: LprConf
     -- ^ Configuration settings for accessing a printer queue via lpr for letter mailing
     , appSmtpConf               :: Maybe SmtpConf
@@ -111,15 +466,13 @@ data AppSettings = AppSettings
     , appWidgetMemcachedConf    :: Maybe WidgetMemcachedConf
     -- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent`
     , appRoot                   :: ApprootScope -> Maybe Text
-    -- ^ Base for all generated URLs. If @Nothing@, determined
+    -- ^ Base for all generated URLs. If @Nothing@, determined from the request headers.
-    -- from the request headers.
     , appHost                   :: HostPreference
     -- ^ Host/interface the server should bind to.
     , appPort                   :: Int
     -- ^ Port to listen on
     , appIpFromHeader           :: Bool
-    -- ^ Get the IP address from the header when logging. Useful when sitting
+    -- ^ Get the IP address from the header when logging. Useful when sitting behind a reverse proxy.
-    -- behind a reverse proxy.
 
     , appServerSessionConfig    :: ServerSessionSettings
     , appServerSessionAcidFallback :: Bool
@@ -160,18 +513,21 @@ data AppSettings = AppSettings
     , appHealthCheckActiveJobExecutorsTimeout :: NominalDiffTime
     , appHealthCheckActiveWidgetMemcachedTimeout :: NominalDiffTime
     , appHealthCheckSMTPConnectTimeout :: NominalDiffTime
-    , appHealthCheckLDAPAdminsTimeout :: NominalDiffTime
+    , appHealthCheckLDAPAdminsTimeout :: NominalDiffTime -- TODO: either generalize over every external auth sources, or otherwise reimplement for different semantics
     , appHealthCheckHTTPReachableTimeout :: NominalDiffTime
     , appHealthCheckMatchingClusterConfigTimeout :: NominalDiffTime
 
-    , appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime
+    -- , appUserRetestFailover :: DiffTime -- TODO: reintroduce and move into failover settings once failover mode has been reimplemented
-    , appSynchroniseLdapUsersInterval :: NominalDiffTime
+    -- TODO; maybe implement syncWithin and syncInterval per auth source
+    , appUserSyncWithin     :: Maybe NominalDiffTime
+    , appUserSyncInterval   :: NominalDiffTime
 
-    , appSynchroniseAvsUsersWithin :: Maybe NominalDiffTime
+    , appLdapPoolConf :: Maybe ResourcePoolConf -- TODO: generalize for arbitrary auth protocols
+                                                -- TODO: maybe use separate pools for external databases?
+
+    , appSynchroniseAvsUsersWithin   :: Maybe NominalDiffTime
     , appSynchroniseAvsUsersInterval :: NominalDiffTime
 
-    , appLdapReTestFailover :: DiffTime
-
     , appSessionFilesExpire     :: NominalDiffTime
     , appKeepUnreferencedFiles  :: NominalDiffTime
 
@@ -256,365 +612,6 @@ data AppSettings = AppSettings
     
     } deriving Show
 
-
-data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
-             | JobsOffload
-             | JobsDrop
-               { jobsAcceptOffload :: Bool
-               , jobsWriteFakeLastExec :: Bool
-               }
-  deriving (Eq, Ord, Read, Show, Generic)
-  deriving anyclass (Hashable)
-
-data ApprootScope = ApprootUserGenerated | ApprootDefault
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
-  deriving anyclass (Universe, Finite, Hashable)
-
-
-newtype ServerSessionSettings
-  = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
-
-instance Show ServerSessionSettings where
-  showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"
-
-data UserDefaultConf = UserDefaultConf
-  { userDefaultTheme :: Theme
-  , userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int
-  , userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
-  , userDefaultDownloadFiles :: Bool
-  , userDefaultWarningDays :: NominalDiffTime
-  , userDefaultShowSex :: Bool
-  , userDefaultExamOfficeGetSynced :: Bool
-  , userDefaultExamOfficeGetLabels :: Bool
-  , userDefaultPrefersPostal :: Bool
-  } deriving (Show)
-
-data PWHashConf = PWHashConf
-  { pwHashAlgorithm :: PWHashAlgorithm
-  , pwHashStrength :: Int
-  }
-
-instance Show PWHashConf where
-  show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }"
-
-instance FromJSON PWHashConf where
-  parseJSON = withObject "PWHashConf" $ \o -> do
-    pwHashAlgorithm' <- o .: "algorithm" :: Aeson.Parser Text
-    pwHashAlgorithm <- if
-      | pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
-      | pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2
-      | otherwise -> fail "Unsupported hash algorithm"
-    pwHashStrength <- o .: "strength"
-
-    return PWHashConf{..}
-
-data LdapConf = LdapConf
-  { ldapHost :: Ldap.Host, ldapPort :: Ldap.PortNumber
-  , ldapDn :: Ldap.Dn, ldapPassword :: Ldap.Password
-  , ldapBase :: Ldap.Dn
-  , ldapScope :: Ldap.Scope
-  , ldapTimeout :: NominalDiffTime
-  , ldapSearchTimeout :: Int32
-  , ldapPool :: ResourcePoolConf
-  } deriving (Show)
-
-data LmsConf = LmsConf
-  { lmsUploadHeader       :: Bool
-  , lmsUploadDelimiter    :: Maybe Char
-  , lmsDownloadHeader     :: Bool
-  , lmsDownloadDelimiter  :: Char
-  , lmsDownloadCrLf       :: Bool
-  , lmsDeletionDays       :: Int
-  } deriving (Show)
-
-data AvsConf = AvsConf
-  { avsHost :: String
-  , avsPort :: Int
-  , avsUser :: ByteString
-  , avsPass :: ByteString
-  } deriving (Show)
-
-data LprConf = LprConf
-  { lprHost :: String
-  , lprPort :: Int
-  , lprQueue:: String
-  } deriving (Show)
-
-data SmtpConf = SmtpConf
-  { smtpHost :: HaskellNet.HostName
-  , smtpPort :: HaskellNet.PortNumber
-  , smtpAuth :: Maybe SmtpAuthConf
-  , smtpSsl  :: SmtpSslMode
-  , smtpPool :: ResourcePoolConf
-  } deriving (Show)
-
-data WidgetMemcachedConf = WidgetMemcachedConf
-  { widgetMemcachedConf :: MemcachedConf
-  , widgetMemcachedBaseUrl :: Text
-  } deriving (Show)
-
-data MemcachedConf = MemcachedConf
-  { memcachedConnectInfo :: Memcached.ConnectInfo
-  , memcachedExpiry      :: Maybe NominalDiffTime
-  } deriving (Show)
-
-instance FromJSON Memcached.Auth where
-  parseJSON = Aeson.withText "Auth" $ \(Text.breakOn "@" -> (encodeUtf8 -> user, encodeUtf8 -> pw)) -> return $ Memcached.Plain user pw
-
-instance FromJSON MemcachedConf where
-  parseJSON = withObject "MemcachedConf" $ \o -> do
-    connectHost <- o .:? "host" .!= ""
-    connectPort <- o .: "port"
-    connectAuth <- o .: "auth"
-    numConnection <- o .: "limit"
-    connectionIdleTime <- o .: "timeout"
-    memcachedExpiry <- assertM (maybe True $ \t -> 0 < t && t <= 30 * nominalDay) $ o .:? "expiration"
-
-    return MemcachedConf{ memcachedConnectInfo = Memcached.ConnectInfo{..}, .. }
-
-instance FromJSON WidgetMemcachedConf where
-  parseJSON v = flip (withObject "WidgetMemcachedConf") v $ \o -> do
-    widgetMemcachedConf <- parseJSON v
-    widgetMemcachedBaseUrl <- o .:? "base-url" .!= ""
-    return WidgetMemcachedConf{..}
-
-data ResourcePoolConf = ResourcePoolConf
-  { poolStripes :: Int
-  , poolTimeout :: NominalDiffTime
-  , poolLimit :: Int
-  } deriving (Show)
-
-data SmtpSslMode = SmtpSslNone | SmtpSslSmtps | SmtpSslStarttls
-  deriving (Show)
-
-data SmtpAuthConf = SmtpAuthConf
-  { smtpAuthType :: HaskellNet.AuthType
-  , smtpAuthUsername :: HaskellNet.UserName
-  , smtpAuthPassword :: HaskellNet.Password
-  } deriving (Show)
-
-data TokenBucketConf = TokenBucketConf
-  { tokenBucketDepth :: Word64
-  , tokenBucketInvRate :: NominalDiffTime
-  , tokenBucketInitialValue :: Int64
-  } deriving (Eq, Ord, Show, Generic)
-
-data VerpMode = VerpNone
-              | Verp { verpPrefix :: Text, verpSeparator :: Char }
-  deriving (Eq, Show, Read, Generic)
-
-data ARCConf w = ARCConf
-  { arccMaximumGhost :: Int
-  , arccMaximumWeight :: w
-  } deriving (Eq, Ord, Read, Show, Generic)
-
-data PrewarmCacheConf = PrewarmCacheConf
-  { precMaximumWeight :: Int
-  , precStart, precEnd, precInhibit :: NominalDiffTime -- ^ Prewarming cache starts at @t - precStart@ and should be finished by @t - precEnd@; injecting from minio to database is inhibited from @t - precStart@ until @t - precStart + precInhibit@
-  , precSteps :: Natural
-  , precMaxSpeedup :: Rational
-  } deriving (Eq, Ord, Read, Show, Generic)
-
-data SettingBotMitigation
-  = SettingBotMitigationOnlyLoggedInTableSorting
-  | SettingBotMitigationUnauthorizedFormHoneypots
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
-  deriving anyclass (Universe, Finite)
-
-data LegalExternal = LegalExternal
-  { externalLanguage :: Lang 
-  , externalImprint :: Text
-  , externalDataProtection :: Text
-  , externalTermsOfUse :: Text
-  , externalPayments :: Text    
-  }
-  deriving (Eq, Ord, Read, Show, Generic)
-makeLenses_ ''LegalExternal
-
-
-nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1
-pathPieceJSON ''ApprootScope
-pathPieceJSONKey ''ApprootScope
-pathPieceBinary ''ApprootScope
-pathPieceHttpApiData ''ApprootScope
-
-deriveJSON defaultOptions
-  { constructorTagModifier = camelToPathPiece' 1
-  , fieldLabelModifier = camelToPathPiece' 1
-  , sumEncoding = UntaggedValue
-  } ''VerpMode
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 2
-  } ''TokenBucketConf
-
-deriveFromJSON defaultOptions ''Ldap.Scope
-deriveFromJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 2
-  } ''UserDefaultConf
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  , constructorTagModifier = camelToPathPiece' 1
-  } ''JobMode
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''ARCConf
-
-deriveJSON defaultOptions
-  { fieldLabelModifier = camelToPathPiece' 1
-  } ''PrewarmCacheConf
-
-makeLenses_ ''PrewarmCacheConf
-
-nullaryPathPiece ''SettingBotMitigation $ camelToPathPiece' 3
-pathPieceJSON ''SettingBotMitigation
-pathPieceJSONKey ''SettingBotMitigation
-
-makePrisms ''JobMode
-makeLenses_ ''JobMode
-
-
-instance FromJSON LdapConf where
-    parseJSON = withObject "LdapConf" $ \o -> do
-        ldapTls <- o .:? "tls"
-        tlsSettings <- case ldapTls :: Maybe String of
-          Just spec
-            | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
-            | spec == "default"  -> return $ Just Ldap.defaultTlsSettings
-            | spec == "none"     -> return Nothing
-            | spec == "notls"    -> return Nothing
-            | null spec          -> return Nothing
-          Nothing                -> return Nothing
-          _otherwise             -> fail "Could not parse LDAP TLSSettings"
-        ldapHost <- maybe Ldap.Plain (flip Ldap.Tls) tlsSettings <$> o .:? "host" .!= ""
-        ldapPort <- (fromIntegral :: Int -> Ldap.PortNumber) <$> o .: "port"
-        ldapDn <- Ldap.Dn <$> o .:? "user" .!= ""
-        ldapPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= ""
-        ldapBase <- Ldap.Dn <$> o .:? "baseDN" .!= ""
-        ldapScope <- o .: "scope"
-        ldapTimeout <- o .: "timeout"
-        ldapSearchTimeout <- o .: "search-timeout"
-        ldapPool <- o .: "pool"
-        return LdapConf{..}
-
-deriveFromJSON
-  defaultOptions
-    { fieldLabelModifier = intercalate "-" . map toLower . drop 1 . splitCamel
-    }
-  ''ResourcePoolConf
-
-instance FromJSON HaskellNet.PortNumber where
-  parseJSON = withScientific "PortNumber" $ \sciNum -> case Scientific.toBoundedInteger sciNum of
-    Just int -> return $ fromIntegral (int :: Word16)
-    Nothing -> fail "Expected whole number of plausible size to denote port"
-
-deriveFromJSON
-  defaultOptions
-    { constructorTagModifier = unpack . intercalate "-" . Text.splitOn "_" . toLower . pack
-    , allNullaryToStringTag = True
-    }
-  ''HaskellNet.AuthType
-
-instance FromJSON LmsConf where
-  parseJSON = withObject "LmsConf" $ \o -> do
-    lmsUploadHeader       <- o .:  "upload-header"
-    lmsUploadDelimiter    <- o .:? "upload-delimiter"
-    lmsDownloadHeader     <- o .:  "download-header"
-    lmsDownloadDelimiter  <- o .:  "download-delimiter"    
-    lmsDownloadCrLf       <- o .:  "download-cr-lf"
-    lmsDeletionDays       <- o .:  "deletion-days"
-    return LmsConf{..}
-
-makeLenses_ ''LmsConf
-
-instance FromJSON AvsConf where
-  parseJSON = withObject "AvsConf" $ \o -> do
-    avsHost <- o .: "host"
-    avsPort <- o .: "port"
-    avsUser <- o .: "user"
-    avsPass <- o .:? "pass" .!= ""
-    return AvsConf{..}
-
-instance FromJSON LprConf where
-  parseJSON = withObject "LprConf" $ \o -> do
-    lprHost  <- o .: "host"
-    lprPort  <- o .: "port"
-    lprQueue <- o .: "queue"
-    return LprConf{..}
-
-instance FromJSON SmtpConf where
-  parseJSON = withObject "SmtpConf" $ \o -> do
-    smtpHost <- o .:? "host" .!= ""
-    smtpPort <- o .: "port"
-    smtpAuth <- assertM (not . null . smtpAuthUsername) <$> o .:? "auth"
-    smtpSsl <- o .: "ssl"
-    smtpPool <- o .: "pool"
-    return SmtpConf{..}
-
-deriveFromJSON
-  defaultOptions
-    { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel
-    , allNullaryToStringTag = True
-    }
-  ''SmtpSslMode
-
-instance FromJSON SmtpAuthConf where
-  parseJSON = withObject "SmtpAuthConf" $ \o -> do
-    smtpAuthType <- o .: "type"
-    smtpAuthUsername <- o .:? "user" .!= ""
-    smtpAuthPassword <- o .:? "pass" .!= ""
-    return SmtpAuthConf{..}
-
-instance FromJSON JwtEncoding where
-  parseJSON v@(String _) = JwsEncoding <$> parseJSON v
-  parseJSON v = flip (withObject "JwtEncoding") v $ \obj -> asum
-    [ do
-        alg <- obj .: "alg"
-        return $ JwsEncoding alg
-    , do
-        alg <- obj .: "alg"
-        enc <- obj .: "enc"
-        return $ JweEncoding alg enc
-    ]
-
-instance FromJSON Minio.ConnectInfo where
-  parseJSON v@(String _) = fromString <$> parseJSON v
-  parseJSON v = flip (withObject "ConnectInfo") v $ \o -> do
-    connectHost <- o .:? "host" .!= ""
-    connectPort <- o .: "port"
-    connectAccessKey <- o .:? "access-key" .!= ""
-    connectSecretKey <- o .:? "secret-key" .!= ""
-    connectIsSecure <- o .: "is-secure"
-    connectRegion <- o .:? "region" .!= ""
-    connectAutoDiscoverRegion <- o .:? "auto-discover-region" .!= True
-    connectDisableTLSCertValidation <- o .:? "disable-cert-validation" .!= False
-    return Minio.ConnectInfo{..}
-
-
-instance FromJSON ServerSessionSettings where
-  parseJSON = withObject "ServerSession.State" $ \o -> do
-    idleTimeout <- o .:? "idle-timeout"
-    absoluteTimeout <- o .:? "absolute-timeout"
-    timeoutResolution <- o .:? "timeout-resolution"
-    persistentCookies <- o .:? "persistent-cookies"
-    return $ ServerSessionSettings (appEndo . foldMap Endo $ catMaybes
-      [ pure $ ServerSession.setIdleTimeout idleTimeout
-      , pure $ ServerSession.setAbsoluteTimeout absoluteTimeout
-      , pure $ ServerSession.setTimeoutResolution timeoutResolution
-      , ServerSession.setPersistentCookies <$> persistentCookies
-      ])
-
-instance FromJSON LegalExternal where 
-  parseJSON = withObject "LegalExternal" $ \o -> do
-    externalLanguage <- o .: "language"
-    externalImprint <- o .: "imprint"
-    externalDataProtection <- o .: "data-protection"
-    externalTermsOfUse<- o .: "terms-of-use"
-    externalPayments <- o .: "payments"
-    return LegalExternal{..}
-
 instance FromJSON AppSettings where
     parseJSON = withObject "AppSettings" $ \o -> do
         let defaultDev =
@@ -629,11 +626,15 @@ instance FromJSON AppSettings where
         appWebpackEntrypoints     <- o .: "webpack-manifest"
         appDatabaseConf           <- o .: "database"
         appAutoDbMigrate          <- o .: "auto-db-migrate"
+        -- TODO: reintroduce non-emptyness check for ldap hosts
+        -- let nonEmptyHost (UserDbLdap LdapConf{..}) = case ldapHost of
+        --       Ldap.Tls host _ -> not $ null host
+        --       Ldap.Plain host -> not $ null host
+        --     nonEmptyHost (UserDbOAuth2 OAuth2Conf{..}) = not $ or [ null oauth2TenantId, null oauth2ClientId, null oauth2ClientSecret ]
+        appUserAuthConf           <- o .: "user-auth"
+        -- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "user-database" .!= []
+        appLdapPoolConf           <- o .:? "ldap-pool"
         appSingleSignOn           <- o .: "single-sign-on"
-        let nonEmptyHost LdapConf{..} = case ldapHost of
-              Ldap.Tls host _ -> not $ null host
-              Ldap.Plain host -> not $ null host
-        appLdapConf               <- P.fromList . mapMaybe (assertM nonEmptyHost) <$> o .:? "ldap" .!= []
         appLmsConf                <- o .: "lms-direct"
         appAvsConf                <- assertM (not . null . avsPass)  <$> o .:? "avs"
         appLprConf                <- o .: "lpr"
@@ -698,14 +699,13 @@ instance FromJSON AppSettings where
 
         appSessionTimeout         <- o .: "session-timeout"
 
-        appSynchroniseLdapUsersWithin   <- o .:? "synchronise-ldap-users-within"
+        -- appUserRetestFailover     <- o .:  "userdb-retest-failover"
-        appSynchroniseLdapUsersInterval <- o .:  "synchronise-ldap-users-interval"
+        appUserSyncWithin   <- o .:? "user-sync-within"
+        appUserSyncInterval <- o .:  "user-sync-interval"
 
         appSynchroniseAvsUsersWithin    <- o .:? "synchronise-avs-users-within"
         appSynchroniseAvsUsersInterval  <- o .:  "synchronise-avs-users-interval"
 
-        appLdapReTestFailover     <- o .:  "ldap-re-test-failover"
-
         appSessionFilesExpire     <- o .:  "session-files-expire"
         appKeepUnreferencedFiles  <- o .:? "keep-unreferenced-files" .!= 0
         appInjectFiles            <- o .:? "inject-files"
@@ -819,6 +819,26 @@ instance FromJSON AppSettings where
 
 makeClassy_ ''AppSettings
 
+-- | Raw bytes at compile time of @config/settings.yml@
+configSettingsYmlBS :: ByteString
+configSettingsYmlBS = $(embedFile configSettingsYml)
+
+-- | @config/settings.yml@, parsed to a @Value@.
+configSettingsYmlValue :: Value
+configSettingsYmlValue = either Exception.throw id
+                       $ decodeEither' configSettingsYmlBS
+
+-- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
+compileTimeAppSettings :: AppSettings
+compileTimeAppSettings =
+    case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
+        Aeson.Error e -> error e
+        Aeson.Success settings -> settings
+
+-- Since widgetFile above also add "templates" directory, requires import Text.Hamlet (hamletFile)
+-- hamletFile' :: FilePath -> Q Exp
+-- hamletFile' nameBase = hamletFile $ "templates" </> nameBase
+
 -- | Settings for 'widgetFile', such as which template languages to support and
 -- default Hamlet settings.
 --
@@ -828,16 +848,6 @@ makeClassy_ ''AppSettings
 widgetFileSettings :: WidgetFileSettings
 widgetFileSettings = def
 
-
-submissionBlacklist :: [Pattern]
-submissionBlacklist = $$(patternFile compDefault "config/submission-blacklist")
-
-personalisedSheetFilesCollatable :: Map Text Pattern
-personalisedSheetFilesCollatable = $$(patternFile' compDefault "config/personalised-sheet-files-collate")
-
--- The rest of this file contains settings which rarely need changing by a
--- user.
-
 widgetFile :: String -> Q Exp
 #ifdef DEVELOPMENT
 widgetFile nameBase = do
@@ -858,24 +868,3 @@ widgetFile
   | otherwise
   = widgetFileNoReload widgetFileSettings
 #endif
-
--- Since widgetFile above also add "templates" directory, requires import Text.Hamlet (hamletFile)
--- hamletFile' :: FilePath -> Q Exp
--- hamletFile' nameBase = hamletFile $ "templates" </> nameBase
-
-
--- | Raw bytes at compile time of @config/settings.yml@
-configSettingsYmlBS :: ByteString
-configSettingsYmlBS = $(embedFile configSettingsYml)
-
--- | @config/settings.yml@, parsed to a @Value@.
-configSettingsYmlValue :: Value
-configSettingsYmlValue = either Exception.throw id
-                       $ decodeEither' configSettingsYmlBS
-
--- | A version of @AppSettings@ parsed at compile time from @config/settings.yml@.
-compileTimeAppSettings :: AppSettings
-compileTimeAppSettings =
-    case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of
-        Aeson.Error e -> error e
-        Aeson.Success settings -> settings

src/Settings/Ldap.hs

@@ -0,0 +1,63 @@
+-- SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@uniworx.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Settings.Ldap
+  ( LdapConf(..)
+  , _ldapConfHost, _ldapConfPort, _ldapConfSourceId, _ldapConfDn, _ldapConfPassword, _ldapConfBase, _ldapConfScope, _ldapConfTimeout, _ldapConfSearchTimeout
+  ) where
+
+import ClassyPrelude
+
+import Utils.Lens.TH
+
+import Control.Monad.Fail (fail)
+
+import Data.Aeson
+import qualified Data.Text.Encoding as Text
+import Data.Time.Clock
+
+import qualified Ldap.Client as Ldap
+import Ldap.Client.Instances ()
+
+
+data LdapConf = LdapConf
+  { ldapConfHost     :: Ldap.Host
+  , ldapConfPort     :: Ldap.PortNumber
+  , ldapConfSourceId :: Text
+  -- ^ Some unique identifier for this LDAP instance, e.g. hostname or hostname:port
+  , ldapConfDn       :: Ldap.Dn
+  , ldapConfPassword :: Ldap.Password
+  , ldapConfBase     :: Ldap.Dn
+  , ldapConfScope    :: Ldap.Scope
+  , ldapConfTimeout  :: NominalDiffTime
+  , ldapConfSearchTimeout :: Int32
+  } deriving (Show)
+
+makeLenses_ ''LdapConf
+
+instance FromJSON LdapConf where
+  parseJSON = withObject "LdapConf" $ \o -> do
+    ldapConfTls <- o .:? "tls"
+    tlsSettings <- case ldapConfTls :: Maybe String of
+      Just spec
+        | spec == "insecure" -> return $ Just Ldap.insecureTlsSettings
+        | spec == "default"  -> return $ Just Ldap.defaultTlsSettings
+        | spec == "none"     -> return Nothing
+        | spec == "notls"    -> return Nothing
+        | null spec          -> return Nothing
+      Nothing                -> return Nothing
+      _otherwise             -> fail "Could not parse LDAP TLSSettings"
+    hostname :: Text <- o .: "host"
+    port :: Int <- o .: "port"
+    let
+      ldapConfHost = maybe Ldap.Plain (flip Ldap.Tls) tlsSettings $ show hostname
+      ldapConfPort = fromIntegral port
+    ldapConfSourceId <- o .:? "source-id" .!= hostname
+    ldapConfDn <- Ldap.Dn <$> o .:? "user" .!= ""
+    ldapConfPassword <- Ldap.Password . Text.encodeUtf8 <$> o .:? "pass" .!= ""
+    ldapConfBase <- Ldap.Dn <$> o .:? "baseDN" .!= ""
+    ldapConfScope <- o .: "scope"
+    ldapConfTimeout <- o .: "timeout"
+    ldapConfSearchTimeout <- o .: "search-timeout"
+    return LdapConf{..}

src/Settings/OAuth2.hs

@@ -0,0 +1,32 @@
+-- SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@uniworx.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Settings.OAuth2
+  ( AzureConf(..)
+  , _azureConfClientId, _azureConfClientSecret, _azureConfTenantId, _azureConfScopes
+  ) where
+
+import ClassyPrelude
+
+import Data.Aeson
+import Data.Aeson.TH
+import Data.UUID
+
+import Utils.Lens.TH
+import Utils.PathPiece (camelToPathPiece')
+
+
+data AzureConf = AzureConf
+  { azureConfClientId     :: UUID
+  , azureConfClientSecret :: Text
+  , azureConfTenantId     :: UUID
+  , azureConfScopes       :: Set Text -- TODO: use AzureScopes type?
+  }
+  deriving (Show)
+
+makeLenses_ ''AzureConf
+
+deriveFromJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 2
+  } ''AzureConf

src/Settings/ResourcePool.hs

@@ -0,0 +1,30 @@
+-- SPDX-FileCopyrightText: 2024 Sarah Vaupel <sarah.vaupel@uniworx.de>
+--
+-- SPDX-License-Identifier: AGPL-3.0-or-later
+
+module Settings.ResourcePool
+  ( ResourcePoolConf(..)
+  , _poolStripes, _poolTimeout, _poolLimit
+  ) where
+
+import ClassyPrelude
+
+import Utils.Lens.TH
+import Utils.PathPiece (camelToPathPiece')
+
+import Data.Aeson
+import Data.Aeson.TH
+import Data.Time.Clock
+
+
+data ResourcePoolConf = ResourcePoolConf
+  { poolStripes :: Int
+  , poolTimeout :: NominalDiffTime
+  , poolLimit   :: Int
+  } deriving (Show)
+
+makeLenses_ ''ResourcePoolConf
+
+deriveFromJSON defaultOptions
+  { fieldLabelModifier = camelToPathPiece' 1
+  } ''ResourcePoolConf

src/Utils/Form.hs

@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2023 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
+-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@cip.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
 
@@ -19,7 +19,7 @@ import Settings
 import Utils.Parameters
 import Utils.Lens
 
-import Text.Blaze (Markup)
+import Text.Blaze (Markup, toMarkup)
 import qualified Text.Blaze.Internal as Blaze (null)
 import qualified Data.Text as T
 import qualified Data.Char as C
@@ -27,6 +27,7 @@ import qualified Data.Char as C
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
 import Data.Universe
+import qualified Data.UUID as UUID
 
 import Data.List (nub, (!!))
 import Data.Map.Lazy ((!))
@@ -81,6 +82,9 @@ import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
 import qualified Data.ByteString as BS
 
 
+fvWidget :: FieldView site -> WidgetFor site ()
+fvWidget FieldView{..} = $(widgetFile "widgets/field-view/field-view")
+
 ------------
 -- Fields --
 ------------
@@ -116,6 +120,17 @@ commentField msg = Field {..}
     fieldView  _ _ _ _ _  = msg2widget msg
     fieldEnctype          = UrlEncoded
 
+uuidField :: Monad m => Field m UUID
+uuidField = Field{..}
+  where
+    fieldParse = parseHelperGen $ maybe (Left $ tshow "Invalid UUID!") Right . UUID.fromText
+    fieldView fvId (toMarkup -> fvLabel) fvAttrs fvInput' fvRequired = fvWidget FieldView{..}
+      where fvTooltip = Nothing
+            fvErrors = either (Just . toMarkup) (const Nothing) fvInput'
+            fvInput = [whamlet|<input type="text" *{fvAttrs} name=#{fvLabel} :fvRequired:required value=#{fvValue}>|]
+            fvValue = either id UUID.toText fvInput'
+    fieldEnctype = UrlEncoded
+
 --------------------
 -- Field Settings --
 --------------------
@@ -1257,10 +1272,6 @@ formSection formSectionTitle = do
       , fvInput    = mempty
       })
 
-fvWidget :: FieldView site -> WidgetFor site ()
-fvWidget FieldView{..} = $(widgetFile "widgets/field-view/field-view")
-
-
 doFormHoneypots :: ( MonadHandler m
                    , HasAppSettings (HandlerSite m)
                    , YesodAuth (HandlerSite m)

src/Utils/Lens.hs

@@ -260,8 +260,6 @@ makeLenses_ ''ExamOccurrence
 
 makeLenses_ ''ExamOfficeLabel
 
-makePrisms ''AuthenticationMode
-
 makeLenses_ ''CourseUserNote
 makeLenses_ ''CourseParticipant
 

src/Utils/Users.hs

@@ -1,35 +1,16 @@
--- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
 {-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
 
 module Utils.Users
-  ( AuthenticationKind(..)
+  ( AddUserData(..)
-  , AddUserData(..)
   , addNewUser
   ) where
 
 import Import
 
-data AuthenticationKind = AuthKindLDAP | AuthKindPWHash | AuthKindNoLogin
-  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Universe, Finite)
---instance Universe AuthenticationKind
---instance Finite AuthenticationKind
-embedRenderMessage ''UniWorX ''AuthenticationKind id
-nullaryPathPiece ''AuthenticationKind $ camelToPathPiece' 2
-
-mkAuthMode :: AuthenticationKind -> AuthenticationMode
-mkAuthMode AuthKindLDAP     = AuthLDAP
-mkAuthMode AuthKindPWHash   = AuthPWHash ""
-mkAuthMode AuthKindNoLogin  = AuthNoLogin
-
-{-
-classifyAuth :: AuthenticationMode -> AuthenticationKind
-classifyAuth AuthLDAP     = AuthKindLDAP
-classifyAuth AuthPWHash{} = AuthKindPWHash
-classifyAuth AuthNoLogin  = AuthKindNoLogin
--} 
 
 data AddUserData = AddUserData
   { audTitle            :: Maybe Text
@@ -49,10 +30,11 @@ data AddUserData = AddUserData
   , audPinPassword      :: Maybe Text
   , audEmail            :: UserEmail
   , audIdent            :: UserIdent
-  , audAuth             :: AuthenticationKind  
+  , audPassword         :: Maybe Text
   }
 
--- | Adds a new user to database, no background jobs are scheduled, no notifications send
+
+-- | Adds a new user to database; no background jobs are scheduled, no notifications sent
 addNewUser :: AddUserData -> Handler (Maybe UserId)
 addNewUser AddUserData{..} = do 
   now <- liftIO getCurrentTime
@@ -60,6 +42,8 @@ addNewUser AddUserData{..} = do
   let 
     newUser = User
       { userIdent                   = audIdent
+      , userLastAuthentication      = Nothing
+      , userPasswordHash            = audPassword
       , userMaxFavourites           = userDefaultMaxFavourites
       , userMaxFavouriteTerms       = userDefaultMaxFavouriteTerms
       , userTheme                   = userDefaultTheme
@@ -76,9 +60,6 @@ addNewUser AddUserData{..} = do
       , userCsvOptions              = def { csvFormat = review csvPreset CsvPresetXlsx }
       , userTokensIssuedAfter       = Nothing
       , userCreated                 = now
-      , userLastLdapSynchronisation = Nothing
-      , userLdapPrimaryKey          = audFPersonalNumber
-      , userLastAuthentication      = Nothing
       , userEmail                   = audEmail
       , userDisplayName             = audDisplayName
       , userDisplayEmail            = audDisplayEmail
@@ -96,6 +77,6 @@ addNewUser AddUserData{..} = do
       , userPrefersPostal           = audPrefersPostal
       , userPinPassword             = audPinPassword
       , userMatrikelnummer          = audMatriculation
-      , userAuthentication          = mkAuthMode audAuth
+      , userLastSync                = Nothing -- TODO: combine add user with external sync?
       }
   runDB $ insertUnique newUser

src/Yesod/Servant.hs

@@ -30,7 +30,7 @@ import Control.Lens.Extras
 import Foundation.Servant.Types
 
 import Utils hiding (HasRoute)
-import Model.Types.Security
+import Model.Types.Auth
 
 import Yesod.Core ( Yesod
                   , RenderRoute(..), ParseRoute(..)

templates/admin/external-user.hamlet

@@ -0,0 +1,46 @@
+$newline never
+
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
+$#
+$# SPDX-License-Identifier: AGPL-3.0-or-later
+
+<section>
+  <p>
+    Query external user databases:
+    ^{personForm}
+  $maybe responses <- mbData
+    <h1>
+      Responses: #
+    <dl .deflist>
+      $forall (source,responses) <- responses
+        <dt .deflist__dt>
+          $case source
+            $of AuthSourceIdAzure tenantId
+              Azure Tenant ID: #
+              #{tshow tenantId}
+            $of AuthSourceIdLdap ldapHost
+              LDAP host: #
+              #{ldapHost}
+        <dd .deflist__dd>
+          <pre>
+            #{responses}
+$#          <dl .deflist>
+$#            $forall (k,(numv,vUtf8,vLatin1)) <- responses
+$#              <dt .deflist__dt>
+$#                #{k}
+$#                $if 1 < numv
+$#                  \ (#{show numv})
+$#              <dd .deflist__dd>
+$#                UTF8:  #{vUtf8}
+$#                &#8212;
+$#                Latin: #{vLatin1}
+
+<section>
+  <p>
+    Upsert user from external database:
+    ^{upsertForm}
+  $maybe response <- mbUpsert
+    <h1>
+      Response: #
+    <p>
+      #{tshow response}

templates/ldap.hamlet

@@ -1,33 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-<section>
-  <p> 
-    LDAP Person Search:
-    ^{personForm}
-  $maybe answers <- mbLdapData
-    <h1>
-      Antwort: #
-    <dl .deflist>
-      $forall (lk, lv) <- answers
-        $with numv <- length lv
-          <dt>
-            #{show lk}
-            $if 1 < numv
-              \ (#{show numv})
-          <dd>
-            UTF8:  #{presentUtf8 lv}
-            &#8212;
-            Latin: #{presentLatin1 lv}
-<section>
-  <p>
-    LDAP Upsert user in DB:
-    ^{upsertForm}
-  $maybe answer <- mbLdapUpsert
-    <h1>
-      Antwort: #
-    <p>
-      #{tshow answer}

templates/login.hamlet

@@ -5,24 +5,24 @@ $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 $forall AuthPlugin{apName, apLogin} <- plugins
-  $if apName == "azureadv2"
+  $if apName == apAzure
     <section>
       <h2>Azure
       ^{apLogin toParent}
-  $elseif apName == "dev-oauth2-mock"
+  $elseif apName == apAzureMock
     <section>
       <h2>_{MsgDummyLoginTitle}
       ^{apLogin toParent}
-  $elseif apName == "LDAP"
+  $elseif apName == apLdap
     <section>
       <h2>_{MsgLDAPLoginTitle}
       ^{apLogin toParent}
-  $elseif apName == "PWHash"
+  $elseif apName == apHash
     <section>
       <h2>_{MsgPWHashLoginTitle}
       <p>_{MsgPWHashLoginNote}
       ^{apLogin toParent}
-  $elseif apName == "dummy"
+  $elseif apName == apDummy
     <section>
       <h2>_{MsgDummyLoginTitle}
       ^{apLogin toParent}

templates/mail/userAuthModeUpdate.hamlet

@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
+$# SPDX-FileCopyrightText: 2022-2024 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
 
@@ -19,21 +19,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       }
   <body>
     <h1>
-      $case userAuthentication
+      $if is _Just userPasswordHash
-        $of AuthLDAP
+        _{SomeMessage MsgUserAuthPasswordEnabled}
-          _{SomeMessage MsgUserAuthModeChangedToLDAP}
+      $else
-        $of AuthPWHash _
+        _{SomeMessage MsgUserAuthPasswordDisabled}
-          _{SomeMessage MsgUserAuthModeChangedToPWHash}
-        $of AuthNoLogin
-          _{SomeMessage MsgUserAuthModeChangedToNoLogin}
     <p>
       <a href=@{NewsR}>
         _{SomeMessage MsgMailFradrive} #
       _{SomeMessage MsgMailBodyFradrive}
 
-    $if is _AuthPWHash userAuthentication
+    $if is _Just userPasswordHash
-      <p>
-        _{SomeMessage MsgAuthPWHashTip}
       <dl>
         <dt>
           _{SomeMessage MsgPWHashIdent}
@@ -42,6 +37,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         <dt>_{SomeMessage MsgPWHashPassword}
         <dd>
           _{SomeMessage MsgPasswordResetEmailIncoming}
+    $else
+      <p>
+        _{SomeMessage MsgAuthExternalLoginTip}
 
     $if is _Just userLastAuthentication
       ^{editNotifications}

templates/oauth2.hamlet

@@ -1,19 +0,0 @@
-$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>
-            

templates/profileData.hamlet

@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -10,10 +10,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         _{MsgIdent}
       <dd .deflist__dd .email>
         #{userIdent}
-      <dt .deflist__dt>
-        _{MsgAuthModeSet}        
-      <dd .deflist__dd>        
-        _{userAuthentication}
       $maybe avs <- avsId
         <dt .deflist__dt>
           _{MsgAvsPersonNo}
@@ -124,6 +120,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           _{MsgUserCreated}
         <dd .deflist__dd>
           ^{formatTimeW SelFormatDateTime userCreated}
+        <dt .deflist__dt>
+          _{MsgAdminUserAuthentication}
+        <dd .deflist__dd>
+          $if null externalUsers && is _Nothing userPasswordHash
+            _{MsgAuthKindNoLogin}
+          $else
+            <ul>
+              $if is _Just userPasswordHash
+                <li>_{MsgAuthKindPWHash}
+              $forall (authIdent, sourceIdent, lsync) <- externalUsers
+                <li>
+                  $case sourceIdent
+                    $of AuthSourceIdAzure _clientId
+                      _{MsgAuthKindAzure}: #
+                    $of AuthSourceIdLdap _sourceId
+                      _{MsgAuthKindLDAP}: #
+                  #{authIdent} #
+                  <span .comment>
+                    (_{MsgAdminUserAuthLastSync}: ^{formatTimeW SelFormatDateTime lsync})
         <dt .deflist__dt>
           _{MsgLastLogin}
         <dd .deflist__dd>
@@ -131,18 +146,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
             ^{formatTimeW SelFormatDateTime llogin}
           $nothing
             _{MsgNeverSet}
-        <dt .deflist__dt>
-          _{MsgProfileLastLdapSynchronisation}
-        <dd .deflist__dd>
-          $maybe lsync <- userLastLdapSynchronisation
-            ^{formatTimeW SelFormatDateTime lsync}
-          $nothing
-            _{MsgNeverSet}
-        $maybe pKey <- userLdapPrimaryKey
-          <dt .deflist__dt>
-            _{MsgProfileLdapPrimaryKey}
-          <dd .deflist__dd .ldap-primary-key>
-            #{pKey}
         <dt .deflist__dt>
           _{MsgTokensLastReset}
         <dd .deflist__dd>

test/Database/Fill.hs

@@ -11,8 +11,9 @@ import "uniworx" Import hiding (Option(..), currentYear)
 import qualified Data.Text.Encoding as TEnc
 import qualified Yesod.Auth.Util.PasswordStore as PWStore
 
-import qualified Data.Set as Set
+import qualified Data.List as List
-import qualified Data.Map as Map
+import qualified Data.Set  as Set
+import qualified Data.Map  as Map
 
 import Utils.Holidays
 
@@ -81,8 +82,9 @@ fillDb = do
 
   gkleen <- insert User
     { userIdent  = "G.Kleen@campus.lmu.de"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Just now
+    , userLastSync = Just now
     , userTokensIssuedAfter = Just now
     , userMatrikelnummer = Nothing
     , userEmail  = "G.Kleen@campus.lmu.de"
@@ -102,8 +104,6 @@ fillDb = do
     , userLanguages = Just $ Languages ["en"]
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -121,8 +121,9 @@ fillDb = do
     }
   fhamann <- insert User
     { userIdent  = "felix.hamann@campus.lmu.de"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail  = "noEmailKnown"
@@ -142,8 +143,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
     , userSex = Just SexMale
     , userShowSex = userDefaultShowSex
@@ -163,12 +162,12 @@ fillDb = do
     let pw = "123.456"
     PWHashConf{..} <- getsYesod $ view _appAuthPWHash
     pwHash <- liftIO $ PWStore.makePasswordWith pwHashAlgorithm pw pwHashStrength
-    return $ AuthPWHash $ TEnc.decodeUtf8 pwHash
+    return $ TEnc.decodeUtf8 pwHash
   jost <- insert User
     { userIdent  = "jost@tcs.ifi.lmu.de"
-    -- , userAuthentication = AuthLDAP
+    , userPasswordHash = Just pwSimple
-    , userAuthentication = pwSimple
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "12345678"
     , userEmail  = "S.Jost@Fraport.de"
@@ -188,8 +187,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userSex = Just SexMale
     , userBirthday = Just $ n_day $ 35 * (-365)
     , userCsvOptions = def
@@ -207,8 +204,9 @@ fillDb = do
     }
   maxMuster <- insert User
     { userIdent  = "max@campus.lmu.de"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Just now
+    , userLastSync = Just now
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "1299"
     , userEmail  = "max@campus.lmu.de"
@@ -228,8 +226,6 @@ fillDb = do
     , userLanguages = Just $ Languages ["de"]
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Just $ n_day $ 27 * (-365)
@@ -247,8 +243,9 @@ fillDb = do
     }
   tinaTester <- insert $ User
     { userIdent  = "tester@campus.lmu.de"
-    , userAuthentication = AuthNoLogin
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "999"
     , userEmail  = "tester@campus.lmu.de"
@@ -268,8 +265,6 @@ fillDb = do
     , userLanguages = Just $ Languages ["sn"]
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexNotApplicable
     , userBirthday = Just $ n_day 3
@@ -287,8 +282,9 @@ fillDb = do
     }
   svaupel <- insert User
     { userIdent  = "vaupel.sarah@campus.lmu.de"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail  = "vaupel.sarah@campus.lmu.de"
@@ -308,8 +304,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexFemale
     , userBirthday = Nothing
@@ -327,8 +321,9 @@ fillDb = do
     }
   sbarth <- insert User
     { userIdent = "Stephan.Barth@campus.lmu.de"
-     , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail = "Stephan.Barth@lmu.de"
@@ -348,8 +343,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -367,8 +360,9 @@ fillDb = do
     }
   _stranger1 <- insert User
     { userIdent = "AVSID:996699"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail = "E996699@fraport.de"
@@ -388,8 +382,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -407,8 +399,9 @@ fillDb = do
     }
   _stranger2 <- insert User
     { userIdent = "AVSID:669966"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail = "E669966@fraport.de"
@@ -428,8 +421,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -447,8 +438,9 @@ fillDb = do
     }
   _stranger3 <- insert User
     { userIdent = "AVSID:6969"
-    , userAuthentication = AuthLDAP
+    , userPasswordHash = Nothing
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Nothing
     , userEmail = "E6969@fraport.de"
@@ -468,8 +460,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -494,6 +484,15 @@ fillDb = do
                  , "Mark", "Paul", "Steven", "Andrew"
                  , "Kenneth", "Joshua", "George", "Kevin"
                  , "Brian", "Edward", "Susan", "Ronald"
+                 , "Nico", "Pascal", "Danielle", "Brendon"
+                 , "Winston", "Luke", "Jeff", "Ben"
+                 , "Asis", "Janika", "Claudio", "Frank"
+                 , "Anna", "Ivo", "Merlin", "Fabienne"
+                 , "Angela", "Alissa", "Fredrik", "Sharlee"
+                 , "René", "Tuval", "Dom", "Fabian"
+                 , "Steve", "Bruce", "Adrian", "Nicko"
+                 , "Joakim", "Ylva", "Mats", "Emil"
+                 , "Angus", "Seeb", "Thalia", "Manu"
                  ]
     surnames =   [ "Smith", "Johnson", "Williams", "Brown"
                  , "Jones", "Miller", "Davis", "Garcia"
@@ -503,19 +502,22 @@ fillDb = do
                  , "Lopez", "Lee", "Gonzalez", "Harris"
                  , "Clark", "Lewis", "Robinson", "Walker"
                  , "Perez", "Hall", "Young", "Allen"
+                 , "Loomis", "Amott", "Gluz", "Erlandsson"
+                 , "Glanzmann", "Murphy", "Henzi", "Sutter"
+                 , "Nasseri", "Wolf", "Quarta", "Fuhrmann"
+                 , "McCall", "Kilpatrick", "Ling", "Gordon"
+                 , "Sallach", "Ratajczak", "Friedrich", "Schillo"
+                 , "Völkl", "Dahn", "Berthiaume", "Crey"
+                 , "Murray", "Dickinson", "McBrain", "Gers"
+                 , "Nilsson", "Eriksson", "Fehrm", "Grahn"
+                 , "Winkler", "Levermann", "Bellazecca", "Lotter"
                  ]
-    middlenames = [ Nothing, Just "Jamesson" ]
+    middlenames = [ Nothing, Just "Jamesson", Just "Theresa", Just "Ally", Just "Tiberius", Just "Maria" ]
-    toMatrikel :: [Int] -> [Text]
-    toMatrikel ns
-      | (cs, rest) <- splitAt 8 ns
-      , length cs == 8
-      = foldMap tshow cs : toMatrikel rest
-      | otherwise
-      = []
     manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
       { userIdent
-      , userAuthentication = AuthLDAP
+      , userPasswordHash = Nothing
       , userLastAuthentication = Nothing
+      , userLastSync = Nothing
       , userTokensIssuedAfter = Nothing
       , userMatrikelnummer = Just userMatrikelnummer'
       , userEmail        = userEmail'
@@ -537,8 +539,6 @@ fillDb = do
       , userLanguages = Nothing
       , userNotificationSettings = def
       , userCreated = now
-      , userLastLdapSynchronisation = Nothing
-      , userLdapPrimaryKey = Nothing
       , userCsvOptions = def
       , userSex = Nothing
       , userBirthday = Nothing
@@ -571,8 +571,16 @@ fillDb = do
           "Clark"     ->      "E" <> userMatrikelnummer' <> "@fraport.de"
           "Jackson"   -> ""
           _           -> userIdent
-
+  -- toMatrikel :: [Int] -> [Text]
-  matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
+  -- toMatrikel ns
+  --   | (cs, rest) <- splitAt 10 ns
+  --   , length cs == 10
+  --   = foldMap tshow cs : toMatrikel rest
+  --   | otherwise
+  --   = []
+  -- matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int)
+  baseMatrikel <- getRandomR (10000 :: Int, 999999 :: Int) 
+  let matrikel = tshow <$> [baseMatrikel..] List.\\ [6969, 669966, 996699]
   manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel
   matUsers <- selectList [UserMatrikelnummer !=. Nothing] []
   insertMany_ [UserAvs (AvsPersonId n) uid n now Nothing | Entity uid User{userMatrikelnummer = fmap readMay -> Just (Just n)} <- matUsers]
@@ -630,6 +638,11 @@ fillDb = do
   ffacil    <- insert' $ Company "Fraport Facility Services GmbH"                      "GCS"        44   False Nothing $ Just "gcs@gcs.com"
   bpol      <- insert' $ Company "Bundespolizeidirektion Flughafen Frankfurt am Main"  "BPol"       5555 False Nothing Nothing
   _noone    <- insert' $ Company "Vollautomaten GmbH"                                  "NoOne"      3    True  Nothing Nothing
+  randComps <- insertMany [Company rcName rcShort n neven Nothing Nothing | n <- [1001..2002]
+                          , let neven   = even n
+                          , let rcName  = CI.mk $ "Random Corp " <> tshow n <> bool "" " GmbH" (even n)
+                          , let rcShort = CI.mk $ "RC" <> tshow n
+                          ]
   void . insert' $ UserCompany jost    fraportAg    True   True 
   void . insert' $ UserCompany svaupel nice         True   False 
   void . insert' $ UserCompany gkleen  nice         False  False 
@@ -642,6 +655,13 @@ fillDb = do
   insertMany_ [UserCompany uid bpol False False| Entity uid User{userFirstName = "Elizabeth"} <- matUsers]
   insertMany_ [UserCompany uid bpol True True| Entity uid User{userFirstName = "Clark", userSurname = dn} <- matUsers, dn == "Walker" || dn == "Robinson"]
   insertMany_ [UserCompany uid ffacil False False| Entity uid User{userSurname = "Walker"} <- matUsers]
+  insertMany_ [UserCompany uid rckey issuper False
+              | rckey <- randComps
+              , Just n <- [readMay $ drop 2 $ unpack $ CI.original $ unCompanyKey rckey]
+              , Entity uid User{userSurname = uSurname} <- take (n `div` 20) $ drop (2*n) matUsers
+              , uSurname /= "Jackson", uSurname /= "Lee"
+              , let issuper = uSurname == "Wolf"
+              ]
   -- void . insert' $ UserSupervisor jost gkleen       True
   -- void . insert' $ UserSupervisor jost svaupel      False
   -- void . insert' $ UserSupervisor jost sbarth       False
@@ -661,9 +681,9 @@ fillDb = do
               , UserSupervisor gkleen gkleen     True
               , UserSupervisor tinaTester tinaTester False
               ] 
-              ++ take 333 [ UserSupervisor fhamann uid True  | Entity uid _ <-          matUsers, uid /= jost]
+              ++ take 444 [ UserSupervisor fhamann uid True  | Entity uid _ <-          matUsers, uid /= jost]
-              ++ take 111 [ UserSupervisor gkleen  uid True  | Entity uid _ <- drop 300 matUsers ]
+              ++ take 123 [ UserSupervisor gkleen  uid True  | Entity uid _ <- drop 369 matUsers ]
-              ++ take  11 [ UserSupervisor jost    uid False | Entity uid _ <- drop 401 matUsers ]
+              ++ take  11 [ UserSupervisor jost    uid False | Entity uid _ <- drop 501 matUsers ]
   upsertManyWhere supvs [] [] [] 
   -- upsertManyWhere supvs [] [] [] -- NOTE: multiple calls like this are ok  
   -- insertMany_ supvs              -- NOTE: multiple calls like this throw an error!