diff --git a/.ports/assign.hs b/.ports/assign.hs new file mode 100644 index 000000000..000881729 --- /dev/null +++ b/.ports/assign.hs @@ -0,0 +1,64 @@ +-- SPDX-FileCopyrightText: 2024 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# Language OverloadedStrings, LambdaCase, TypeApplications #-} + +import Data.Text (Text) +import qualified Data.Text as T +import System.Directory +import System.Environment +import System.IO + +main :: IO () +main = getArgs >>= \case + ["--assign", offsetFile] -> parseOffsets offsetFile >>= uncurry nextOffset + ["--remove", offset] -> removeOffset offset + _ -> fail "unsupported args" + +parseOffsets :: FilePath -> IO (Int,Int) +parseOffsets offsetFile = do + user <- T.pack <$> getEnv "USER" + let pred x = "//" `T.isPrefixOf` x || T.null (T.strip x) + tokenise = map (filter (not . pred) . T.lines) . T.split (=='#') + extract = map tail . filter (\u -> not (null u) && user == (T.strip $ head u)) + ((extract . tokenise . T.pack) <$> readFile offsetFile) >>= \case + [[min,max]] -> return (read $ T.unpack min, read $ T.unpack max) + x -> print x >> fail "malformed offset file" + +nextOffset :: Int -> Int -> IO () +nextOffset min max + | min > max = nextOffset max min + | otherwise = do + home <- getEnv "HOME" + offset <- findFile [home] ".port-offsets" >>= \case + Nothing -> writeFile (home ++ "/.port-offsets") (show min) >> return min + Just path -> do + used <- (map (read @Int) . filter (not . null) . lines) <$> readFile path + o <- next min max used + appendFile path ('\n' : show o) + return o + print offset + where + next :: Int -> Int -> [Int] -> IO Int + next min max used + | min > max = fail "all offsets currently in use" + | min `elem` used = next (min+1) max used + | otherwise = return min + +removeOffset :: String -> IO () +removeOffset offset = do + home <- getEnv "HOME" + findFile [home] ".port-offsets" >>= \case + Nothing -> fail "offset file does not exist" + Just path -> do + remaining <- (filter (/= offset) . lines) <$> readFile path + run <- getEnv "XDG_RUNTIME_DIR" + (tempPath, fh) <- openTempFile run ".port-offsets" + let out = unlines remaining + hPutStr fh $ out + case T.null (T.strip $ T.pack out) of + True -> removeFile path + False -> writeFile path $ out + removeFile tempPath + diff --git a/.ports/offsets b/.ports/offsets new file mode 100644 index 000000000..7a4e5e7d6 --- /dev/null +++ b/.ports/offsets @@ -0,0 +1,24 @@ +// SPDX-FileCopyrightText: 2024 David Mosbach +// +// SPDX-License-Identifier: AGPL-3.0-or-later + +# gkleen + -1000 + -950 + +# ishka + -949 + -899 + +# jost + -898 + -848 + +# mosbach + -847 + -797 + +# savau + -796 + -746 + diff --git a/config/settings.yml b/config/settings.yml index 602c9c0e2..ed8743679 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , David Mosbach , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -24,9 +24,9 @@ mail-from: email: "_env:MAILFROM_EMAIL:uniworx@localhost" 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:" - email: "_env:MAIL_REROUTE_TO_EMAIL:" +mail-reroute-to: + name: "_env:MAIL_REROUTE_TO_NAME:" + email: "_env:MAIL_REROUTE_TO_EMAIL:" #mail-verp: # separator: "_env:VERP_SEPARATOR:+" # prefix: "_env:VERP_PREFIX:bounce" @@ -45,7 +45,7 @@ legal-external: imprint: "https://www.fraport.com/de/tools/impressum.html" data-protection: "https://www.fraport.com/de/konzern/datenschutz.html" terms-of-use: "https://www.fraport.com/de/tools/disclaimer.html" - payments: "https://www.fraport.com/de/geschaeftsfelder/service/geschaeftspartner/richtlinien-und-zahlungsbedingungen.html" + payments: "https://www.fraport.com/de/geschaeftsfelder/service/geschaeftspartner/richtlinien-und-zahlungsbedingungen.html" job-workers: "_env:JOB_WORKERS:10" job-flush-interval: "_env:JOB_FLUSH:30" @@ -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,24 +126,47 @@ 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" -ldap: - - 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" - pool: - stripes: "_env:LDAPSTRIPES:1" - timeout: "_env:LDAPTIMEOUT:20" - limit: "_env:LDAPLIMIT:10" +# 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" -ldap-re-test-failover: 60 +single-sign-on: "_env:OIDC_SSO:false" + +# Automatically redirect to SSO route when not signed on +# Note: This will force authentication, thus the site will be inaccessible without external credentials. Only use this option when it is ensured that every user that should be able to access the site has valid external credentials! +auto-sign-on: "_env:AUTO_SIGN_ON:false" + +# TODO: generalize for arbitrary auth protocols +# TODO: maybe use separate pools for external databases? +ldap-pool: + stripes: "_env:LDAPSTRIPES:1" + timeout: "_env:LDAPTIMEOUT:20" + limit: "_env:LDAPLIMIT:10" + +# 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" @@ -165,7 +185,7 @@ avs: lpr: host: "_env:LPRHOST:fravm017173.fra.fraport.de" port: "_env:LPRPORT:515" - queue: "_env:LPRQUEUE:fradrive" + queue: "_env:LPRQUEUE:fradrive" smtp: host: "_env:SMTPHOST:" @@ -188,7 +208,7 @@ widget-memcached: timeout: "_env:WIDGET_MEMCACHED_TIMEOUT:20" base-url: "_env:WIDGET_MEMCACHED_ROOT:" expiration: "_env:WIDGET_MEMCACHED_EXPIRATION:3600" - + session-memcached: host: "_env:SESSION_MEMCACHED_HOST:localhost" port: "_env:SESSION_MEMCACHED_PORT:11211" diff --git a/messages/uniworx/categories/admin/de-de-formal.msg b/messages/uniworx/categories/admin/de-de-formal.msg index eb6cfe753..8aa72be6e 100644 --- a/messages/uniworx/categories/admin/de-de-formal.msg +++ b/messages/uniworx/categories/admin/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -128,6 +128,8 @@ InterfaceName: Schnittstelle InterfaceLastSynch: Zuletzt InterfaceSubtype: Betreffend InterfaceWrite: Schreibend + +AdminUserPassword: Passwort InterfaceSuccess: Rückmeldung InterfaceInfo: Nachricht -InterfaceFreshness: Prüfungszeitraum (h) \ No newline at end of file +InterfaceFreshness: Prüfungszeitraum (h) diff --git a/messages/uniworx/categories/admin/en-eu.msg b/messages/uniworx/categories/admin/en-eu.msg index 13f35ed9f..d59341441 100644 --- a/messages/uniworx/categories/admin/en-eu.msg +++ b/messages/uniworx/categories/admin/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Sarah Vaupel , Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -128,6 +128,8 @@ InterfaceName: Interface InterfaceLastSynch: Last InterfaceSubtype: Affecting InterfaceWrite: Write + +AdminUserPassword: Password InterfaceSuccess: Returned InterfaceInfo: Message -InterfaceFreshness: Check hours \ No newline at end of file +InterfaceFreshness: Check hours diff --git a/messages/uniworx/categories/authorization/de-de-formal.msg b/messages/uniworx/categories/authorization/de-de-formal.msg index f9a26de23..5204bddb7 100644 --- a/messages/uniworx/categories/authorization/de-de-formal.msg +++ b/messages/uniworx/categories/authorization/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 David Mosbach , Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros # # 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. -UnauthorizedPWHash: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit FRADrive-Kennung an. +UnauthorizedExternal: Angegebene:r Benuzter:in meldet sich nicht über einen aktuell unterstützten externen Login 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 -CampusUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln -CampusUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln -CampusUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln -CampusUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln -CampusUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln -CampusUserInvalidTitle: 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 -CampusUserInvalidAssociatedSchools parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Bereiche ermitteln +InternalLoginError: Interner Fehler beim Login +DecodeUserInvalidIdent: Konnte anhand des Fraport Büko-Logins keine eindeutige Identifikation ermitteln +DecodeUserInvalidEmail: Konnte anhand des Fraport Büko-Logins keine E-Mail-Addresse ermitteln +DecodeUserInvalidDisplayName: Konnte anhand des Fraport Büko-Logins keinen vollen Namen ermitteln +DecodeUserInvalidGivenName: Konnte anhand des Fraport Büko-Logins keinen Vornamen ermitteln +DecodeUserInvalidSurname: Konnte anhand des Fraport Büko-Logins keinen Nachname ermitteln +DecodeUserInvalidTitle: Konnte anhand des Fraport Büko-Logins keinen akademischen Titel ermitteln +DecodeUserInvalidFeaturesOfStudy parseErr@Text: Konnte anhand des Fraport Büko-Logins keine Studiengänge 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 @@ -139,3 +139,6 @@ FormHoneypotNamePlaceholder: Name FormHoneypotComment: Kommentar FormHoneypotCommentPlaceholder: Kommentar FormHoneypotFilled: Bitte füllen Sie keines der verstecken Felder aus + +Logout: Abmeldung +SingleSignOut: Abmeldung bei Azure diff --git a/messages/uniworx/categories/authorization/en-eu.msg b/messages/uniworx/categories/authorization/en-eu.msg index b539efbf1..713afeec3 100644 --- a/messages/uniworx/categories/authorization/en-eu.msg +++ b/messages/uniworx/categories/authorization/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , David Mosbach , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros # # 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. -UnauthorizedPWHash: Specified user does not log in with an FRADrive-account. +UnauthorizedExternal: Specified user does not log in with any currently supported external login. +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 -CampusUserInvalidIdent: Could not determine unique identification during Fraport Büko login -CampusUserInvalidEmail: Could not determine email address during Fraport Büko login -CampusUserInvalidDisplayName: Could not determine display name during Fraport Büko login -CampusUserInvalidGivenName: Could not determine given name during Fraport Büko login -CampusUserInvalidSurname: Could not determine surname during Fraport Büko login -CampusUserInvalidTitle: Could not determine title during Fraport Büko login -CampusUserInvalidFeaturesOfStudy parseErr: Could not determine features of study during Fraport Büko login -CampusUserInvalidAssociatedSchools parseErr: Could not determine associated departments during Fraport Büko login +InternalLoginError: Internal error during login +DecodeUserInvalidIdent: Could not determine unique identification during Fraport Büko login +DecodeUserInvalidEmail: Could not determine email address during Fraport Büko login +DecodeUserInvalidDisplayName: Could not determine display name during Fraport Büko login +DecodeUserInvalidGivenName: Could not determine given name during Fraport Büko login +DecodeUserInvalidSurname: Could not determine surname during Fraport Büko login +DecodeUserInvalidTitle: Could not determine title during Fraport Büko login +DecodeUserInvalidFeaturesOfStudy parseErr: Could not determine features of study 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 @@ -140,3 +140,6 @@ FormHoneypotNamePlaceholder !ident-ok: Name FormHoneypotComment: Comment FormHoneypotCommentPlaceholder: Comment FormHoneypotFilled: Please do not fill in any of the hidden fields + +Logout: Logout +SingleSignOut: Azure logout diff --git a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg index cba2c8110..2c0907f7c 100644 --- a/messages/uniworx/categories/send/send_notifications/de-de-formal.msg +++ b/messages/uniworx/categories/send/send_notifications/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Winnie Ros # # 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. -UserAuthModeChangedToPWHash: Sie können sich nun mit einer 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. -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. +UserAuthPasswordEnabled: 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. +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. +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. diff --git a/messages/uniworx/categories/send/send_notifications/en-eu.msg b/messages/uniworx/categories/send/send_notifications/en-eu.msg index 04fe30088..dc9b17327 100644 --- a/messages/uniworx/categories/send/send_notifications/en-eu.msg +++ b/messages/uniworx/categories/send/send_notifications/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Winnie Ros # # 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) -UserAuthModeChangedToPWHash: You can now log in using your FRADrive-internal account -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. -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. +UserAuthPasswordEnabled: You can now log in using your FRADrive-internal account credentials. +UserAuthPasswordDisabled: You can no longer log in using your FRADrive-internal account credentials. +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. 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. diff --git a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg index e558668d3..b8f442862 100644 --- a/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg +++ b/messages/uniworx/categories/settings/auth_settings/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Winnie Ros # # 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 -AuthTagIsPWHash: Nutzer:in meldet sich mit FRADrive spezifischer Kennung an +AuthTagIsExternal: Nutzer:in meldet sich mit extern verwalteten Logindaten 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 diff --git a/messages/uniworx/categories/settings/auth_settings/en-eu.msg b/messages/uniworx/categories/settings/auth_settings/en-eu.msg index 562846f1a..5ba42ba0f 100644 --- a/messages/uniworx/categories/settings/auth_settings/en-eu.msg +++ b/messages/uniworx/categories/settings/auth_settings/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros # # 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 -AuthTagIsPWHash: User logs in using their FRADrive specific account +AuthTagIsExternal: User logs in using externally managed credentials +AuthTagIsInternal: User logs in using FRADrive-internal credentials AuthTagAuthentication: User is authenticated AuthTagRead: Access is read only AuthTagWrite: Access might write diff --git a/messages/uniworx/categories/user/de-de-formal.msg b/messages/uniworx/categories/user/de-de-formal.msg index a3c630c46..b644c1880 100644 --- a/messages/uniworx/categories/user/de-de-formal.msg +++ b/messages/uniworx/categories/user/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Steffen Jost , Winnie Ros # # 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 -SynchroniseLdapAllUsersQueued: LDAP-Synchronisation von allen Benutzer:innen angestoßen +SynchroniseUserdbUserQueued n@Int: Benutzerdatenbank-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "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 diff --git a/messages/uniworx/categories/user/en-eu.msg b/messages/uniworx/categories/user/en-eu.msg index 10c42830d..c1bd56124 100644 --- a/messages/uniworx/categories/user/en-eu.msg +++ b/messages/uniworx/categories/user/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Steffen Jost ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost , Steffen Jost , Winnie Ros # # 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"}. -SynchroniseLdapAllUsersQueued: Triggered LDAP synchronisation of all users +SynchroniseUserdbUserQueued n: Triggered user database synchronisation of #{n} #{pluralEN n "user" "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"}. \ No newline at end of file +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 \ No newline at end of file diff --git a/messages/uniworx/utils/navigation/menu/de-de-formal.msg b/messages/uniworx/utils/navigation/menu/de-de-formal.msg index eab4f204e..e6aa4079d 100644 --- a/messages/uniworx/utils/navigation/menu/de-de-formal.msg +++ b/messages/uniworx/utils/navigation/menu/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -25,6 +25,7 @@ MenuInstance: Instanz-Identifikation MenuHealth: Instanz-Zustand MenuHealthInterface: Schnittstellen Zustand MenuHelp: Hilfe +MenuAccount: Konto MenuProfile: Anpassen MenuLogin !ident-ok: Login MenuLogout !ident-ok: Logout @@ -142,7 +143,7 @@ MenuSap: SAP Schnittstelle MenuAvs: AVS Schnittstelle MenuAvsSynchError: AVS Problemübersicht -MenuLdap: LDAP Schnittstelle +MenuExternalUser: Externe Benutzer MenuApc: Druckerei MenuPrintSend: Manueller Briefversand MenuPrintDownload: Brief herunterladen diff --git a/messages/uniworx/utils/navigation/menu/en-eu.msg b/messages/uniworx/utils/navigation/menu/en-eu.msg index 526c6d871..71c56b8da 100644 --- a/messages/uniworx/utils/navigation/menu/en-eu.msg +++ b/messages/uniworx/utils/navigation/menu/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -25,6 +25,7 @@ MenuInstance: Instance identification MenuHealth: Instance health MenuHealthInterface: Interface health MenuHelp: Support +MenuAccount: Account MenuProfile: Settings MenuLogin: Login MenuLogout: Logout @@ -142,7 +143,7 @@ MenuSap: SAP Interface MenuAvs: AVS Interface MenuAvsSynchError: AVS Problem Overview -MenuLdap: LDAP Interface +MenuExternalUser: External users MenuApc: Printing MenuPrintSend: Send Letter MenuPrintDownload: Download Letter diff --git a/messages/uniworx/utils/utils/de-de-formal.msg b/messages/uniworx/utils/utils/de-de-formal.msg index 5ff122fb1..fb7d7c499 100644 --- a/messages/uniworx/utils/utils/de-de-formal.msg +++ b/messages/uniworx/utils/utils/de-de-formal.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2023 Steffen Jost ,Gregor Kleen ,Sarah Vaupel ,Winnie Ros +# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Steffen Jost , Gregor Kleen , Sarah Vaupel , Winnie Ros # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -158,4 +158,6 @@ SheetGradingPassAlways': Automatisch bestanden, sobald korrigiert SheetTypeNormal !ident-ok: Normal SheetTypeBonus !ident-ok: Bonus -InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten \ No newline at end of file +InvalidFormAction: Keine Aktion ausgeführt wegen ungültigen Formulardaten + +InvalidUuid: Invalide UUID! \ No newline at end of file diff --git a/messages/uniworx/utils/utils/en-eu.msg b/messages/uniworx/utils/utils/en-eu.msg index f65004cd1..e9c71d44e 100644 --- a/messages/uniworx/utils/utils/en-eu.msg +++ b/messages/uniworx/utils/utils/en-eu.msg @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2023 Sarah Vaupel ,Winnie Ros ,Steffen Jost +# SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Sarah Vaupel , Winnie Ros , Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -158,4 +158,6 @@ SheetGradingPassAlways': Automatically passed when corrected SheetTypeNormal: Normal SheetTypeBonus: Bonus -InvalidFormAction: No action taken due to invalid form data \ No newline at end of file +InvalidFormAction: No action taken due to invalid form data + +InvalidUuid: Invalid UUID! \ No newline at end of file diff --git a/models/users.model b/models/users.model index b23fe85b2..39ea0ae09 100644 --- a/models/users.model +++ b/models/users.model @@ -1,8 +1,8 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Steffen Jost -- -- 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 - diff --git a/package.yaml b/package.yaml index 2c242b3b3..c7d59d999 100644 --- a/package.yaml +++ b/package.yaml @@ -6,6 +6,7 @@ dependencies: - yesod-core - yesod-persistent - yesod-auth + - yesod-auth-oauth2 - yesod-static - yesod-form - yesod-persistent diff --git a/routes b/routes index 34ad73505..0e4a83324 100644 --- a/routes +++ b/routes @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -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-pw-hash -- user has authentication mode set to PWHash +-- !is-external -- user can login using external sources +-- !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 @@ -46,6 +46,9 @@ /static StaticR EmbeddedStatic appStatic !free /auth AuthR Auth getAuth !free +/logout SOutR GET !free +/logout/ssout SSOutR GET !free -- single sign-out (OIDC) + /metrics MetricsR GET !free -- verify if this can be free /err ErrorR GET !free @@ -59,23 +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 -/admin AdminR GET -/admin/test AdminTestR GET POST -/admin/test/pdf AdminTestPdfR GET -/admin/errMsg AdminErrMsgR GET POST -/admin/tokens AdminTokensR GET POST -/admin/crontab AdminCrontabR GET -/admin/crontab/jobs AdminJobsR GET POST -/admin/avs AdminAvsR GET POST -/admin/avs/#CryptoUUIDUser AdminAvsUserR GET -/admin/ldap AdminLdapR GET POST -/admin/problems AdminProblemsR GET +!/users/add AdminUserAddR GET POST +/admin AdminR GET +/admin/test AdminTestR GET POST +/admin/test/pdf AdminTestPdfR GET +/admin/errMsg AdminErrMsgR GET POST +/admin/tokens AdminTokensR GET POST +/admin/crontab AdminCrontabR GET +/admin/crontab/jobs AdminJobsR GET POST +/admin/avs AdminAvsR GET POST +/admin/avs/#CryptoUUIDUser AdminAvsUserR GET +/admin/external-user AdminExternalUserR GET POST +/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/errors ProblemAvsErrorR GET +/admin/problems/avs ProblemAvsSynchR GET POST +/admin/problems/avs/errors ProblemAvsErrorR GET /print PrintCenterR GET POST !system-printer /print/acknowledge/#Day/#Int/#Int PrintAckR GET POST !system-printer diff --git a/shell.nix b/shell.nix index 42c65ae1f..a5ca0056c 100644 --- a/shell.nix +++ b/shell.nix @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022-2023 Gregor Kleen , Sarah Vaupel , Steffen Jost +# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , Sarah Vaupel , Steffen Jost , David Mosbach # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -9,6 +9,13 @@ let haskellPackages = pkgs.haskellPackages; + oauth2Flake = (builtins.getFlake "git+https://gitlab.uniworx.de/mosbach/oauth2-mock-server/?rev=7b995e6cffa963a24eb5d0373b2d29089533284f&ref=main").packages.x86_64-linux; + + + oauth2MockServer = oauth2Flake.default; + mkOauth2DB = oauth2Flake.mkOauth2DB; + killOauth2DB = oauth2Flake.killOauth2DB; + postgresSchema = pkgs.writeText "schema.sql" '' CREATE USER uniworx WITH SUPERUSER; CREATE DATABASE uniworx_test; @@ -21,6 +28,17 @@ let local all all trust ''; + oauth2Schema = pkgs.writeText "oauth2_schema.sql" '' + CREATE USER oauth2mock WITH SUPERUSER; + CREATE DATABASE test_users; + GRANT ALL ON DATABASE test_users TO oauth2mock; + ''; + + oauth2Hba = pkgs.writeText "oauth2_hba_file" '' + local all all trust + ''; + + develop = pkgs.writeScriptBin "develop" '' #!${pkgs.zsh}/bin/zsh -e @@ -44,6 +62,9 @@ let type cleanup_cache_memcached &>/dev/null && cleanup_cache_memcached type cleanup_minio &>/dev/null && cleanup_minio type cleanup_maildev &>/dev/null && cleanup_maildev + [[ -z "$OAUTH2_PGDIR" ]] || source ${killOauth2DB}/bin/killOauth2DB + [[ -z "$OAUTH2_PGHOST" ]] || pkill oauth2-mock-ser + [[ -z "$PORT_OFFSET" ]] || runghc .ports/assign.hs --remove $PORT_OFFSET [ -f "''${basePath}/.develop.env" ] && rm -vf "''${basePath}/.develop.env" set +x @@ -51,7 +72,17 @@ let trap cleanup EXIT - export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000)) + export PORT_OFFSET=$(runghc .ports/assign.hs --assign .ports/offsets) + # export PORT_OFFSET=$(((16#$(sha256sum <<<"$(hostname -f):''${basePath}" | head -c 16)) % 1000)) + + if [[ -z "$OAUTH2_PGHOST" ]]; then + set -xe + export OAUTH2_SERVER_PORT=$((9443 + $PORT_OFFSET)) + export OAUTH2_DB_PORT=$((9444 + $PORT_OFFSET)) + source ${mkOauth2DB}/bin/mkOauth2DB + ${oauth2MockServer}/bin/oauth2-mock-server& + set +xe + fi if [[ -z "$PGHOST" ]]; then set -xe @@ -271,6 +302,9 @@ in pkgs.mkShell { export CHROME_BIN=${pkgs.chromium}/bin/chromium ''; + OAUTH2_HBA = oauth2Hba; + OAUTH2_DB_SCHEMA = oauth2Schema; + OAUTH2_TEST_USERS = ./test/Database/test-users.yaml; nativeBuildInputs = [develop inDevelop killallUni2work diffRunning] ++ (with pkgs; [ stack nodejs-14_x postgresql_12 openldap exiftool memcached minio minio-client diff --git a/src/Application.hs b/src/Application.hs index 4b60ecb39..1741d239a 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Sarah Vaupel , Steffen Jost , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -61,6 +61,7 @@ import Jobs import qualified Data.Text.Encoding as Text +import Yesod.Auth.OAuth2.AzureAD (oauth2AzureADScoped) import Yesod.Auth.Util.PasswordStore import qualified Data.ByteString.Lazy as LBS @@ -161,6 +162,7 @@ import Handler.PrintCenter import Handler.ApiDocs import Handler.Swagger import Handler.Firm +import Handler.SingleSignOut import ServantApi () -- YesodSubDispatch instances import Servant.API @@ -236,7 +238,7 @@ makeFoundation appSettings''@AppSettings{..} = do -- from there, and then create the real foundation. let mkFoundation :: _ -> (forall m. MonadIO m => Custom.Pool' m DBConnLabel DBConnUseState SqlBackend) -> _ - mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} + mkFoundation appSettings' appConnPool appSmtpPool appLdapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appAuthPlugins appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery = UniWorX{..} tempFoundation = mkFoundation (error "appSettings' forced in tempFoundation") (error "connPool forced in tempFoundation") @@ -253,10 +255,12 @@ makeFoundation appSettings''@AppSettings{..} = do (error "MinioConn forced in tempFoundation") (error "VerpSecret forced in tempFoundation") (error "AuthKey forced in tempFoundation") + (error "AuthPlugins forced in tempFoundation") (error "PersonalisedSheetFilesSeedKey forced in tempFoundation") (error "VolatileClusterSettingsCache forced in tempFoundation") (error "AvsQuery forced in tempFoundation") + runAppLoggingT tempFoundation $ do $logInfoS "InstanceID" $ UUID.toText appInstanceID $logInfoS "Configuration" $ tshowCrop appSettings'' @@ -291,13 +295,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 - let ldapLabel = case ldapHost of - 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 ldapPool) (poolTimeout ldapPool) ldapTimeout (poolLimit ldapPool) - forM_ ldapPool $ registerFailoverMetrics "ldap" + -- ldapPool <- traverse mkFailoverLabeled <=< forOf (traverse . traverse) appUserDbConf $ \conf -> if + -- | UserDbSingleSource{..} <- conf + -- , UserDbLdap LdapConf{..} <- userdbSingleSource + -- , Just ResourcePoolConf{..} <- userdbPoolConf + -- -> do + -- let ldapLabel = case ldapHost of + -- 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 $ @@ -318,6 +341,35 @@ 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 + -- TODO: use scopes from Settings +#ifdef DEVELOPMENT + oauth2Plugins <- liftIO $ sequence + [ (azureMockServer . fromJust) <$> lookupEnv "OAUTH2_SERVER_PORT" + , return $ oauth2AzureADScoped ["openid", "profile", "offline_access"] "42" "shhh" + ] +#else + let -- Auth Plugins + -- loadPlugin p prefix = do -- Loads given YesodAuthPlugin + -- mID <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientId + -- mSecret <- fmap Text.pack <$> appUserAuthConf ^? _UserAuthConfSingleSource . _AuthSourceConfAzureAdV2 . _azureConfClientSecret + -- let mArgs = (,) <$> mID <*> mSecret + -- guard $ isJust mArgs + -- return . uncurry p $ fromJust mArgs + -- tenantID = case appUserAuthConf of + -- UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..}) + -- -> tshow azureConfTenantId + -- _other + -- -> error "Tenant ID missing!" + oauth2Plugins + | UserAuthConfSingleSource (AuthSourceConfAzureAdV2 AzureConf{..}) <- appUserAuthConf + = singleton $ oauth2AzureADScoped (Set.toList azureConfScopes) (tshow azureConfClientId) azureConfClientSecret + | otherwise + = mempty +#endif + let appAuthPlugins = oauth2Plugins + + let appVolatileClusterSettingsCacheTime' = Clock.fromNanoSecs ns where (MkFixed ns :: Nano) = realToFrac appVolatileClusterSettingsCacheTime appVolatileClusterSettingsCache <- newTVarIO $ mkVolatileClusterSettingsCache appVolatileClusterSettingsCacheTime' @@ -377,7 +429,8 @@ makeFoundation appSettings''@AppSettings{..} = do $logDebugS "Runtime configuration" $ tshowCrop appSettings' - let foundation = mkFoundation appSettings' sqlPool smtpPool ldapPool appCryptoIDKey appSessionStore appSecretBoxKey appWidgetMemcached appJSONWebKeySet appClusterID appMemcached appMemcachedLocal appUploadCache appVerpSecret appAuthKey appPersonalisedSheetFilesSeedKey appVolatileClusterSettingsCache appAvsQuery + -- 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 $logInfoS "setup" "*** DONE ***" @@ -616,6 +669,8 @@ appMain = runResourceT $ do foundation <- makeFoundation settings runAppLoggingT foundation $ do + $logDebugS "AppSettings" $ tshow settings + $logInfoS "setup" "Job-Handling" handleJobs foundation @@ -732,7 +787,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 @@ -757,7 +812,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{..} diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 329bb0a29..a5a2d2813 100644 --- a/src/Auth/LDAP.hs +++ b/src/Auth/LDAP.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Felix Hamann , Gregor Kleen , Sarah Vaupel , Steffen Jost , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -7,11 +7,11 @@ module Auth.LDAP ( apLdap , ADError(..), ADInvalidCredentials(..) - , campusLogin - , CampusUserException(..) - , campusUser, campusUser', campusUser'' - , campusUserReTest, campusUserReTest' - , campusUserMatr, campusUserMatr' + , ldapLogin + , LdapUserException(..) + , ldapUser, ldapUser', ldapUser'' +--, ldapUserReTest, ldapUserReTest' + , 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 Utils.Metrics -import Utils.Form +import Auth.LDAP.AD 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 -deriving newtype instance Ord Ldap.Attr +-- | Plugin name of the LDAP yesod auth plugin +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 conf@LdapConf{..} ldap ident retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters +findUser :: LdapConf + -> 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 conf@LdapConf{..} ldap userMatr retAttrs = fromMaybe [] <$> findM (assertM (not . null) . lift . flip (Ldap.search ldap ldapBase $ userSearchSettings conf) retAttrs) userFilters +findUserMatr :: LdapConf + -> 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 - | CampusUserNoResult - | CampusUserAmbiguous +-- TODO: deprecate in favour of FetchUserDataException +data LdapUserException = LdapUserLdapError LdapPoolError + | LdapUserNoResult + | LdapUserAmbiguous deriving (Show, Eq, Generic) -instance Exception CampusUserException +instance Exception LdapUserException -makePrisms ''CampusUserException +makePrisms ''LdapUserException -campusUserWith :: ( MonadUnliftIO m - , MonadCatch m - ) - => ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap - -> Failover (LdapConf, LdapPool) - -> FailoverMode - -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) - -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) - ) - -> Failover (LdapConf, LdapPool) - -> FailoverMode - -> Creds site - -> m (Either CampusUserException (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 + +ldapUserWith :: ( MonadUnliftIO m + , MonadCatch m + --, MonadLogger m + ) + -- ( Lens (LdapConf, LdapPool) (LdapConf, Ldap) LdapPool Ldap + -- -> (LdapConf, LdapPool) + -- -> ((LdapConf, Ldap) -> m (Either CampusUserException (Ldap.AttrList []))) + -- -> m (Either LdapPoolError (Either CampusUserException (Ldap.AttrList []))) + -- ) + => ( LdapPool + -> (Ldap -> m (Either LdapUserException (Ldap.AttrList []))) + -> m (Either LdapPoolError (Either LdapUserException (Ldap.AttrList []))) + ) + -> (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 - -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 + _otherwise -> throwE LdapUserAmbiguous -campusUser :: (MonadMask m, MonadUnliftIO m, MonadLogger m) => Failover (LdapConf, LdapPool) -> FailoverMode -> Creds site -> m (Ldap.AttrList []) -campusUser pool mode creds = throwLeft =<< campusUserWith withLdapFailover pool mode creds +-- TODO: reintroduce once failover has been reimplemented +-- 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 [])) -campusUser'' pool mode ident - = runMaybeT . catchIfMaybeT (is _CampusUserNoResult) $ campusUser pool mode (Creds apLdap ident []) +-- TODO: deprecate in favour of fetchUserData +ldapUser :: ( MonadMask m + , 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 []) -campusUserMatr pool mode userMatr = either (throwM . CampusUserLdapError) return <=< withLdapFailover _2 pool mode $ \(conf@LdapConf{..}, ldap) -> liftIO $ do - Ldap.bind ldap ldapDn ldapPassword +ldapUser' :: ( MonadMask m + , MonadUnliftIO m + --, 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 - -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 + _otherwise -> throwM LdapUserAmbiguous +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. - ( YesodAuth site - , RenderMessage site CampusMessage - , RenderAFormSite site - , RenderMessage site (ValueRequired site) - , RenderMessage site ADInvalidCredentials - , Button site ButtonSubmit - ) => Failover (LdapConf, LdapPool) -> FailoverMode -> AuthPlugin site -campusLogin pool mode = AuthPlugin{..} +-- TODO: reintroduce Failover +ldapLogin :: forall site. + ( YesodAuth site + , RenderMessage site CampusMessage + , RenderAFormSite site + , RenderMessage site (ValueRequired site) + , RenderMessage site ADInvalidCredentials + , Button site ButtonSubmit + ) + => 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 - Ldap.bind ldap ldapDn ldapPassword + ldapResult <- withLdap pool $ \ldap -> liftIO $ do + Ldap.bind ldap ldapConfDn ldapConfPassword searchResults <- findUser conf ldap campusIdent [ldapUserPrincipalName] case searchResults of [Ldap.SearchEntry (Ldap.Dn userDN) userAttrs] diff --git a/src/Auth/OAuth2.hs b/src/Auth/OAuth2.hs new file mode 100644 index 000000000..88bcff790 --- /dev/null +++ b/src/Auth/OAuth2.hs @@ -0,0 +1,246 @@ +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Auth.OAuth2 + ( apAzure + , azurePrimaryKey, azureUserPrincipalName, azureUserDisplayName, azureUserGivenName, azureUserSurname, azureUserMail, azureUserTelephone, azureUserMobile, azureUserPreferredLanguage + -- , azureUser, azureUser' + , AzureUserException(..), _AzureUserError, _AzureUserNoResult, _AzureUserAmbiguous + , apAzureMock + , azureMockServer + , queryOAuth2User + , refreshOAuth2Token + , singleSignOut + ) where + +-- import qualified Data.CaseInsensitive as CI +import Data.Maybe (fromJust) +import Data.Text + +import Import.NoFoundation hiding (pack, unpack) + +import Network.HTTP.Simple (httpJSONEither, getResponseBody, JSONException) + +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 + deriving (Show, Eq, Generic) + +instance Exception AzureUserException + +makePrisms ''AzureUserException + + +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 ---- +----------------------------------------------- + +apAzureMock :: Text +apAzureMock = "uniworx_dev" + +newtype UserID = UserID Text +instance FromJSON UserID where + parseJSON = withObject "UserID" $ \o -> + UserID <$> o .: "id" + +azureMockServer :: YesodAuth m => String -> AuthPlugin m +azureMockServer port = + let oa = OAuth2 + { oauthClientId = "42" + , oauthClientSecret = Just "shhh" + , oauthOAuthorizeEndpoint = fromString (mockServerURL <> "/auth") + `withQuery` [ scopeParam " " ["openid", "profile", "email", "offline_access"] -- TODO read scopes from config + , ("response_type", "code id_token") + , ("nonce", "Foo") -- TODO generate meaningful value + ] + , oauthAccessTokenEndpoint = fromString $ mockServerURL <> "/token" + , oauthCallback = Nothing + } + mockServerURL = "http://localhost:" <> fromString port + profileSrc = fromString $ mockServerURL <> "/users/me" + in authOAuth2 apAzureMock oa $ \manager token -> do + (UserID userID, userResponse) <- authGetProfile apAzureMock manager token profileSrc + return Creds + { credsPlugin = apAzureMock + , credsIdent = userID + , credsExtra = setExtra token userResponse + } + + +---------------------- +---- User Queries ---- +---------------------- + +data UserDataException = UserDataJSONException JSONException + | UserDataInternalException Text + deriving Show + +instance Exception UserDataException + +queryOAuth2User :: forall j m. + ( FromJSON j + , MonadHandler m + , MonadThrow m + ) + => Text -- ^ User identifier (arbitrary needle) + -> m (Either UserDataException j) +queryOAuth2User userID = runExceptT $ do + (queryUrl, tokenUrl) <- liftIO mkBaseUrls + req <- parseRequest $ "GET " ++ queryUrl ++ unpack userID + mTokens <- lookupSessionJson SessionOAuth2Token + unless (isJust mTokens) . throwE $ UserDataInternalException "Tried to load session Oauth2 tokens, but there are none" +# ifdef DEVELOPMENT + let secure = False +# else + let secure = True +# endif + newTokens <- refreshOAuth2Token @m (fromJust mTokens) tokenUrl secure + setSessionJson SessionOAuth2Token (Just $ accessToken newTokens, refreshToken newTokens) + eResult <- lift $ getResponseBody <$> httpJSONEither @m @j (req + { secure = secure + , requestHeaders = [("Authorization", encodeUtf8 . ("Bearer " <>) . atoken $ accessToken newTokens)] + }) + case eResult of + Left x -> throwE $ UserDataJSONException x + Right x -> return x + + +mkBaseUrls :: IO (String, String) +mkBaseUrls = do +# ifndef DEVELOPMENT + Just tenantID <- lookupEnv "AZURE_TENANT_ID" + return ( "https://graph.microsoft.com/v1.0/users/" + , "https://login.microsoftonline.com/" ++ tenantID ++ "/oauth2/v2.0" ) +# else + Just port <- lookupEnv "OAUTH2_SERVER_PORT" + let base = "http://localhost:" ++ port + return ( base ++ "/users/query?id=" + , base ++ "/token" ) +# endif + + +refreshOAuth2Token :: forall m. + ( MonadHandler m + , MonadThrow m + ) + => (Maybe AccessToken, Maybe RefreshToken) + -> String + -> Bool + -> ExceptT UserDataException m OAuth2Token +refreshOAuth2Token (_, rToken) url secure + | isJust rToken = do + req <- parseRequest $ "POST " ++ url + let + body = + [ ("grant_type", "refresh_token") + , ("refresh_token", encodeUtf8 . rtoken $ fromJust rToken) + ] + body' <- if secure then do + clientID <- liftIO $ fromJust <$> lookupEnv "CLIENT_ID" + clientSecret <- liftIO $ fromJust <$> lookupEnv "CLIENT_SECRET" + return $ body ++ [("client_id", fromString clientID), ("client_secret", fromString clientSecret), scopeParam " " ["openid","profile"," offline_access"]] -- TODO read from config + else return $ scopeParam " " ["openid","profile","offline_access"] : body -- TODO read from config + $logDebugS "\27[31mAdmin Handler\27[0m" $ tshow (requestBody $ urlEncodedBody body' req{ secure = secure }) + eResult <- lift $ getResponseBody <$> httpJSONEither @m @OAuth2Token (urlEncodedBody body' req{ secure = secure }) + case eResult of + Left x -> throwE $ UserDataJSONException x + Right x -> return x + | otherwise = throwE $ UserDataInternalException "Could not refresh access token. Refresh token is missing." + +instance Show RequestBody where + show (RequestBodyLBS x) = show x + show _ = error ":(" + + + ----------------------- +---- Single Sign-Out ---- + ----------------------- + +singleSignOut :: forall a m. (MonadHandler m) + => Maybe Text -- ^ redirect uri + -> m a +singleSignOut mRedirect = do +# ifdef DEVELOPMENT + port <- liftIO $ fromJust <$> lookupEnv "OAUTH2_SERVER_PORT" + let base = "http://localhost:" <> pack port <> "/logout" +# else + let base = "" -- TODO find out fraport oidc end_session_endpoint +# endif + endpoint = case mRedirect of + Just r -> base <> "?post_logout_redirect_uri=" <> r + Nothing -> base + $logDebugS "\n\27[31mSSO\27[0m" endpoint + redirect endpoint + diff --git a/src/Auth/PWHash.hs b/src/Auth/PWHash.hs index e857d8dcc..bd8664668 100644 --- a/src/Auth/PWHash.hs +++ b/src/Auth/PWHash.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Felix Hamann ,Gregor Kleen ,Sarah Vaupel +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Felix Hamann , Gregor Kleen , Sarah Vaupel -- -- 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 }) - | verifyPasswordWith pwHashAlgo (2^) (encodeUtf8 hashPassword) (encodeUtf8 authPWHash) -> do -- (2^) is magic. + Just (Entity _ User{userIdent,userPasswordHash}) + | 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 diff --git a/src/Foundation/Authorization.hs b/src/Foundation/Authorization.hs index 0243b0609..770ef64f9 100644 --- a/src/Foundation/Authorization.hs +++ b/src/Foundation/Authorization.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt -- -- 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 - User{..} <- MaybeT $ get referencedUser' - guard $ userAuthentication == AuthLDAP + availableSources <- getsYesod (view _appUserAuthConf) >>= \case + UserAuthConfSingleSource{..} -> return . singleton $ case userAuthConfSingleSource of + 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 diff --git a/src/Foundation/I18n.hs b/src/Foundation/I18n.hs index fd2bb9479..98096978e 100644 --- a/src/Foundation/I18n.hs +++ b/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 diff --git a/src/Foundation/Instances.hs b/src/Foundation/Instances.hs index b7d6a555b..39b8ee163 100644 --- a/src/Foundation/Instances.hs +++ b/src/Foundation/Instances.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Wolfgang Witt , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -11,11 +11,14 @@ module Foundation.Instances , unsafeHandler ) where +import qualified Prelude as P + import Import.NoFoundation import qualified Data.Text as Text import Data.List (inits) +import Yesod.Auth.OAuth2 import qualified Yesod.Core.Unsafe as Unsafe import qualified Yesod.Auth.Message as Auth @@ -23,6 +26,7 @@ import Utils.Form import Auth.LDAP import Auth.PWHash import Auth.Dummy +import Auth.OAuth2 import qualified Foundation.Yesod.Session as UniWorX import qualified Foundation.Yesod.Middleware as UniWorX @@ -42,6 +46,8 @@ import Foundation.DB import Network.Wai.Parse (lbsBackEnd) +import System.Environment (lookupEnv) + import UnliftIO.Pool (withResource) import qualified Control.Monad.State.Class as State @@ -119,7 +125,7 @@ instance YesodPersistRunner UniWorX where getDBRunner :: HasCallStack => HandlerFor UniWorX (DBRunner UniWorX, HandlerFor UniWorX ()) getDBRunner = UniWorX.getDBRunner' callStack - + instance YesodAuth UniWorX where type AuthId UniWorX = UserId @@ -128,21 +134,30 @@ instance YesodAuth UniWorX where -- Where to send a user after logout logoutDest _ = NewsR -- Override the above two destinations when a Referer: header is present - redirectToReferer _ = True + redirectToReferer _ = False loginHandler = do + plugins <- getsYesod authPlugins + AppSettings{..} <- getsYesod appSettings' + + when appSingleSignOn $ do + let plugin = P.head $ P.filter ((`elem` [apAzureMock, apAzure]) . apName) plugins + pieces = case oauth2Url (apName plugin) of + PluginR _ p -> p + _ -> error "Unexpected OAuth2 AuthRoute" + void $ apDispatch plugin "GET" pieces + toParent <- getRouteToParent liftHandler . defaultLayout $ do - plugins <- getsYesod authPlugins $logDebugS "Auth" $ "Enabled plugins: " <> Text.intercalate ", " (map apName plugins) - + mPort <- liftIO $ lookupEnv "OAUTH2_SERVER_PORT" setTitleI MsgLoginTitle $(widgetFile "login") authenticate = UniWorX.authenticate - authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool } = catMaybes - [ flip campusLogin campusUserFailoverMode <$> appLdapPool + authPlugins UniWorX{ appSettings' = AppSettings{..}, appLdapPool, appAuthPlugins } = appAuthPlugins ++ catMaybes + [ uncurry ldapLogin <$> appLdapPool , Just . hashLogin $ pwHashAlgorithm appAuthPWHash , dummyLogin <$ guard appAuthDummyLogin ] @@ -157,6 +172,11 @@ instance YesodAuth UniWorX where addMessage Success . toHtml $ mr Auth.NowLoggedIn + -- onLogout = do + -- AppSettings{..} <- getsYesod appSettings' + -- when appSingleSignOn $ singleSignOut @UniWorX Nothing + + onErrorHtml dest msg = do addMessage Error $ toHtml msg redirect dest diff --git a/src/Foundation/Navigation.hs b/src/Foundation/Navigation.hs index 008e68e08..c3b3cb1ed 100644 --- a/src/Foundation/Navigation.hs +++ b/src/Foundation/Navigation.hs @@ -73,6 +73,8 @@ breadcrumb :: ( BearerAuthSite UniWorX => Route UniWorX -> m Breadcrumb breadcrumb (AuthR _) = i18nCrumb MsgMenuLogin $ Just NewsR +breadcrumb SOutR = i18nCrumb MsgLogout Nothing +breadcrumb SSOutR = i18nCrumb MsgSingleSignOut Nothing breadcrumb (StaticR _) = i18nCrumb MsgBreadcrumbStatic Nothing breadcrumb (WellKnownR _) = i18nCrumb MsgBreadcrumbWellKnown Nothing breadcrumb MetricsR = i18nCrumb MsgBreadcrumbMetrics Nothing @@ -115,7 +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 AdminProblemsR = i18nCrumb MsgProblemsHeading $ Just AdminR breadcrumb ProblemUnreachableR = i18nCrumb MsgProblemsUnreachableHeading $ Just AdminProblemsR breadcrumb ProblemWithoutAvsId = i18nCrumb MsgProblemsNoAvsIdHeading $ Just AdminProblemsR @@ -542,42 +544,37 @@ defaultLinks :: ( MonadHandler m , BearerAuthSite UniWorX ) => m [Nav] defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the header. - [ return NavHeader + [ return NavHeaderContainer { navHeaderRole = NavHeaderSecondary - , navIcon = IconMenuLogout - , navLink = NavLink - { navLabel = MsgMenuLogout - , navRoute = AuthR LogoutR - , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } - , return NavHeader - { navHeaderRole = NavHeaderSecondary - , navIcon = IconMenuLogin - , navLink = NavLink - { navLabel = MsgMenuLogin - , navRoute = AuthR LoginR - , navAccess' = NavAccessHandler $ is _Nothing <$> maybeAuthId - , navType = NavTypeLink { navModal = True } - , navQuick' = mempty - , navForceActive = False - } - } - , return NavHeader - { navHeaderRole = NavHeaderSecondary - , navIcon = IconMenuProfile - , navLink = NavLink - { navLabel = MsgMenuProfile - , navRoute = ProfileR - , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId - , navType = NavTypeLink { navModal = False } - , navQuick' = mempty - , navForceActive = False - } - } + , navLabel = SomeMessage MsgMenuAccount + , navIcon = IconMenuAccount + , navChildren = + [ NavLink + { navLabel = MsgMenuLogout + , navRoute = SSOutR -- AuthR LogoutR + , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuLogin + , navRoute = AuthR LoginR + , navAccess' = NavAccessHandler $ is _Nothing <$> maybeAuthId + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + , NavLink + { navLabel = MsgMenuProfile + , navRoute = ProfileR + , navAccess' = NavAccessHandler $ is _Just <$> maybeAuthId + , navType = NavTypeLink { navModal = False } + , navQuick' = mempty + , navForceActive = False + } + ] + } , do mCurrentRoute <- getCurrentRoute @@ -856,8 +853,8 @@ defaultLinks = fmap catMaybes . mapM runMaybeT $ -- Define the menu items of the , navForceActive = False } , NavLink - { navLabel = MsgMenuLdap - , navRoute = AdminLdapR + { navLabel = MsgMenuExternalUser + , navRoute = AdminExternalUserR , navAccess' = NavAccessTrue , navType = NavTypeLink { navModal = False } , navQuick' = mempty @@ -1214,8 +1211,8 @@ pageActions (AdminUserR cID) = return , navRoute = UserPasswordR cID , navAccess' = NavAccessDB $ do uid <- decrypt cID - User{userAuthentication} <- get404 uid - return $ is _AuthPWHash userAuthentication + User{userPasswordHash} <- get404 uid + return $ is _Just userPasswordHash , navType = NavTypeLink { navModal = True } , navQuick' = mempty , navForceActive = False diff --git a/src/Foundation/Routes.hs b/src/Foundation/Routes.hs index 454be37a6..e7f7ba32b 100644 --- a/src/Foundation/Routes.hs +++ b/src/Foundation/Routes.hs @@ -9,7 +9,7 @@ module Foundation.Routes ( module Foundation.Routes.Definitions , module Foundation.Routes ) where - + import Import.NoFoundation import Foundation.Type diff --git a/src/Foundation/SiteLayout.hs b/src/Foundation/SiteLayout.hs index 46d3f9272..3275485a2 100644 --- a/src/Foundation/SiteLayout.hs +++ b/src/Foundation/SiteLayout.hs @@ -156,6 +156,10 @@ siteLayout' overrideHeading widget = do -- isParent r = r == (fst parents) isAuth <- isJust <$> maybeAuthId + + when (appAutoSignOn && not isAuth) $ do + $logDebugS "AutoSignOn" "AutoSignOn is enabled in AppSettings and user is not authenticated" + redirect $ AuthR LoginR now <- liftIO getCurrentTime diff --git a/src/Foundation/Type.hs b/src/Foundation/Type.hs index 5c77e9863..c7cfd977b 100644 --- a/src/Foundation/Type.hs +++ b/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) @@ -97,6 +97,7 @@ data UniWorX = UniWorX , appUploadCache :: Maybe MinioConn , appVerpSecret :: VerpSecret , appAuthKey :: Auth.Key + , appAuthPlugins :: [AuthPlugin UniWorX] , appFileSourceARC :: Maybe (ARCHandle (FileContentChunkReference, (Int, Int)) Int ByteString) , appFileSourcePrewarm :: Maybe (LRUHandle (FileContentChunkReference, (Int, Int)) UTCTime Int ByteString) , appFileInjectInhibit :: TVar (IntervalMap UTCTime (Set FileContentReference)) diff --git a/src/Foundation/Types.hs b/src/Foundation/Types.hs index 786b943b0..f76076f33 100644 --- a/src/Foundation/Types.hs +++ b/src/Foundation/Types.hs @@ -1,23 +1,44 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Gregor Kleen , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Foundation.Types - ( UpsertCampusUserMode(..) - , _UpsertCampusUserLoginLdap, _UpsertCampusUserLoginDummy, _UpsertCampusUserLoginOther, _UpsertCampusUserLdapSync, _UpsertCampusUserGuessUser - , _upsertCampusUserIdent + ( UpsertUserMode(..) + , _UpsertUserLogin, _UpsertUserLoginDummy, _UpsertUserLoginOther, _UpsertUserSync, _UpsertUserGuessUser + , _upsertUserSource, _upsertUserIdent + , UpsertUserData(..) + , _UpsertUserDataAzure, _UpsertUserDataLdap + , _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 +-- TODO: rename? +data UpsertUserMode + = UpsertUserLogin { upsertUserSource :: Text } -- TODO: use type synonym? + | UpsertUserLoginDummy { upsertUserIdent :: UserIdent } + | UpsertUserLoginOther { upsertUserIdent :: UserIdent } -- does not allow further login + | UpsertUserSync { upsertUserIdent :: UserIdent } + | UpsertUserGuessUser + deriving (Show) + +makeLenses_ ''UpsertUserMode +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 diff --git a/src/Foundation/Yesod/Auth.hs b/src/Foundation/Yesod/Auth.hs index efabadc80..c15240171 100644 --- a/src/Foundation/Yesod/Auth.hs +++ b/src/Foundation/Yesod/Auth.hs @@ -1,69 +1,66 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost , Steffen Jost , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later module Foundation.Yesod.Auth ( authenticate - , ldapLookupAndUpsert - , upsertCampusUser + , userLookupAndUpsert + , upsertUser, maybeUpsertUser , decodeUserTest - , CampusUserConversionException(..) - , campusUserFailoverMode, updateUserLanguage + , DecodeUserException(..) + , 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 Auth.LDAP -import Auth.PWHash (apHash) -import Auth.Dummy (apDummy) +import Yesod.Auth.OAuth2 (getAccessToken, getRefreshToken) -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 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) +import qualified Ldap.Client as Ldap 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 + $logDebugS "Auth Debug" $ "\a\27[31m" <> tshow creds <> "\27[0m" + setSessionJson SessionOAuth2Token (getAccessToken creds, getRefreshToken creds) + now <- liftIO getCurrentTime let uAuth = UniqueAuthentication $ CI.mk credsIdent - upsertMode = creds ^? _upsertCampusUserMode + upsertMode = creds ^? _upsertUserMode - isDummy = is (_Just . _UpsertCampusUserLoginDummy) upsertMode - isOther = is (_Just . _UpsertCampusUserLoginOther) upsertMode + isDummy = is (_Just . _UpsertUserLoginDummy) upsertMode + isOther = is (_Just . _UpsertUserLoginOther) upsertMode excRecovery res | isDummy || isOther @@ -77,21 +74,21 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend = return res excHandlers = - [ C.Handler $ \case - CampusUserNoResult -> do - $logWarnS "LDAP" $ "User lookup failed after successful login for " <> credsIdent + [ C.Handler $ \(fExc :: FetchUserDataException) -> case fExc of + FetchUserDataNoResult -> do + $logWarnS "FetchUserException" $ "User lookup failed after successful login for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent - CampusUserAmbiguous -> do - $logWarnS "LDAP" $ "Multiple LDAP results for " <> credsIdent + FetchUserDataAmbiguous -> do + $logWarnS "FetchUserException" $ "Multiple User results for " <> credsIdent excRecovery . UserError $ IdentifierNotFound credsIdent err -> do - $logErrorS "LDAP" $ tshow err + $logErrorS "FetchUserException" $ tshow err mr <- getMessageRender - excRecovery . ServerError $ mr MsgInternalLdapError - , C.Handler $ \(cExc :: CampusUserConversionException) -> do - $logErrorS "LDAP" $ tshow cExc + excRecovery . ServerError $ mr MsgInternalLoginError + , C.Handler $ \(dExc :: DecodeUserException) -> do + $logErrorS "Auth" $ tshow dExc mr <- getMessageRender - excRecovery . ServerError $ mr cExc + excRecovery . ServerError $ mr dExc ] acceptExisting :: SqlPersistT (HandlerFor UniWorX) (AuthenticationResult UniWorX) @@ -107,231 +104,300 @@ authenticate creds@Creds{..} = liftHandler . runDB . withReaderT projectBackend | not isDummy -> res <$ update uid [ UserLastAuthentication =. Just now ] _other -> return res - $logDebugS "auth" $ tshow Creds{..} - ldapPool' <- getsYesod $ view _appLdapPool + $logDebugS "Auth" $ tshow Creds{..} - 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 + flip catches excHandlers $ if + | not isDummy, not isOther + , Just upsertMode' <- upsertMode -> fetchUserData Creds{..} >>= \case + Just userData -> do + $logDebugS "Auth" $ "Successful user data lookup: " <> tshow userData + Authenticated . entityKey <$> upsertUser upsertMode' userData + Nothing + -> throwM FetchUserDataNoResult + | otherwise -> acceptExisting -data CampusUserConversionException - = CampusUserInvalidIdent - | CampusUserInvalidEmail - | CampusUserInvalidDisplayName - | CampusUserInvalidGivenName - | CampusUserInvalidSurname - | CampusUserInvalidTitle - -- | CampusUserInvalidMatriculation - | CampusUserInvalidFeaturesOfStudy Text - | CampusUserInvalidAssociatedSchools Text +data DecodeUserException + = DecodeUserInvalidIdent + | DecodeUserInvalidEmail + | DecodeUserInvalidDisplayName + | DecodeUserInvalidGivenName + | DecodeUserInvalidSurname + | DecodeUserInvalidTitle + | DecodeUserInvalidFeaturesOfStudy Text + | DecodeUserInvalidAssociatedSchools Text deriving (Eq, Ord, Read, Show, Generic) deriving anyclass (Exception) -_upsertCampusUserMode :: Traversal' (Creds UniWorX) UpsertCampusUserMode -_upsertCampusUserMode mMode cs@Creds{..} - | credsPlugin == apDummy = setMode <$> mMode (UpsertCampusUserLoginDummy $ CI.mk credsIdent) - | credsPlugin == apLdap = setMode <$> mMode UpsertCampusUserLoginLdap - | otherwise = setMode <$> mMode (UpsertCampusUserLoginOther $ CI.mk credsIdent) + +_upsertUserMode :: Traversal' (Creds UniWorX) UpsertUserMode +_upsertUserMode mMode cs@Creds{..} + | credsPlugin == apDummy = setMode <$> mMode (UpsertUserLoginDummy $ CI.mk credsIdent) + | credsPlugin `elem` loginAPs + = setMode <$> mMode (UpsertUserLogin credsPlugin) + | otherwise = setMode <$> mMode (UpsertUserLoginOther $ CI.mk credsIdent) where - setMode UpsertCampusUserLoginLdap - = cs{ credsPlugin = apLdap } - setMode (UpsertCampusUserLoginDummy ident) - = cs{ credsPlugin = apDummy - , credsIdent = CI.original ident - } - setMode (UpsertCampusUserLoginOther ident) - = cs{ credsPlugin = bool defaultOther credsPlugin (credsPlugin /= apDummy && credsPlugin /= apLdap) - , credsIdent = CI.original ident - } + setMode UpsertUserLogin{..} | upsertUserSource `elem` loginAPs + = cs { credsPlugin = upsertUserSource } + setMode UpsertUserLoginDummy{..} + = cs { credsPlugin = apDummy + , credsIdent = CI.original upsertUserIdent + } + setMode UpsertUserLoginOther{..} + = cs { credsPlugin = bool defaultOther credsPlugin (credsPlugin `notElem` [apDummy, apLdap, apAzure]) + , credsIdent = CI.original upsertUserIdent + } setMode _ = cs + loginAPs = [ apAzure, apLdap ] defaultOther = apHash -ldapLookupAndUpsert :: forall m. (MonadHandler m, HandlerSite m ~ UniWorX, MonadMask m, MonadUnliftIO m) => Text -> SqlPersistT m (Entity User) -ldapLookupAndUpsert ident = - getsYesod (view _appLdapPool) >>= \case - Nothing -> throwM $ CampusUserLdapError $ LdapHostNotResolved "No LDAP configuration in Foundation." - Just ldapPool -> - campusUser'' ldapPool campusUserFailoverMode ident >>= \case - Nothing -> throwM CampusUserNoResult - Just ldapResponse -> upsertCampusUser UpsertCampusUserGuessUser ldapResponse -{- 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])] --} +userLookupAndUpsert :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadMask m + , MonadUnliftIO m + ) + => Text + -> UpsertUserMode + -> SqlPersistT m (Maybe (Entity User)) +userLookupAndUpsert credsIdent mode = + fetchUserData Creds{credsPlugin=mempty,credsExtra=mempty,..} >>= maybeUpsertUser mode --- | 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 + +data FetchUserDataException + = FetchUserDataNoResult + | FetchUserDataAmbiguous + | FetchUserDataException + deriving (Eq, Ord, Read, Show, Generic) + deriving anyclass (Exception) + +-- | Fetch user data with given credentials from external source(s) +fetchUserData :: forall m site. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => 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 <&> second (filter (not . ByteString.null)) + , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName + -> return $ CI.mk azureUserPrincipalName' + | UpsertUserDataLdap{..} <- res + , ldapData <- Map.fromListWith (++) $ upsertUserLdapData <&> second (filter (not . ByteString.null)) + , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey + -> return $ CI.mk ldapPrimaryKey' + | otherwise + -> throwM DecodeUserInvalidIdent + void $ upsert ExternalUser{..} [ExternalUserData =. externalUserData, ExternalUserLastSync =. externalUserLastSync] + + return results + + +-- | Upsert User and related auth in DB according to given external source data (does not query source itself) +maybeUpsertUser :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertUserMode + -> Maybe (NonEmpty UpsertUserData) + -> SqlPersistT m (Maybe (Entity User)) +maybeUpsertUser _upsertMode Nothing = return Nothing +maybeUpsertUser _upsertMode (Just upsertData) = 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 - Just [oldUserId] -> updateGetEntity oldUserId 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 ())) + user@(Entity userId _userRec) <- case oldUsers of + [oldUserId] -> updateGetEntity oldUserId userUpdate + _other -> upsertBy (UniqueAuthentication (newUser ^. _userIdent)) newUser userUpdate let userSystemFunctions = determineSystemFunctions . Set.fromList $ map CI.mk userSystemFunctions' - userSystemFunctions' = do - (k, v) <- ldapData - guard $ k == ldapAffiliation - v' <- v - Right str <- return $ Text.decodeUtf8' v' - assertM' (not . Text.null) $ Text.strip str + userSystemFunctions' = concat $ upsertData <&> \case + UpsertUserDataAzure{..} -> do + (_k, v) <- upsertUserAzureData + v' <- v + Right str <- return $ Text.decodeUtf8' v' + 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) - => Maybe UserIdent -> Ldap.AttrList [] -> m (Either CampusUserConversionException (User, [Update User])) -decodeUserTest mbIdent ldapData = do - now <- liftIO getCurrentTime - userDefaultConf <- getsYesod $ view _appUserDefaults - let mode = maybe UpsertCampusUserLoginLdap UpsertCampusUserLoginDummy mbIdent - try $ decodeUser now userDefaultConf mode ldapData +upsertUser :: forall m. + ( MonadHandler m + , HandlerSite m ~ UniWorX + , MonadCatch m + ) + => UpsertUserMode + -> 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 now UserDefaultConf{..} upsertMode ldapData = do - let - userTelephone = decodeLdap ldapUserTelephone - userMobile = decodeLdap ldapUserMobile - userCompanyPersonalNumber = decodeLdap ldapUserFraportPersonalnummer - userCompanyDepartment = decodeLdap ldapUserFraportAbteilung - - 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) - +decodeUser :: ( MonadThrow m + ) + => UTCTime -- ^ Now + -> UserDefaultConf + -> NonEmpty UpsertUserData -- ^ Raw source data + -> m (User,_) -- ^ Data for new User entry and updating existing User entries +decodeUser now UserDefaultConf{..} upsertData = do userIdent <- if - | [bs] <- ldapMap !!! ldapUserPrincipalName - , Right userIdent' <- CI.mk <$> Text.decodeUtf8' bs - , hasn't _upsertCampusUserIdent upsertMode || has (_upsertCampusUserIdent . only userIdent') upsertMode - -> return userIdent' - | Just userIdent' <- upsertMode ^? _upsertCampusUserIdent - -> return userIdent' + | Just azureData <- mbAzureData + , [Text.decodeUtf8' -> Right azureUserPrincipalName'] <- azureData !!! azureUserPrincipalName + , Just azureUserPrincipalName'' <- assertM' (not . Text.null) $ Text.strip azureUserPrincipalName' + -> return $ CI.mk azureUserPrincipalName'' + | Just ldapData <- mbLdapData + , [Text.decodeUtf8' -> Right ldapPrimaryKey'] <- ldapData !!! ldapPrimaryKey + , Just ldapPrimaryKey'' <- assertM' (not . Text.null) $ Text.strip ldapPrimaryKey' + -> return $ CI.mk ldapPrimaryKey'' | otherwise - -> throwM CampusUserInvalidIdent - - userEmail <- if -- TODO: refactor! NOTE: LDAP doesnt know email for all users; we use userPrincialName instead; however validEmail refutes `E 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 + -> throwM DecodeUserInvalidIdent 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 - , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms - , userTheme = userDefaultTheme - , userDateTimeFormat = userDefaultDateTimeFormat - , userDateFormat = userDefaultDateFormat - , userTimeFormat = userDefaultTimeFormat - , userDownloadFiles = userDefaultDownloadFiles - , userWarningDays = userDefaultWarningDays - , userShowSex = userDefaultShowSex - , userSex = Nothing - , userBirthday = Nothing - , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced - , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels - , userNotificationSettings = def - , userLanguages = Nothing - , userCsvOptions = def - , userTokensIssuedAfter = Nothing - , userCreated = now - , userLastLdapSynchronisation = Just now - , userDisplayName = userDisplayName - , userDisplayEmail = userEmail - , userMatrikelnummer = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userPostAddress = Nothing -- not known from LDAP, must be derived from REST interface to AVS TODO - , userPostLastUpdate = Nothing - , userPinPassword = Nothing -- must be derived via AVS - , userPrefersPostal = userDefaultPrefersPostal + { userMaxFavourites = userDefaultMaxFavourites + , userMaxFavouriteTerms = userDefaultMaxFavouriteTerms + , userTheme = userDefaultTheme + , userDateTimeFormat = userDefaultDateTimeFormat + , userDateFormat = userDefaultDateFormat + , userTimeFormat = userDefaultTimeFormat + , userDownloadFiles = userDefaultDownloadFiles + , userWarningDays = userDefaultWarningDays + , userShowSex = userDefaultShowSex + , userSex = Nothing + , userBirthday = Nothing + , userTitle = Nothing + , userExamOfficeGetSynced = userDefaultExamOfficeGetSynced + , userExamOfficeGetLabels = userDefaultExamOfficeGetLabels + , userNotificationSettings = def + , userCsvOptions = def + , userTokensIssuedAfter = Nothing + , userDisplayEmail = userEmail + , userMatrikelnummer = Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS + , userPostAddress = Nothing -- TODO: not known from Azure/LDAP, must be derived from REST interface to AVS + , userPostLastUpdate = Nothing + , userPinPassword = Nothing -- must be derived via AVS + , userPrefersPostal = userDefaultPrefersPostal + , userPasswordHash = Nothing + , userLastAuthentication = Nothing + , userCreated = now + , userLastSync = Just now , .. } - userUpdate = - [ UserLastAuthentication =. Just now | isLogin ] ++ - [ UserEmail =. userEmail | validEmail' userEmail ] ++ - [ - -- UserDisplayName =. userDisplayName -- not updated here, since users are allowed to change their DisplayName; see line 272 - UserFirstName =. userFirstName - , UserSurname =. userSurname - , UserLastLdapSynchronisation =. Just now - , UserLdapPrimaryKey =. userLdapPrimaryKey - , UserMobile =. userMobile - , UserTelephone =. userTelephone - , UserCompanyPersonalNumber =. userCompanyPersonalNumber - , UserCompanyDepartment =. userCompanyDepartment + userUpdate = + [ UserSurname =. userSurname + , UserFirstName =. userFirstName + -- , UserDisplayName =. userDisplayName -- not updated, since users are allowed to change their DisplayName + , UserEmail =. userEmail + , UserTelephone =. userTelephone + , UserMobile =. userMobile + , UserCompanyPersonalNumber =. userCompanyPersonalNumber + , UserCompanyDepartment =. userCompanyDepartment + , UserLastSync =. Just now ] return (newUser, userUpdate) where - ldapMap :: Map.Map Ldap.Attr [Ldap.AttrValue] -- Recall: Ldap.AttrValue == ByteString - ldapMap = Map.fromListWith (++) $ ldapData <&> second (filter (not . ByteString.null)) + mbAzureData :: Maybe (Map Text [ByteString]) + mbAzureData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserAzureData <$> NonEmpty.toList upsertData + mbLdapData :: Maybe (Map Ldap.Attr [Ldap.AttrValue]) -- Recall: Ldap.AttrValue == ByteString + mbLdapData = fmap (Map.fromListWith (++) . map (second (filter (not . ByteString.null)))) . concat $ preview _upsertUserLdapData <$> NonEmpty.toList upsertData -- just returns Nothing on error, pure - decodeLdap :: Ldap.Attr -> Maybe Text - decodeLdap attr = listToMaybe . rights $ Text.decodeUtf8' <$> ldapMap !!! attr + decodeAzure :: Map Text [ByteString] -> Text -> Maybe Text + 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 - decodeLdap' = fromMaybe "" . decodeLdap + -- decodeAzure' :: Map Text [ByteString] -> Text -> Text + -- 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 @@ -343,11 +409,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 - | (h:_) <- rights vs = return h - | otherwise = throwM err - where - vs = Text.decodeUtf8' <$> (ldapMap !!! attr) + -- decodeLdap1 ldapData attr err + -- | (h:_) <- rights vs = return h + -- | otherwise = throwM err + -- where + -- vs = Text.decodeUtf8' <$> (ldapData !!! attr) -- accept and merge one or more successful decodings, ignoring all others -- decodeLdapN attr err @@ -357,6 +423,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 @@ -371,11 +448,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"] @@ -406,7 +486,4 @@ updateUserLanguage Nothing = runMaybeT $ do setRegisteredCookie CookieLang lang return lang -campusUserFailoverMode :: FailoverMode -campusUserFailoverMode = FailoverUnlimited - -embedRenderMessage ''UniWorX ''CampusUserConversionException id +embedRenderMessage ''UniWorX ''DecodeUserException id diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index fd001c768..d99be986a 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -31,7 +31,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 getAdminR :: Handler Html diff --git a/src/Handler/Admin/ExternalUser.hs b/src/Handler/Admin/ExternalUser.hs new file mode 100644 index 000000000..fc67a6616 --- /dev/null +++ b/src/Handler/Admin/ExternalUser.hs @@ -0,0 +1,74 @@ +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , David Mosbach , Steffen Jost +-- +-- 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") diff --git a/src/Handler/Admin/Ldap.hs b/src/Handler/Admin/Ldap.hs deleted file mode 100644 index c3ed22c2a..000000000 --- a/src/Handler/Admin/Ldap.hs +++ /dev/null @@ -1,69 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost --- --- 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") - diff --git a/src/Handler/Admin/Test.hs b/src/Handler/Admin/Test.hs index 1969f8717..e6acc5d5d 100644 --- a/src/Handler/Admin/Test.hs +++ b/src/Handler/Admin/Test.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -321,8 +321,8 @@ postAdminTestR = do
appJobCronInterval
#{tshow appJobCronInterval} -
appSynchroniseLdapUsersWithin -
#{tshow appSynchroniseLdapUsersWithin} +
appUserSyncWithin +
#{tshow appUserSyncWithin}
appSynchroniseAvsUsersWithin
#{tshow appSynchroniseAvsUsersWithin} |] diff --git a/src/Handler/Course/Users.hs b/src/Handler/Course/Users.hs index 4a4e11e9d..744ca2671 100644 --- a/src/Handler/Course/Users.hs +++ b/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) diff --git a/src/Handler/Exam/Users.hs b/src/Handler/Exam/Users.hs index cd06ea982..09e14253f 100644 --- a/src/Handler/Exam/Users.hs +++ b/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 diff --git a/src/Handler/LMS/Fake.hs b/src/Handler/LMS/Fake.hs index cd7392760..743f076f8 100644 --- a/src/Handler/LMS/Fake.hs +++ b/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 - userLdapPrimaryKey = Nothing + userLastSync = Just now userTokensIssuedAfter = Nothing userFirstName = Text.unwords firstNames userTitle = Nothing diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index 3a0103c58..a29a60933 100644 --- a/src/Handler/Profile.hs +++ b/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 diff --git a/src/Handler/SAP.hs b/src/Handler/SAP.hs index 3414b618b..bef117074 100644 --- a/src/Handler/SAP.hs +++ b/src/Handler/SAP.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost -- -- 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 @@ -96,8 +94,16 @@ compileBlocks dStart dEnd = go (dStart, True) getQualificationSAPDirectR :: Handler TypedContent getQualificationSAPDirectR = do now <- liftIO getCurrentTime - fdate <- formatTime' "%Y%m%d_%H-%M" now - let ldap_cutoff = addDiffDaysRollOver (fromMonths $ -3) now + fdate <- formatTime' "%Y%m%d_%H-%M" 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.^. UserLastLdapSynchronisation) - E.&&. (E.justVal ldap_cutoff E.<=. user E.^. UserLastLdapSynchronisation) + E.&&. E.isJust (user E.^. UserCompanyPersonalNumber) + E.where_ . E.exists $ do + 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 diff --git a/src/Handler/SingleSignOut.hs b/src/Handler/SingleSignOut.hs new file mode 100644 index 000000000..ea057b4f0 --- /dev/null +++ b/src/Handler/SingleSignOut.hs @@ -0,0 +1,31 @@ +-- SPDX-FileCopyrightText: 2024 David Mosbach +-- +-- SPDX-License-Identifier: AGPL-3.0-or-later + +module Handler.SingleSignOut + ( getSOutR + , getSSOutR + ) where + +import Import +import Auth.OAuth2 (singleSignOut) +import qualified Network.Wai as W + + +getSOutR :: Handler Html +getSOutR = do + $logDebugS "\27[31mSOut\27[0m" "Redirect to LogoutR" + redirect $ AuthR LogoutR + +getSSOutR :: Handler Html +getSSOutR = do + app <- getYesod + let redir = intercalate "/" . fst . renderRoute $ SOutR + root = case approot of + ApprootRequest f -> f app W.defaultRequest + _ -> error "approt implementation changed" + url = decodeUtf8 . urlEncode True . encodeUtf8 $ root <> "/" <> redir + AppSettings{..} <- getsYesod appSettings' + $logDebugS "\27[31mSSOut\27[0m" "Redirect to auth server" + if appSingleSignOn then singleSignOut (Just url) else redirect (AuthR LogoutR) + diff --git a/src/Handler/Users.hs b/src/Handler/Users.hs index 2af62ef7d..d29bbd82d 100644 --- a/src/Handler/Users.hs +++ b/src/Handler/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Winnie Ros -- -- 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 @@ -130,8 +125,8 @@ postUsersR = do icnReroute = text2widget " " <> toWgt (icon IconLetter) pure $ mconcat supervisors , sortable (Just "last-login") (i18nCell MsgLastLogin) $ \DBRow{ dbrOutput = Entity _ User{..} } -> maybe mempty dateTimeCell userLastAuthentication - , sortable (Just "auth-ldap") (i18nCell MsgAuthMode) $ \DBRow{ dbrOutput = Entity _ User{..} } -> i18nCell userAuthentication - , 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 @@ -226,15 +221,15 @@ postUsersR = do , ( "company-department" , SortColumn $ \user -> user E.^. UserCompanyDepartment ) - , ( "auth-ldap" - , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP - ) + -- , ( "auth-ldap" + -- , SortColumn $ \user -> user E.^. UserAuthentication E.!=. E.val AuthLDAP + -- ) -- TODO: reintroduce via ExternalUser , ( "last-login" , SortColumn $ \user -> user E.^. UserLastAuthentication ) - , ( "ldap-sync" - , SortColumn $ \user -> user E.^. UserLastLdapSynchronisation - ) + -- , ( "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 @@ -276,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 - | Just crit <- getLast criterion - -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit - | otherwise - -> E.true - ) + -- , ( "auth-ldap", FilterColumn $ \user (criterion :: Last Bool) -> if + -- | Just crit <- getLast criterion + -- -> (user E.^. UserAuthentication E.==. E.val AuthLDAP) E.==. E.val crit + -- | otherwise + -- -> 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 - | Just criteria' <- fromNullable criteria - -> let minTime = minimum (criteria' :: NonNull (Set UTCTime)) - in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation - | otherwise -> E.val True :: E.SqlExpr (E.Value Bool) - ) + -- , ( "ldap-sync", FilterColumn $ \user criteria -> if + -- | Just criteria' <- fromNullable criteria + -- -> let minTime = minimum (criteria' :: NonNull (Set UTCTime)) + -- in E.maybe E.true (E.<=. E.val minTime) $ user E.^. UserLastLdapSynchronisation + -- | 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` @@ -335,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 "ldap-sync" . maybePrism _PathPiece) mPrev $ aopt utcTimeField (fslI MsgLdapSyncedBefore) + -- , 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) -- TODO: reintroduce via ExternalUser ] , dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout } , dbtParams = DBParamsForm @@ -364,8 +359,8 @@ postUsersR = do | Set.null usersSet && isNotSetSupervisor act -> addMessageI Info MsgActionNoUsersSelected (UserLdapSyncData, userSet) -> do - forM_ userSet $ \uid -> queueJob' $ JobSynchroniseLdapUser uid - addMessageI Success . MsgSynchroniseLdapUserQueued $ Set.size userSet + forM_ userSet $ queueJob' . JobSynchroniseUser + addMessageI Success . MsgSynchroniseUserdbUserQueued $ Set.size userSet redirectKeepGetParams UsersR (UserAvsSyncData, userSet) -> do forM_ userSet $ \uid -> queueJob' $ JobSynchroniseAvsUser uid Nothing @@ -400,8 +395,8 @@ postUsersR = do formResult allUsersRes $ \case AllUsersLdapSync -> do - runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseLdapUser . entityKey) - addMessageI Success MsgSynchroniseLdapAllUsersQueued + runDBJobs . runConduit $ selectSource [] [] .| C.mapM_ (queueDBJob . JobSynchroniseUser . entityKey) + addMessageI Success MsgSynchroniseUserdbAllUsersQueued redirect UsersR let allUsersWgt' = wrapForm allUsersWgt def { formSubmit = FormNoSubmit @@ -506,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 @@ -532,33 +527,41 @@ postAdminUserR uuid = do redirect $ AdminUserR uuid userAuthenticationAction = \case - BtnAuthLDAP -> do - let - campusHandler :: MonadPlus m => Auth.CampusUserException -> m a - campusHandler _ = mzero - campusResult <- runMaybeT . handle campusHandler $ do - Just pool <- getsYesod $ view _appLdapPool - void . lift . Auth.campusUser pool FailoverUnlimited $ Creds Auth.apLdap (CI.original userIdent) [] - case campusResult of - Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup - _other - | is _AuthLDAP userAuthentication - -> addMessageI Info MsgAuthLDAPAlreadyConfigured - Just () -> do - runDBJobs $ do - update uid [ UserAuthentication =. AuthLDAP ] - queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid + BtnAuthLDAP -> do -- TODO: Reformulate messages and constructors to "remove pw hash" or "external login only" + -- let + -- ldapHandler :: MonadPlus m => Auth.LdapUserException -> m a + -- ldapHandler _ = mzero + -- ldapResult <- runMaybeT . handle ldapHandler $ do + -- Just pool <- getsYesod $ view _appLdapPool + -- void . lift . Auth.ldapUser pool $ Creds Auth.apLdap (CI.original userIdent) [] + -- case ldapResult of + -- Nothing -> addMessageI Error MsgAuthLDAPInvalidLookup + -- _other + -- | is _AuthLDAP userAuthentication + -- -> addMessageI Info MsgAuthLDAPAlreadyConfigured + -- Just () -> do + -- runDBJobs $ do + -- update uid [ UserAuthentication =. AuthLDAP ] + -- 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 @@ -718,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) @@ -746,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}|] $ diff --git a/src/Handler/Users/Add.hs b/src/Handler/Users/Add.hs index 872431554..5537c7d8c 100644 --- a/src/Handler/Users/Add.hs +++ b/src/Handler/Users/Add.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2023 Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost , Winnie Ros -- -- 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 - let authKind = audAuth aud - when (authKind /= AuthKindNoLogin) $ + queueDBJob $ JobSynchroniseUser uid + when (is _Just $ audPassword aud) $ do queueDBJob . JobQueueNotification $ NotificationUserAuthModeUpdate uid - when (authKind == AuthKindPWHash) $ queueDBJob $ JobSendPasswordReset uid return $ Just uid diff --git a/src/Handler/Utils/Avs.hs b/src/Handler/Utils/Avs.hs index 42275f139..222ec4ba6 100644 --- a/src/Handler/Utils/Avs.hs +++ b/src/Handler/Utils/Avs.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost -- -- 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 (ldapLookupAndUpsert) -- , CampusUserConversionException()) +import Foundation.Yesod.Auth (userLookupAndUpsert) 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 - Right Entity{entityKey=uid, entityVal=User{userCompanyPersonalNumber=Just persNo}} -> + Nothing -> try (runDB $ userLookupAndUpsert someid UpsertUserGuessUser) >>= \case + 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 - Right Entity{entityVal=User{userCompanyPersonalNumber=Just persNo}} -> maybeCatchAll $ upsertAvsUserByCard (Right $ mkAvsInternalPersonalNo persNo) + try (runDB $ userLookupAndUpsert otherId UpsertUserGuessUser) >>= \case + 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) - <- try $ ldapLookupAndUpsert persNo + upsRes :: Either SomeException (Maybe (Entity User)) + <- 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 diff --git a/src/Handler/Utils/Users.hs b/src/Handler/Utils/Users.hs index e281c7fcf..82d58fea6 100644 --- a/src/Handler/Utils/Users.hs +++ b/src/Handler/Utils/Users.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost -- -- 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 (upsertCampusUser) +import Foundation.Yesod.Auth (userLookupAndUpsert) 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 - ldapPool' <- getsYesod $ view _appLdapPool - fmap join . for ldapPool' $ \ldapPool -> do - ldapData <- campusUserMatr' ldapPool FailoverUnlimited userMatr - for ldapData $ upsertCampusUser UpsertCampusUserGuessUser + doUpsert = flip userLookupAndUpsert UpsertUserGuessUser 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)) - convertLdapResults [] = Nothing - convertLdapResults [x] = Just $ Right x - convertLdapResults xs = Just $ Left $ NonEmpty.fromList xs + convertUpsertResults :: [Entity User] -> Maybe (Either (NonEmpty (Entity User)) (Entity User)) + convertUpsertResults [] = Nothing + convertUpsertResults [x] = Just $ Right x + 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 - , mergeBy (<) UserAuthentication + [ mergeMaybe UserPasswordHash , mergeBy (>) UserLastAuthentication , mergeBy (<) UserCreated , toMaybe (not (validEmail' (newUser ^. _userEmail )) && validEmail' (oldUser ^. _userEmail)) diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index 90edef7a1..d5bd8072e 100644 --- a/src/Import/NoModel.hs +++ b/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) diff --git a/src/Jobs.hs b/src/Jobs.hs index b45b24b82..d08a6f500 100644 --- a/src/Jobs.hs +++ b/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 diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 72ae6a7c4..476cfe841 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , David Mosbach , Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost -- -- 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 <- appSynchroniseLdapUsersWithin - , Just cInterval <- appJobCronInterval + | Just syncWithin <- appUserSyncWithin + , 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 - , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appSynchroniseLdapUsersInterval nextIntervalTime + , cronRateLimit = appUserSyncInterval + , cronNotAfter = Right . CronTimestamp . utcToLocalTimeTZ appTZ $ addUTCTime appUserSyncInterval nextIntervalTime } | otherwise -> return () diff --git a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs index b89e45c82..a03beb3fc 100644 --- a/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs +++ b/src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Jobs/Handler/SendPasswordReset.hs b/src/Jobs/Handler/SendPasswordReset.hs index 5a93f3ba3..cf6686d46 100644 --- a/src/Jobs/Handler/SendPasswordReset.hs +++ b/src/Jobs/Handler/SendPasswordReset.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Winnie Ros +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Winnie Ros -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -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)]) diff --git a/src/Jobs/Handler/SynchroniseLdap.hs b/src/Jobs/Handler/SynchroniseLdap.hs deleted file mode 100644 index 52572d879..000000000 --- a/src/Jobs/Handler/SynchroniseLdap.hs +++ /dev/null @@ -1,64 +0,0 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen --- --- 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) diff --git a/src/Jobs/Handler/SynchroniseUser.hs b/src/Jobs/Handler/SynchroniseUser.hs new file mode 100644 index 000000000..231dd851d --- /dev/null +++ b/src/Jobs/Handler/SynchroniseUser.hs @@ -0,0 +1,48 @@ +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen +-- +-- 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{..} diff --git a/src/Jobs/HealthReport.hs b/src/Jobs/HealthReport.hs index 1f503321b..8e2da381a 100644 --- a/src/Jobs/HealthReport.hs +++ b/src/Jobs/HealthReport.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Steffen Jost -- -- 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) - hCampusExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err) - in handle hCampusExc $ Sum 1 <$ campusUserReTest ldapPool ((>= reTestAfter) . realToFrac) FailoverUnlimited (Creds apLdap adminIdent []) + let hLdapExc :: LdapUserException -> Handler (Sum Integer) + hLdapExc err = mempty <$ $logErrorS "healthCheckLDAPAdmins" (adminIdent <> ": " <> tshow err) + 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 diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index 69ad6b4d6..e1545dc89 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost -- -- 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 - JobSynchroniseLdapUser{} -> Just JobNoQueueSame + JobSynchroniseUsers{} -> Just JobNoQueueSame + JobSynchroniseUser{} -> Just JobNoQueueSame JobSynchroniseAvs{} -> Just JobNoQueueSame JobSynchroniseAvsUser{} -> Just JobNoQueueSame JobSynchroniseAvsId{} -> Just JobNoQueueSame diff --git a/src/Ldap/Client/Instances.hs b/src/Ldap/Client/Instances.hs index ca2689934..04db439e6 100644 --- a/src/Ldap/Client/Instances.hs +++ b/src/Ldap/Client/Instances.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen -- -- 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 diff --git a/src/Ldap/Client/Pool.hs b/src/Ldap/Client/Pool.hs index 47eb4147c..96216e354 100644 --- a/src/Ldap/Client/Pool.hs +++ b/src/Ldap/Client/Pool.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen -- -- SPDX-License-Identifier: AGPL-3.0-or-later diff --git a/src/Model/Migration/Definitions.hs b/src/Model/Migration/Definitions.hs index ab0147ff4..1f78bbbaf 100644 --- a/src/Model/Migration/Definitions.hs +++ b/src/Model/Migration/Definitions.hs @@ -50,6 +50,7 @@ data ManualMigration = Migration20230524QualificationUserBlock | Migration20230703LmsUserStatus | Migration20240212InitInterfaceHealth -- create table interface_health and fill with default values + | Migration20240312OAuth2 deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) deriving anyclass (Universe, Finite) @@ -81,7 +82,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") @@ -195,7 +196,24 @@ customMigrations = mapF $ \case ('Printer', 'Acknowledge', True, 168) , ('AVS' , 'Synch' , True , 96) ON CONFLICT DO NOTHING; - |] + |] + + Migration20240312OAuth2 -> whenM (andM [ columnNotExists "user" "password_hash", columnExists "user" "authentication", columnExists "user" "last_ldap_synchronisation", columnNotExists "user" "last_sync", columnExists "user" "ldap_primary_key" ]) $ do + [executeQQ| + ALTER TABLE "user" ADD COLUMN "password_hash" VARCHAR NULL; + |] + 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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index c3cd32a20..4e8a7d388 100644 --- a/src/Model/Types.hs +++ b/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 diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Auth.hs similarity index 80% rename from src/Model/Types/Security.hs rename to src/Model/Types/Auth.hs index cb73195b2..c1704c7bc 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Auth.hs @@ -1,75 +1,103 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Sarah Vaupel , Steffen Jost -- -- 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.Security +module Model.Types.Auth + ( 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 Data.Universe.Instances.Reverse () -import Data.Proxy -import Data.Data (Data) +import Model.Types.TH.PathPiece + +import Utils +import Utils.Lens.TH import Control.Lens -import qualified Data.Set as Set - -import qualified Data.Text as Text - -import qualified Data.HashMap.Strict as HashMap - +import Data.Aeson +import Data.Aeson.TH import qualified Data.Aeson.Types as Aeson - -import Data.CaseInsensitive (CI) +import qualified Data.Binary as Binary +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.Set.Instances () +import Data.Data (Data) +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 } - | AuthNoLogin - deriving (Eq, Ord, Read, Show, Generic) +---------------------------------- +----- Authentication Sources ----- +---------------------------------- -instance Hashable AuthenticationMode -instance NFData AuthenticationMode +type AzureScopes = Set Text + +-- 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' 1 - , sumEncoding = UntaggedValue - } ''AuthenticationMode + { fieldLabelModifier = camelToPathPiece' 3 + , constructorTagModifier = camelToPathPiece' 3 + , sumEncoding = UntaggedValue + } ''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 - | AuthIsPWHash + | AuthIsExternal -- TODO: maybe distinguish between AuthenticationProtocols + | 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 diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs index 986aa3871..83fb519f5 100644 --- a/src/Model/Types/Exam.hs +++ b/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) #-} diff --git a/src/Model/Types/User.hs b/src/Model/Types/User.hs index 64cb539d9..7938f0763 100644 --- a/src/Model/Types/User.hs +++ b/src/Model/Types/User.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Sarah Vaupel , Steffen Jost -- -- 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 diff --git a/src/Settings.hs b/src/Settings.hs index e3fcc6105..d94267891 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,David Mosbach -- -- 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) + +newtype 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,12 +452,16 @@ data AppSettings = AppSettings , appDatabaseConf :: PostgresConf -- ^ Configuration settings for accessing the database. , appAutoDbMigrate :: Bool - , appLdapConf :: Maybe (PointedList LdapConf) - -- ^ Configuration settings for CSV export/import to LMS (= Learn Management System) + , appUserAuthConf :: UserAuthConf + , appSingleSignOn :: Bool + -- ^ Enable OIDC single sign-on + , appAutoSignOn :: Bool + -- ^ Automatically redirect to SSO route when not signed on + -- ^ Note: This will force authentication, thus the site will be inaccessible without external credentials. Only use this option when it is ensured that every user that should be able to access the site has valid external credentials! , 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 @@ -109,15 +469,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 - -- from the request headers. + -- ^ Base for all generated URLs. If @Nothing@, determined 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 - -- behind a reverse proxy. + -- ^ Get the IP address from the header when logging. Useful when sitting behind a reverse proxy. , appServerSessionConfig :: ServerSessionSettings , appServerSessionAcidFallback :: Bool @@ -158,18 +516,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 - , appSynchroniseLdapUsersInterval :: NominalDiffTime + -- , appUserRetestFailover :: DiffTime -- TODO: reintroduce and move into failover settings once failover mode has been reimplemented + -- 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 @@ -254,365 +615,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 = @@ -627,10 +629,16 @@ instance FromJSON AppSettings where appWebpackEntrypoints <- o .: "webpack-manifest" appDatabaseConf <- o .: "database" appAutoDbMigrate <- o .: "auto-db-migrate" - 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" .!= [] + -- 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" .!= False + appAutoSignOn <- o .:? "auto-sign-on" .!= False appLmsConf <- o .: "lms-direct" appAvsConf <- assertM (not . null . avsPass) <$> o .:? "avs" appLprConf <- o .: "lpr" @@ -695,14 +703,13 @@ instance FromJSON AppSettings where appSessionTimeout <- o .: "session-timeout" - appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within" - appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval" + -- appUserRetestFailover <- o .: "userdb-retest-failover" + 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" @@ -816,6 +823,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. -- @@ -825,16 +852,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 @@ -855,24 +872,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 diff --git a/src/Settings/Ldap.hs b/src/Settings/Ldap.hs new file mode 100644 index 000000000..915f4ebce --- /dev/null +++ b/src/Settings/Ldap.hs @@ -0,0 +1,63 @@ +-- SPDX-FileCopyrightText: 2024 Sarah Vaupel +-- +-- 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{..} diff --git a/src/Settings/OAuth2.hs b/src/Settings/OAuth2.hs new file mode 100644 index 000000000..ba1980178 --- /dev/null +++ b/src/Settings/OAuth2.hs @@ -0,0 +1,32 @@ +-- SPDX-FileCopyrightText: 2024 Sarah Vaupel +-- +-- 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 diff --git a/src/Settings/ResourcePool.hs b/src/Settings/ResourcePool.hs new file mode 100644 index 000000000..df3fa3156 --- /dev/null +++ b/src/Settings/ResourcePool.hs @@ -0,0 +1,30 @@ +-- SPDX-FileCopyrightText: 2024 Sarah Vaupel +-- +-- 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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 18c96c289..8884c221b 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2023 Felix Hamann ,Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Steffen Jost ,Wolfgang Witt +-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel , Felix Hamann , Gregor Kleen , Sarah Vaupel , Sarah Vaupel , Steffen Jost , Steffen Jost , Wolfgang Witt -- -- 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||] + fvValue = either id UUID.toText fvInput' + fieldEnctype = UrlEncoded + -------------------- -- Field Settings -- -------------------- @@ -1259,10 +1274,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) diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 07804c015..1f72ea042 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022-23 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost +-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen ,Sarah Vaupel ,Sarah Vaupel ,Steffen Jost ,Wolfgang Witt ,Steffen Jost ,David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -81,6 +81,7 @@ data Icon | IconNavContainerClose | IconPageActionChildrenClose | IconMenuNews | IconMenuHelp + | IconMenuAccount | IconMenuProfile | IconMenuLogin | IconMenuLogout | IconBreadcrumbsHome @@ -173,6 +174,7 @@ iconText = \case IconPageActionChildrenClose -> "chevron-up" IconMenuNews -> "megaphone" IconMenuHelp -> "question" + IconMenuAccount -> "user" IconMenuProfile -> "cogs" IconMenuLogin -> "sign-in-alt" IconMenuLogout -> "sign-out-alt" diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index adcba7262..b6aec5284 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -260,8 +260,6 @@ makeLenses_ ''ExamOccurrence makeLenses_ ''ExamOfficeLabel -makePrisms ''AuthenticationMode - makeLenses_ ''CourseUserNote makeLenses_ ''CourseParticipant diff --git a/src/Utils/Session.hs b/src/Utils/Session.hs index ef104b29c..4b5e5c378 100644 --- a/src/Utils/Session.hs +++ b/src/Utils/Session.hs @@ -1,4 +1,4 @@ --- SPDX-FileCopyrightText: 2022 Gregor Kleen +-- SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , David Mosbach -- -- SPDX-License-Identifier: AGPL-3.0-or-later @@ -20,6 +20,7 @@ data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags | SessionLang | SessionError | SessionFiles + | SessionOAuth2Token deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic) deriving anyclass (Universe, Finite) diff --git a/src/Utils/Users.hs b/src/Utils/Users.hs index 2339fbed5..7c676299a 100644 --- a/src/Utils/Users.hs +++ b/src/Utils/Users.hs @@ -1,35 +1,16 @@ --- SPDX-FileCopyrightText: 2022 Steffen Jost +-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost -- -- 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 \ No newline at end of file + runDB $ insertUnique newUser \ No newline at end of file diff --git a/src/Yesod/Servant.hs b/src/Yesod/Servant.hs index 1c08c46fc..ff56f8a3e 100644 --- a/src/Yesod/Servant.hs +++ b/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(..) diff --git a/stack.yaml b/stack.yaml index 2c7b72c31..7346e8392 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost +# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost # # SPDX-License-Identifier: AGPL-3.0-or-later @@ -26,33 +26,33 @@ packages: - . extra-deps: - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git + - git: https://gitlab.uniworx.de/haskell/encoding.git commit: 22fc3bb14841d8d50997aa47f1be3852e666f787 - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git + - git: https://gitlab.uniworx.de/haskell/memcached-binary.git commit: b7071df50bad3a251a544b984e4bf98fa09b8fae - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git + - git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git commit: cbea6159c2975d42f948525e03e12fc390da53c5 - git: https://github.com/jtdaugherty/HaskellNet.git commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git + - git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git + - git: https://gitlab.uniworx.de/haskell/ldap-client.git commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git + - git: https://gitlab.uniworx.de/haskell/serversession.git commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 subdirs: - serversession - serversession-backend-acid-state - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git + - git: https://gitlab.uniworx.de/haskell/xss-sanitize.git commit: dc928c3a456074b8777603bea20e81937321777f - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git + - git: https://gitlab.uniworx.de/haskell/colonnade.git commit: f8170266ab25b533576e96715bedffc5aa4f19fa subdirs: - colonnade - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git + - git: https://gitlab.uniworx.de/haskell/minio-hs.git commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git + - git: https://gitlab.uniworx.de/haskell/cryptoids.git commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 subdirs: - cryptoids-class @@ -67,10 +67,10 @@ extra-deps: - gearhash - fastcdc - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git + - git: https://gitlab.uniworx.de/haskell/zip-stream.git commit: 843683d024f767de236f74d24a3348f69181a720 - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + - git: https://gitlab.uniworx.de/haskell/yesod.git commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 # <- references debug with traceStack; master ref: cb75191e0c5490246ae2cbcc2a00e7985cf2aadb subdirs: - yesod-core @@ -88,10 +88,13 @@ extra-deps: - yesod-eventsource - yesod-websockets - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git + - git: https://github.com/freckle/yesod-auth-oauth2 + commit: 342dac80e40b10f07694a7e9aa8bab6d03ed6d66 + + - git: https://gitlab.uniworx.de/haskell/cryptonite.git commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f - - git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git + - git: https://gitlab.uniworx.de/haskell/esqueleto.git commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37 - classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 diff --git a/stack.yaml.lock b/stack.yaml.lock index cb7c7063a..40712391d 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,539 +5,550 @@ packages: - completed: + commit: 22fc3bb14841d8d50997aa47f1be3852e666f787 + git: https://gitlab.uniworx.de/haskell/encoding.git name: encoding - version: 0.8.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git pantry-tree: - size: 5723 sha256: fec12328951021bb4d9326ae0b35f0c459e65f28442366efd4366cd1e18abe19 - commit: 22fc3bb14841d8d50997aa47f1be3852e666f787 + size: 5723 + version: 0.8.2 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/encoding.git commit: 22fc3bb14841d8d50997aa47f1be3852e666f787 + git: https://gitlab.uniworx.de/haskell/encoding.git - completed: + commit: b7071df50bad3a251a544b984e4bf98fa09b8fae + git: https://gitlab.uniworx.de/haskell/memcached-binary.git name: memcached-binary - version: 0.2.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git pantry-tree: - size: 1277 sha256: 0da0539b7b9a56d03a116dcd666bc1bbbef085659910420849484d1418aa0857 - commit: b7071df50bad3a251a544b984e4bf98fa09b8fae + size: 1277 + version: 0.2.0 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/memcached-binary.git commit: b7071df50bad3a251a544b984e4bf98fa09b8fae + git: https://gitlab.uniworx.de/haskell/memcached-binary.git - completed: + commit: cbea6159c2975d42f948525e03e12fc390da53c5 + git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git name: conduit-resumablesink - version: '0.3' - git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git pantry-tree: - size: 394 sha256: 0cccf4684bbd84f81d2d3d53dd81c46cb103b5322f1d8e89e9b222211281e1b7 - commit: cbea6159c2975d42f948525e03e12fc390da53c5 + size: 394 + version: '0.3' original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/conduit-resumablesink.git commit: cbea6159c2975d42f948525e03e12fc390da53c5 + git: https://gitlab.uniworx.de/haskell/conduit-resumablesink.git - completed: + commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 + git: https://github.com/jtdaugherty/HaskellNet.git name: HaskellNet - version: 0.5.1 - git: https://github.com/jtdaugherty/HaskellNet.git pantry-tree: - size: 4011 sha256: 921b437ef18ccb04f889301c407263d6b5b72c5864803a000b1e61328988ce70 - commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 + size: 4011 + version: 0.5.1 original: + commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 git: https://github.com/jtdaugherty/HaskellNet.git - commit: 5aa1f3b009253b02c4822005ac59ee208a10a347 - completed: + commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 + git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git name: HaskellNet-SSL - version: 0.3.4.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git pantry-tree: - size: 841 sha256: 95dcec22fdb8af986e59f0f60aa76d4a48f34a546dca799bd571e1d183f773e0 - commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 + size: 841 + version: 0.3.4.1 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/HaskellNet-SSL.git commit: 40393c938111ac78232dc2c7eec5edb4a22d03e8 + git: https://gitlab.uniworx.de/haskell/HaskellNet-SSL.git - completed: + commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 + git: https://gitlab.uniworx.de/haskell/ldap-client.git name: ldap-client - version: 0.4.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git pantry-tree: - size: 6176 sha256: 3fa8f102427b437b2baaec15cf884e88b47a1621b1c3fd4d8919f0263fde8656 - commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 + size: 6176 + version: 0.4.0 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/ldap-client.git commit: 01afaf599ba6f8a9d804c269e91d3190b249d3f0 + git: https://gitlab.uniworx.de/haskell/ldap-client.git - completed: - subdir: serversession + commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 + git: https://gitlab.uniworx.de/haskell/serversession.git name: serversession - version: 1.0.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git pantry-tree: - size: 545 sha256: 83ac78a987399db3da62f84bbd335fead11aadebd57251d0688127fca984db23 - commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 - original: + size: 545 subdir: serversession - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git + version: 1.0.2 + original: commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 + git: https://gitlab.uniworx.de/haskell/serversession.git + subdir: serversession - completed: - subdir: serversession-backend-acid-state + commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 + git: https://gitlab.uniworx.de/haskell/serversession.git name: serversession-backend-acid-state - version: 1.0.4 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git pantry-tree: - size: 544 sha256: 4804260c6245c12e1728c78dd33bf16e95b7f2b69b38b6900a4e65b1ef3e04b7 - commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 - original: + size: 544 subdir: serversession-backend-acid-state - git: https://gitlab.ifi.lmu.de/uni2work/haskell/serversession.git + version: 1.0.4 + original: commit: fda3a000f9039e35e76e28f8e88c4942fac9fd69 + git: https://gitlab.uniworx.de/haskell/serversession.git + subdir: serversession-backend-acid-state - completed: + commit: dc928c3a456074b8777603bea20e81937321777f + git: https://gitlab.uniworx.de/haskell/xss-sanitize.git name: xss-sanitize - version: 0.3.6 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git pantry-tree: - size: 750 sha256: f567a1c834448daaa164f2029fad164e6c8df2d4c92b51f811bae19cc0c95975 - commit: dc928c3a456074b8777603bea20e81937321777f + size: 750 + version: 0.3.6 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/xss-sanitize.git commit: dc928c3a456074b8777603bea20e81937321777f + git: https://gitlab.uniworx.de/haskell/xss-sanitize.git - completed: - subdir: colonnade + commit: f8170266ab25b533576e96715bedffc5aa4f19fa + git: https://gitlab.uniworx.de/haskell/colonnade.git name: colonnade - version: 1.2.0.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git pantry-tree: - size: 481 sha256: 392393652cc0f354d351482557b9385c8e6122e706359b030373656565f2e045 - commit: f8170266ab25b533576e96715bedffc5aa4f19fa - original: + size: 481 subdir: colonnade - git: https://gitlab.ifi.lmu.de/uni2work/haskell/colonnade.git + version: 1.2.0.2 + original: commit: f8170266ab25b533576e96715bedffc5aa4f19fa + git: https://gitlab.uniworx.de/haskell/colonnade.git + subdir: colonnade - completed: + commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 + git: https://gitlab.uniworx.de/haskell/minio-hs.git name: minio-hs - version: 1.5.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git pantry-tree: - size: 4560 sha256: c5faff15fa22a7a63f45cd903c9bd11ae03f422c26f24750f5c44cb4d0db70fc - commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 + size: 4560 + version: 1.5.2 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/minio-hs.git commit: 42103ab247057c04c8ce7a83d9d4c160713a3df1 + git: https://gitlab.uniworx.de/haskell/minio-hs.git - completed: - subdir: cryptoids-class + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git name: cryptoids-class - version: 0.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git pantry-tree: - size: 412 sha256: 30466648d273ffb1d580b7961188d67a0bedb3703d6d5f8cca3c15a45295f203 - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: + size: 412 subdir: cryptoids-class - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: cryptoids-types - name: cryptoids-types - version: 1.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - pantry-tree: - size: 320 - sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: - subdir: cryptoids-types - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: cryptoids - name: cryptoids - version: 0.5.1.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - pantry-tree: - size: 566 - sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: - subdir: cryptoids - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: filepath-crypto - name: filepath-crypto - version: 0.1.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - pantry-tree: - size: 676 - sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9 - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: - subdir: filepath-crypto - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: uuid-crypto - name: uuid-crypto - version: 1.4.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - pantry-tree: - size: 417 - sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4 - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 - original: - subdir: uuid-crypto - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptoids.git - commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 -- completed: - subdir: gearhash - name: gearhash - version: 1.0.0 - git: https://github.com/gkleen/FastCDC.git - pantry-tree: - size: 551 - sha256: 89c58554f6780bff2a2cab86e94d2f562eea34e8025a9925bfdc25b56c925d3e - commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d - original: - subdir: gearhash - git: https://github.com/gkleen/FastCDC.git - commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d -- completed: - subdir: fastcdc - name: fastcdc version: 0.0.0 - git: https://github.com/gkleen/FastCDC.git + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + subdir: cryptoids-class +- completed: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + name: cryptoids-types + pantry-tree: + sha256: 824ac5c55c2ad553bd401bb5a99731bbdccc828ecc5d71f174e9375c4e03c46e + size: 320 + subdir: cryptoids-types + version: 1.0.0 + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + subdir: cryptoids-types +- completed: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + name: cryptoids + pantry-tree: + sha256: b1f49dde76ff7e78b76e7f2f3b3f76c55e5e61555d1df5415ad3b6eb80dda2cb + size: 566 + subdir: cryptoids + version: 0.5.1.0 + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + subdir: cryptoids +- completed: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + name: filepath-crypto + pantry-tree: + sha256: 9c31a2ffb2b1c86f9ba34eb83529c7a5a7dc68a49f89813c9b553427474654d9 + size: 676 + subdir: filepath-crypto + version: 0.1.0.0 + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + subdir: filepath-crypto +- completed: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + name: uuid-crypto + pantry-tree: + sha256: 852e59807df1f2cf4b5a3748c46fa149d15a78651c93addfe5fc31d2d94c47f4 + size: 417 + subdir: uuid-crypto + version: 1.4.0.0 + original: + commit: 130b0dcbf2b09ccdf387b50262f1efbbbf1819e3 + git: https://gitlab.uniworx.de/haskell/cryptoids.git + subdir: uuid-crypto +- completed: + commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d + git: https://github.com/gkleen/FastCDC.git + name: gearhash + pantry-tree: + sha256: 89c58554f6780bff2a2cab86e94d2f562eea34e8025a9925bfdc25b56c925d3e + size: 551 + subdir: gearhash + version: 1.0.0 + original: + commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d + git: https://github.com/gkleen/FastCDC.git + subdir: gearhash +- completed: + commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d + git: https://github.com/gkleen/FastCDC.git + name: fastcdc pantry-tree: - size: 292 sha256: aa588b55c7c9c079e39569489a8089ec312f0538d02cf0e1fffe2f0e058566b8 - commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d - original: + size: 292 subdir: fastcdc - git: https://github.com/gkleen/FastCDC.git + version: 0.0.0 + original: commit: f216e3c0a1efa11a62fd4c9c2db38f7e2b7ac72d + git: https://github.com/gkleen/FastCDC.git + subdir: fastcdc - completed: + commit: 843683d024f767de236f74d24a3348f69181a720 + git: https://gitlab.uniworx.de/haskell/zip-stream.git name: zip-stream - version: 0.2.0.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git pantry-tree: - size: 812 sha256: 0da8bc38d73034962d2e2d1a7586b6dee848a629319fce9cbbf578348c61118c - commit: 843683d024f767de236f74d24a3348f69181a720 + size: 812 + version: 0.2.0.1 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/zip-stream.git commit: 843683d024f767de236f74d24a3348f69181a720 + git: https://gitlab.uniworx.de/haskell/zip-stream.git - completed: - subdir: yesod-core + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-core - version: 1.6.20.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 5954 sha256: 08c8da10b32c8d9f784238fd87232bf90b752e82f81ef2c52c62210f9aadda9a - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 5954 subdir: yesod-core - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.20.2 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-core - completed: - subdir: yesod-static + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-static - version: 1.6.1.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 2949 sha256: 32c1608243a5309005ce11e2aa379ac1d6f8c380c529785eb510770118f3da06 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 2949 subdir: yesod-static - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.1.0 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-static - completed: - subdir: yesod-persistent + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-persistent - version: 1.6.0.7 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 497 sha256: 3778ef2964e1a3890afc22cc9124eacb40e64b62bed4983a85d3b99897f54c5c - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 497 subdir: yesod-persistent - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.0.7 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-persistent - completed: - subdir: yesod-newsfeed + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-newsfeed - version: 1.7.0.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 488 sha256: 53ebad62655863a657dcf749ffd3de46f6af90dd71f55bc4d50805ac48ddb099 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 488 subdir: yesod-newsfeed - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.7.0.0 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-newsfeed - completed: - subdir: yesod-form + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-form - version: 1.7.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 1914 sha256: 260b7f16a8e1d58da137eb91aeed3a11ccbe59ba3e614457a635b9dc3e71426f - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 1914 subdir: yesod-form - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.7.0 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-form - completed: - subdir: yesod-form-multi + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-form-multi - version: 1.7.0.2 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 328 sha256: b21fc50db43733dfe6e285345856610ba4feb83329e9cf953bf8047ba18ecbd6 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 328 subdir: yesod-form-multi - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.7.0.2 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-form-multi - completed: - subdir: yesod-auth + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-auth - version: 1.6.10.3 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 1212 sha256: d335b940a207f8155f421b7146746a72d20db6ad54412154f2c829a59bf21e08 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 1212 subdir: yesod-auth - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.10.3 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-auth - completed: - subdir: yesod-auth-oauth + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-auth-oauth - version: 1.6.0.3 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 321 sha256: 39d2f7d5d1abb3a2953858c5f23880e60ecfcdad0549ddc2570204f9c47649f4 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 321 subdir: yesod-auth-oauth - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.0.3 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-auth-oauth - completed: - subdir: yesod-sitemap + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-sitemap - version: 1.6.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 314 sha256: 971f48af7011ff7816872d067e5de9cadafdd371bdf209170b77df36001abd27 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 314 subdir: yesod-sitemap - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.0 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-sitemap - completed: - subdir: yesod-test + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-test - version: 1.6.12 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 563 sha256: 3d5022e8e3f8e77abcf075c42cf49efaa26f4951159bbb5ab50b69fdfeacb7c1 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 563 subdir: yesod-test - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.12 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-test - completed: - subdir: yesod-bin + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-bin - version: 1.6.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 1295 sha256: 422d7816965b79826c6c24582d76dadbacd1bfb3e9a8f31208867cd788f2a5b8 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 1295 subdir: yesod-bin - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.1 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-bin - completed: - subdir: yesod + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod - version: 1.6.1.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 666 sha256: cb53ef3f2036185d2b4752d6fbc5d78470b4504e646e7eb4dd2397f2599daf42 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 666 subdir: yesod - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.1.1 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod - completed: - subdir: yesod-eventsource + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-eventsource - version: 1.6.0.1 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 324 sha256: 6d393201852cd024e377159ba836398e24d191563e08165430113d3c1384aff2 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 324 subdir: yesod-eventsource - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 1.6.0.1 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-eventsource - completed: - subdir: yesod-websockets + commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git name: yesod-websockets - version: 0.3.0.3 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git pantry-tree: - size: 485 sha256: 02df6117e9b74a77879ea750130ba2d8ad8d3c99e14ca678320cb578984301e5 - commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 - original: + size: 485 subdir: yesod-websockets - git: https://gitlab.ifi.lmu.de/uni2work/haskell/yesod.git + version: 0.3.0.3 + original: commit: aa671eb41fdad360f2f7cb844f8de03479efe3f7 + git: https://gitlab.uniworx.de/haskell/yesod.git + subdir: yesod-websockets - completed: + commit: 342dac80e40b10f07694a7e9aa8bab6d03ed6d66 + git: https://github.com/freckle/yesod-auth-oauth2 + name: yesod-auth-oauth2 + pantry-tree: + sha256: 22e8be5c8128e2f0fb976cb904ac93cefb49e6feef6bcadb7746641be11dcb13 + size: 3054 + version: 0.6.3.4 + original: + commit: 342dac80e40b10f07694a7e9aa8bab6d03ed6d66 + git: https://github.com/freckle/yesod-auth-oauth2 +- completed: + commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f + git: https://gitlab.uniworx.de/haskell/cryptonite.git name: cryptonite - version: '0.29' - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git pantry-tree: - size: 25056 sha256: 19e49259fa5e3c257495d72b3c7c3c49537aeafd508c780c2430ddca2ef71a91 - commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f + size: 25056 + version: '0.29' original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/cryptonite.git commit: 71a630edaf5f22c464e24fac8d9d310f4055ea1f + git: https://gitlab.uniworx.de/haskell/cryptonite.git - completed: + commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37 + git: https://gitlab.uniworx.de/haskell/esqueleto.git name: esqueleto - version: 3.5.4.0 - git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git pantry-tree: - size: 5633 sha256: 8a93dc98eb4529ff64aa5bcdaa3c00dcdf0378033ad675864e2b0fc3d869d947 - commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37 + size: 5633 + version: 3.5.4.0 original: - git: https://gitlab.ifi.lmu.de/uni2work/haskell/esqueleto.git commit: e18dd125c5ea26fa4e88bed079b61d8c1365ee37 + git: https://gitlab.uniworx.de/haskell/esqueleto.git - completed: hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 pantry-tree: - size: 330 sha256: ae84d4cc0e1daf985db6cdcf2ac92319531b8e60f547183cc46480d00aafbe20 + size: 330 original: hackage: classy-prelude-yesod-1.5.0@sha256:8f7e183bdfd6d2ea9674284c4f285294ab086aff60d9be4e5d7d2f3c1a2b05b7,1330 - completed: hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 pantry-tree: - size: 13678 sha256: d57bcb2ad5e01fe7424abbcf9e58cf943027b5c4a8496d93625c57b6e1272274 + size: 13678 original: hackage: acid-state-0.16.0.1@sha256:d43f6ee0b23338758156c500290c4405d769abefeb98e9bc112780dae09ece6f,6207 - completed: hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160 pantry-tree: - size: 269 sha256: 856818862d12df8b030fa9cfef2c4ffa604d06f0eb057498db245dfffcd60e3c + size: 269 original: hackage: normaldistribution-1.1.0.3@sha256:2615b784c4112cbf6ffa0e2b55b76790290a9b9dff18a05d8c89aa374b213477,2160 - completed: hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 pantry-tree: - size: 316 sha256: ab3c2d2880179a945ab3122c51d1657ab4a7a628292b646e047cd32b0751a80c + size: 316 original: hackage: pkcs7-1.0.0.1@sha256:b26e5181868667abbde3ce17f9a61cf705eb695da073cdf82e1f9dfd6cc11176,3594 - completed: hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 pantry-tree: - size: 446 sha256: 3b22af3e6315835bf614a0d30381ec7e47aca147b59ba601aeaa26f1fdc19373 + size: 446 original: hackage: system-locale-0.3.0.0@sha256:13b3982403d8ac8cc6138e68802be8d8e7cf7ebc4cbc7e47e99e3c0dd1be066a,1529 - completed: hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899 pantry-tree: - size: 399 sha256: b0b4a08ea1bf76bd108310f64d7f80e0f30b61ddc3d71f6cab7bdce329d2c1fa + size: 399 original: hackage: token-bucket-0.1.0.1@sha256:d8e85f2fc373939975e7ace7907baee177531ab6e43df94e330a2357e64a2d11,1899 - completed: hackage: tz-0.1.3.5@sha256:fb17ca50a7d943e511c0ca70342dc83f66aa2532de2745632f1f5f9b1ad783c4,5086 pantry-tree: - size: 1179 sha256: 6482698ea1b1a93bd684fca35836b35e8cdf53fe51b0fa6b215afa7da1f983a6 + size: 1179 original: hackage: tz-0.1.3.5@sha256:fb17ca50a7d943e511c0ca70342dc83f66aa2532de2745632f1f5f9b1ad783c4,5086 - completed: hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 pantry-tree: - size: 492 sha256: 4959068a0caf410dd4b8046f0b0138e3cf6471abb0cc865c9993db3b2930d283 + size: 492 original: hackage: unidecode-0.1.0.4@sha256:99581ee1ea334a4596a09ae3642e007808457c66893b587e965b31f15cbf8c4d,1144 - completed: hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 pantry-tree: - size: 442 sha256: 347eac6c8a3c02fc0101444d6526b57b3c27785809149b12f90d8db57c721fea + size: 442 original: hackage: hlint-test-0.1.0.0@sha256:e427c0593433205fc629fb05b74c6b1deb1de72d1571f26142de008f0d5ee7a9,1814 - completed: hackage: servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755 pantry-tree: - size: 976 sha256: 37dab60111c71d011fc4964e9a8b4b05ac544bc0ba8155e895518680066c2adb + size: 976 original: hackage: servant-quickcheck-0.0.10.0@sha256:1d5849d703c2487752f8fc7391cca7c998ee24f54ca0bb72d238bf99b64ac667,3755 - completed: hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 pantry-tree: - size: 325 sha256: 04f12c7bef2c3f9a25d94eb9489752ed498db8e243069fe95838dbb51df1dcb3 + size: 325 original: hackage: servant-flatten-0.2@sha256:276896f7c5cdec5b8f8493f6205fded0cc602d050b58fdb09a6d7c85c3bb0837,1234 - completed: hackage: network-arbitrary-0.7.0.0@sha256:0cd381c80ae20c16048936edcdb018b1d9fbe2b6ac8c44e908df403a5c6d7cd5,2520 pantry-tree: - size: 912 sha256: a40b62eddfb12cfec753a10836a4ef5fe8ec94d7478e6957e1fe5729017928fb + size: 912 original: hackage: network-arbitrary-0.7.0.0@sha256:0cd381c80ae20c16048936edcdb018b1d9fbe2b6ac8c44e908df403a5c6d7cd5,2520 - completed: hackage: saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198 pantry-tree: - size: 5016 sha256: fdf4397f4b1ed7975f38d0b463eb6c9d206d0c85d157c41c19983e80b2005763 + size: 5016 original: hackage: saltine-0.2.0.0@sha256:2232a285ef326b0942bbcbfa6f465933a020f27e19552213e688fe371d66dddd,5198 - completed: hackage: persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601 pantry-tree: - size: 1059 sha256: 2d647a17372e42bc54331cfb35f5a55a71e6854dac8299b7ed6a1c69ae12734d + size: 1059 original: hackage: persistent-postgresql-2.13.0.3@sha256:43384bf8ed9c931c673e6abb763c8811113d1b7004095faaae1eb42e2cd52d8f,3601 snapshots: - completed: + sha256: c632012da648385b9fa3c29f4e0afd56ead299f1c5528ee789058be410e883c0 size: 585393 url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/0.yaml - sha256: c632012da648385b9fa3c29f4e0afd56ead299f1c5528ee789058be410e883c0 original: lts-18.0 diff --git a/templates/admin/external-user.hamlet b/templates/admin/external-user.hamlet new file mode 100644 index 000000000..44f4b5af2 --- /dev/null +++ b/templates/admin/external-user.hamlet @@ -0,0 +1,46 @@ +$newline never + +$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Steffen Jost +$# +$# SPDX-License-Identifier: AGPL-3.0-or-later + +
+

+ Query external user databases: + ^{personForm} + $maybe responses <- mbData +

+ Responses: # +
+ $forall (source,responses) <- responses +
+ $case source + $of AuthSourceIdAzure tenantId + Azure Tenant ID: # + #{tshow tenantId} + $of AuthSourceIdLdap ldapHost + LDAP host: # + #{ldapHost} +
+ 
+            #{responses}
+$#          

+$#            $forall (k,(numv,vUtf8,vLatin1)) <- responses
+$#              

+$#                #{k}
+$#                $if 1 < numv
+$#                  \ (#{show numv})
+$#              

+$#                UTF8:  #{vUtf8}
+$#                —
+$#                Latin: #{vLatin1}
+
+

+  

+    Upsert user from external database:
+    ^{upsertForm}
+  $maybe response <- mbUpsert
+    

+      Response: #
+    

+      #{tshow response}
diff --git a/templates/ldap.hamlet b/templates/ldap.hamlet
deleted file mode 100644
index a2b2a1533..000000000
--- a/templates/ldap.hamlet
+++ /dev/null
@@ -1,33 +0,0 @@
-$newline never
-
-$# SPDX-FileCopyrightText: 2022 Steffen Jost 
-$#
-$# SPDX-License-Identifier: AGPL-3.0-or-later
-
-

-  
 
-    LDAP Person Search:
-    ^{personForm}
-  $maybe answers <- mbLdapData
-    

-      Antwort: #
-    

-      $forall (lk, lv) <- answers
-        $with numv <- length lv
-          

-            #{show lk}
-            $if 1 < numv
-              \ (#{show numv})
-          

-            UTF8:  #{presentUtf8 lv}
-            —
-            Latin: #{presentLatin1 lv}
-

-  

-    LDAP Upsert user in DB:
-    ^{upsertForm}
-  $maybe answer <- mbLdapUpsert
-    

-      Antwort: #
-    

-      #{tshow answer}
diff --git a/templates/login.hamlet b/templates/login.hamlet
index 19539af3f..8b3cb046b 100644
--- a/templates/login.hamlet
+++ b/templates/login.hamlet
@@ -1,20 +1,33 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Gregor Kleen 
+$# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen , David Mosbach 
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
 $forall AuthPlugin{apName, apLogin} <- plugins
-  $if apName == "LDAP"
+  $if apName == apAzure
+    

+      
Azure
+      ^{apLogin toParent}
+  $elseif apName == apAzureMock
+    

+      
_{MsgDummyLoginTitle}
+      ^{apLogin toParent}
+  $elseif apName == apLdap
     

       
_{MsgLDAPLoginTitle}
       ^{apLogin toParent}
-  $elseif apName == "PWHash"
+  $elseif apName == apHash
     

       
_{MsgPWHashLoginTitle}
       
_{MsgPWHashLoginNote}
       ^{apLogin toParent}
-  $elseif apName == "dummy"
+  $elseif apName == apDummy
     

       
_{MsgDummyLoginTitle}
       ^{apLogin toParent}
+$maybe port <- mPort
+  

+    
SSO Dev Test
+    Test login via single sign-on
+  
diff --git a/templates/mail/userAuthModeUpdate.hamlet b/templates/mail/userAuthModeUpdate.hamlet
index 95494335e..fb45ed4db 100644
--- a/templates/mail/userAuthModeUpdate.hamlet
+++ b/templates/mail/userAuthModeUpdate.hamlet
@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Steffen Jost 
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen , Steffen Jost 
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -19,21 +19,16 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
       }
   
     

-      $case userAuthentication
-        $of AuthLDAP
-          _{SomeMessage MsgUserAuthModeChangedToLDAP}
-        $of AuthPWHash _
-          _{SomeMessage MsgUserAuthModeChangedToPWHash}
-        $of AuthNoLogin
-          _{SomeMessage MsgUserAuthModeChangedToNoLogin}
+      $if is _Just userPasswordHash
+        _{SomeMessage MsgUserAuthPasswordEnabled}
+      $else
+        _{SomeMessage MsgUserAuthPasswordDisabled}
     

       
         _{SomeMessage MsgMailFradrive} #
       _{SomeMessage MsgMailBodyFradrive}
 
-    $if is _AuthPWHash userAuthentication
-      

-        _{SomeMessage MsgAuthPWHashTip}
+    $if is _Just userPasswordHash
       

         

           _{SomeMessage MsgPWHashIdent}
@@ -42,6 +37,9 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         
_{SomeMessage MsgPWHashPassword}
         

           _{SomeMessage MsgPasswordResetEmailIncoming}
+    $else
+      

+        _{SomeMessage MsgAuthExternalLoginTip}
 
     $if is _Just userLastAuthentication
       ^{editNotifications}
diff --git a/templates/profileData.hamlet b/templates/profileData.hamlet
index 9eb2817af..1501f3c53 100644
--- a/templates/profileData.hamlet
+++ b/templates/profileData.hamlet
@@ -1,6 +1,6 @@
 $newline never
 
-$# SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
+$# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Winnie Ros 
 $#
 $# SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -10,10 +10,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
         _{MsgIdent}
       

         #{userIdent}
-      

-        _{MsgAuthModeSet}        
-      
        
-        _{userAuthentication}
       $maybe avs <- avsId
         

           _{MsgAvsPersonNo}
@@ -124,6 +120,25 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
           _{MsgUserCreated}
         

           ^{formatTimeW SelFormatDateTime userCreated}
+        

+          _{MsgAdminUserAuthentication}
+        

+          $if null externalUsers && is _Nothing userPasswordHash
+            _{MsgAuthKindNoLogin}
+          $else
+            
    
+              $if is _Just userPasswordHash
+                
  • _{MsgAuthKindPWHash}
+              $forall (authIdent, sourceIdent, lsync) <- externalUsers
+                
  • 
+                  $case sourceIdent
+                    $of AuthSourceIdAzure _clientId
+                      _{MsgAuthKindAzure}: #
+                    $of AuthSourceIdLdap _sourceId
+                      _{MsgAuthKindLDAP}: #
+                  #{authIdent} #
+                  
+                    (_{MsgAdminUserAuthLastSync}: ^{formatTimeW SelFormatDateTime lsync})
         
    
           _{MsgLastLogin}
         
    
@@ -131,18 +146,6 @@ $# SPDX-License-Identifier: AGPL-3.0-or-later
             ^{formatTimeW SelFormatDateTime llogin}
           $nothing
             _{MsgNeverSet}
-        
    
-          _{MsgProfileLastLdapSynchronisation}
-        
    
-          $maybe lsync <- userLastLdapSynchronisation
-            ^{formatTimeW SelFormatDateTime lsync}
-          $nothing
-            _{MsgNeverSet}
-        $maybe pKey <- userLdapPrimaryKey
-          
    
-            _{MsgProfileLdapPrimaryKey}
-          
    
-            #{pKey}
         
    
           _{MsgTokensLastReset}
         
    
diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs
index af8961dba..531946836 100644
--- a/test/Database/Fill.hs
+++ b/test/Database/Fill.hs
@@ -82,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"
@@ -103,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
@@ -122,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"
@@ -143,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
@@ -164,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
-    , userAuthentication = pwSimple
+    , userPasswordHash = Just pwSimple
     , userLastAuthentication = Nothing
+    , userLastSync = Nothing
     , userTokensIssuedAfter = Nothing
     , userMatrikelnummer = Just "12345678"
     , userEmail  = "S.Jost@Fraport.de"
@@ -189,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
@@ -208,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"
@@ -229,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)
@@ -248,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"
@@ -269,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
@@ -288,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"
@@ -309,8 +304,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexFemale
     , userBirthday = Nothing
@@ -328,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"
@@ -349,8 +343,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -368,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"
@@ -389,8 +382,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -408,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"
@@ -429,8 +421,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -448,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"
@@ -469,8 +460,6 @@ fillDb = do
     , userLanguages = Nothing
     , userNotificationSettings = def
     , userCreated = now
-    , userLastLdapSynchronisation = Nothing
-    , userLdapPrimaryKey = Nothing
     , userCsvOptions = def
     , userSex = Just SexMale
     , userBirthday = Nothing
@@ -526,8 +515,9 @@ fillDb = do
     middlenames = [ Nothing, Just "Jamesson", Just "Theresa", Just "Ally", Just "Tiberius", Just "Maria" ]
     manyUser (firstName, middleName, userSurname) userMatrikelnummer' = User
       { userIdent
-      , userAuthentication = AuthLDAP
+      , userPasswordHash = Nothing
       , userLastAuthentication = Nothing
+      , userLastSync = Nothing
       , userTokensIssuedAfter = Nothing
       , userMatrikelnummer = Just userMatrikelnummer'
       , userEmail        = userEmail'
@@ -549,8 +539,6 @@ fillDb = do
       , userLanguages = Nothing
       , userNotificationSettings = def
       , userCreated = now
-      , userLastLdapSynchronisation = Nothing
-      , userLdapPrimaryKey = Nothing
       , userCsvOptions = def
       , userSex = Nothing
       , userBirthday = Nothing
diff --git a/test/Database/test-users.yaml b/test/Database/test-users.yaml
new file mode 100644
index 000000000..17ea6d1ba
--- /dev/null
+++ b/test/Database/test-users.yaml
@@ -0,0 +1,231 @@
+# SPDX-FileCopyrightText: 2024 David Mosbach 
+#
+# SPDX-License-Identifier: AGPL-3.0-or-later
+
+special-users:
+
+  - default: &default-user
+      userIdent: null
+      userAuthentication: AuthLDAP
+      userLastAuthentication: null
+      userTokensIssuedAfter: null
+      userMatrikelnummer: null
+      userEmail: ""
+      userDisplayEmail: null
+      userDisplayName: null
+      userSurname: ""
+      userFirstName: ""
+      userTitle: null
+      userMaxFavourites: userDefaultMaxFavourites
+      userMaxFavouriteTerms: userDefaultMaxFavouriteTerms
+      userTheme: ThemeDefault
+      userDateTimeFormat: userDefaultDateTimeFormat
+      userDateFormat: userDefaultDateFormat
+      userTimeFormat: userDefaultTimeFormat
+      userDownloadFiles: userDefaultDownloadFiles
+      userWarningDays: userDefaultWarningDays
+      userLanguages: null
+      userCreated: now
+      userNotificationSettings: def
+      userLastLdapSynchronisation: null
+      userLdapPrimaryKey: null
+      userCsvOptions: def
+      userSex: null
+      userBirthday: null
+      userShowSex: userDefaultShowSex
+      userTelephone: null
+      userMobile: null
+      userCompanyPersonalNumber: null
+      userCompanyDepartment: null
+      userPinPassword: null
+      userPostAddress: null
+      userPostLastUpdate: null
+      userPrefersPostal: true
+      userExamOfficeGetSynced: userDefaultExamOfficeGetSynced
+      userExamOfficeGetLabels: userDefaultExamOfficeGetLabels
+
+  - gkleen:
+      <<: *default-user
+      userIdent: "G.Kleen@campus.lmu.de"
+      userLastAuthentication: now
+      userTokensIssuedAfter: now
+      userEmail: "G.Kleen@campus.lmu.de"
+      userDisplayEmail: "gregor.kleen@ifi.lmu.de"
+      userDisplayName: "Gregor Kleen"
+      userSurname: "Kleen"
+      userFirstName: "Gregor Julius Arthur"
+      userMaxFavourites: 6
+      userMaxFavouriteTerms: 1
+      userLanguages: ["en"]
+      # userCsvOptions = def { csvFormat = csvPreset # CsvPresetRFC }
+      userSex: SexMale
+      userCompanyPersonalNumber: "00000"
+      userPostAddress: "Büro 127   \nMathematisches Institut der Ludwig-Maximilians-Universität München   \nTheresienstr. 39   \nD-80333 München"
+
+  - fhamann:
+      <<: *default-user
+      userIdent: "felix.hamann@campus.lmu.de"
+      userEmail: "noEmailKnown"
+      userDisplayEmail: "felix.hamann@campus.lmu.de"
+      userDisplayName: "Felix Hamann"
+      userSurname: "Hamann"
+      userFirstName: "Felix"
+      # userCsvOptions = def { csvFormat = csvPreset # CsvPresetExcel }
+      userSex: SexMale
+      userPinPassword: "tomatenmarmelade"
+      userPostAddress: "Erdbeerweg 24  \n12345 Schlumpfhausen  \nTraumland"
+
+  - jost:
+      <<: *default-user
+      userIdent: "jost@tcs.ifi.lmu.de"
+      userAuthentication: pwSimple
+      userMatrikelnummer: "12345678"
+      userEmail: "S.Jost@Fraport.de"
+      userDisplayEmail: "jost@tcs.ifi.lmu.de"
+      userDisplayName: "Steffen Jost"
+      userSurname: "Jost"
+      userFirstName: "Steffen"
+      userTitle: "Dr."
+      userMaxFavourites: 14
+      userMaxFavouriteTerms: 4
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      # userBirthday = Just $ n_day $ 35 * (-365)
+      userTelephone: "+49 69 690-71706"
+      userMobile: "0173 69 99 646"
+      userCompanyPersonalNumber: "57138"
+      userCompanyDepartment: "AVN-AR2"
+
+  - maxMuster:
+      <<: *default-user
+      userIdent: "max@campus.lmu.de"
+      userLastAuthentication: now
+      userMatrikelnummer: "1299"
+      userEmail: "max@campus.lmu.de"
+      userDisplayEmail: "max@max.com"
+      userDisplayName: "Max Musterstudent"
+      userSurname: "Musterstudent"
+      userFirstName: "Max"
+      userMaxFavourites: 7
+      userTheme: ThemeAberdeenReds
+      userLanguages: ["de"]
+      userSex: SexMale
+      # userBirthday = Just $ n_day $ 27 * (-365)
+      userPrefersPostal: false
+
+  - tinaTester:
+      <<: *default-user
+      userIdent: "tester@campus.lmu.de"
+      userAuthentication: null
+      userMatrikelnummer: "999"
+      userEmail: "tester@campus.lmu.de"
+      userDisplayEmail: "tina@tester.example"
+      userDisplayName: "Tina Tester"
+      userSurname: "vön Tërrör¿"
+      userFirstName: "Sabrina"
+      userTitle: "Magister"
+      userMaxFavourites: 5
+      userTheme: ThemeAberdeenReds
+      userLanguages: ["sn"]
+      userSex: SexNotApplicable
+      # userBirthday = Just $ n_day 3
+      userCompanyPersonalNumber: "12345"
+      userPrefersPostal: false
+
+  - svaupel:
+      <<: *default-user
+      userIdent: "vaupel.sarah@campus.lmu.de"
+      userEmail: "vaupel.sarah@campus.lmu.de"
+      userDisplayEmail: "vaupel.sarah@campus.lmu.de"
+      userDisplayName: "Sarah Vaupel"
+      userSurname: "Vaupel"
+      userFirstName: "Sarah"
+      userMaxFavourites: 14
+      userMaxFavouriteTerms: 4
+      userTheme: ThemeMossGreen
+      userLanguages: null
+      userSex: SexFemale
+      userPrefersPostal: false
+
+  - sbarth:
+      <<: *default-user
+      userIdent: "Stephan.Barth@campus.lmu.de"
+      userEmail: "Stephan.Barth@lmu.de"
+      userDisplayEmail: "stephan.barth@ifi.lmu.de"
+      userDisplayName: "Stephan Barth"
+      userSurname: "Barth"
+      userFirstName: "Stephan"
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      userPrefersPostal: false
+      userExamOfficeGetSynced: false
+      userExamOfficeGetLabels: true
+
+  - _stranger1:
+      userIdent: "AVSID:996699"
+      userEmail: "E996699@fraport.de"
+      userDisplayEmail: ""
+      userDisplayName: "Stranger One"
+      userSurname: "One"
+      userFirstName: "Stranger"
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      userCompanyPersonalNumber: "E996699"
+      userCompanyDepartment: "AVN-Strange"
+      userPrefersPostal: false
+      userExamOfficeGetSynced: false
+      userExamOfficeGetLabels: true
+
+  - _stranger2:
+      userIdent: "AVSID:669966"
+      userEmail: "E669966@fraport.de"
+      userDisplayEmail: ""
+      userDisplayName: "Stranger Two"
+      userSurname: "Stranger"
+      userFirstName: "Two"
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      userCompanyPersonalNumber: "669966"
+      userCompanyDepartment: "AVN-Strange"
+      userPrefersPostal: false
+      userExamOfficeGetSynced: false
+      userExamOfficeGetLabels: true
+
+  - _stranger3:
+      userIdent: "AVSID:6969"
+      userEmail: "E6969@fraport.de"
+      userDisplayEmail: ""
+      userDisplayName: "Stranger 3 Three"
+      userSurname: "Three"
+      userFirstName: "Stranger"
+      userTheme: ThemeMossGreen
+      userSex: SexMale
+      userCompanyPersonalNumber: "E996699"
+      userCompanyDepartment: "AVN-Strange"
+      userPostAddress: "Kartoffelweg 12  \n666 Höllensumpf  \nFreiland"
+      userPrefersPostal: false
+      userExamOfficeGetSynced: false
+      userExamOfficeGetLabels: true
+
+
+random-users:
+  firstNames: [ "James", "John", "Robert", "Michael"
+              , "William", "David", "Mary", "Richard"
+              , "Joseph", "Thomas", "Charles", "Daniel"
+              , "Matthew", "Patricia", "Jennifer", "Linda"
+              , "Elizabeth", "Barbara", "Anthony", "Donald"
+              , "Mark", "Paul", "Steven", "Andrew"
+              , "Kenneth", "Joshua", "George", "Kevin"
+              , "Brian", "Edward", "Susan", "Ronald"
+              ]
+  surnames: [ "Smith", "Johnson", "Williams", "Brown"
+            , "Jones", "Miller", "Davis", "Garcia"
+            , "Rodriguez", "Wilson", "Martinez", "Anderson"
+            , "Taylor", "Thomas", "Hernandez", "Moore"
+            , "Martin", "Jackson", "Thompson", "White"
+            , "Lopez", "Lee", "Gonzalez", "Harris"
+            , "Clark", "Lewis", "Robinson", "Walker"
+            , "Perez", "Hall", "Young", "Allen"
+            ]
+  middlenames: [ null, "Jamesson" ]
+
diff --git a/test/Handler/Utils/SubmissionSpec.hs b/test/Handler/Utils/SubmissionSpec.hs
index ed50724ba..4a16c559d 100644
--- a/test/Handler/Utils/SubmissionSpec.hs
+++ b/test/Handler/Utils/SubmissionSpec.hs
@@ -51,7 +51,6 @@ makeUsers (fromIntegral -> n) = do
     let baseid = "user." <> tshow i
         u' = u { userIdent          = CI.mk   baseid 
                , userEmail          = CI.mk $ baseid <> "@example.com"
-               , userLdapPrimaryKey = Just  $ baseid <> ".ldap"
                }
     return u'
   uids <- insertMany users
diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs
index fe9eb7325..b8b0eca50 100644
--- a/test/Model/TypesSpec.hs
+++ b/test/Model/TypesSpec.hs
@@ -10,7 +10,6 @@ module Model.TypesSpec
 
 import TestImport
 import TestInstances ()
-import Settings
 
 import Utils (guardOn)
 
@@ -21,7 +20,6 @@ import qualified Data.Aeson.Types as Aeson
 import Model.Types.LanguagesSpec ()
 
 import System.IO.Unsafe
-import Yesod.Auth.Util.PasswordStore
 
 import Database.Persist.Sql (SqlBackend, fromSqlKey, toSqlKey)
 
@@ -217,21 +215,6 @@ instance Arbitrary Value where
       arbitrary' = scale (`div` 2) arbitrary
   shrink = genericShrink
 
-instance Arbitrary AuthenticationMode where
-  arbitrary = oneof
-    [ pure AuthLDAP
-    , do
-        pw <- encodeUtf8 . pack . getPrintableString <$> arbitrary
-        let
-          PWHashConf{..} = appAuthPWHash compileTimeAppSettings
-          authPWHash = unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2)
-        return $ AuthPWHash{..}
-    ]
-
-  shrink AuthLDAP = []
-  shrink AuthNoLogin = []
-  shrink (AuthPWHash _) = [AuthLDAP]
-
 instance Arbitrary LecturerType where
   arbitrary = genericArbitrary
   shrink = genericShrink
@@ -462,8 +445,6 @@ spec = do
       [ eqLaws, ordLaws, boundedEnumLaws, showReadLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @CorrectorState)
       [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, jsonLaws, finiteLaws, pathPieceLaws, persistFieldLaws ]
-    lawsCheckHspec (Proxy @AuthenticationMode)
-      [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ]
     lawsCheckHspec (Proxy @Value)
       [ persistFieldLaws ]
     lawsCheckHspec (Proxy @Scientific)
diff --git a/test/ModelSpec.hs b/test/ModelSpec.hs
index 729f1a769..7fb5c4bc9 100644
--- a/test/ModelSpec.hs
+++ b/test/ModelSpec.hs
@@ -1,4 +1,4 @@
--- SPDX-FileCopyrightText: 2022 Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost 
+-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel , Gregor Kleen ,Sarah Vaupel ,Steffen Jost ,Steffen Jost 
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
@@ -9,7 +9,7 @@ module ModelSpec where
 
 import TestImport
 
-import Settings (getTimeLocale', VerpMode(..))
+import Settings
 
 import Model.TypesSpec ()
 import MailSpec ()
@@ -34,9 +34,10 @@ import qualified Data.CryptoID.Class.ImplicitNamespace as Implicit
 import qualified Data.CryptoID.Class as Explicit
 import Data.Binary.SerializationLength
 
-import Control.Monad.Catch.Pure (Catch, runCatch)
+import System.IO.Unsafe
+import Yesod.Auth.Util.PasswordStore
 
-import System.IO.Unsafe (unsafePerformIO)
+import Control.Monad.Catch.Pure (Catch, runCatch)
 
 import Data.Universe
 
@@ -102,7 +103,12 @@ instance Arbitrary User where
       [ getPrintableString <$> arbitrary
       , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
       ]
-    userAuthentication <- arbitrary
+    userPasswordHash <-
+      let genPwd = do
+            pw <- encodeUtf8 . pack . getPrintableString <$> arbitrary
+            let PWHashConf{..} = appAuthPWHash compileTimeAppSettings
+            return . unsafePerformIO . fmap decodeUtf8 $ makePasswordWith pwHashAlgorithm pw (pwHashStrength `div` 2)
+       in oneof [ pure Nothing, Just <$> genPwd ]
     userLastAuthentication <- arbitrary
     userTokensIssuedAfter <- arbitrary
     userMatrikelnummer <- fmap pack . assertM' (not . null) <$> listOf (elements ['0'..'9'])
@@ -146,14 +152,7 @@ instance Arbitrary User where
     userExamOfficeGetLabels <- arbitrary
 
     userCreated <- arbitrary
-    userLastLdapSynchronisation <- arbitrary
-    userLdapPrimaryKey <- oneof
-      [ pure Nothing
-      , fmap Just $ pack <$> oneof
-        [ getPrintableString <$> arbitrary
-        , on (\l d -> l <> "@" <> d) getPrintableString <$> arbitrary <*> arbitrary
-        ]
-      ]
+    userLastSync <- arbitrary
 
     return User{..}
   shrink = genericShrink
diff --git a/test/User.hs b/test/User.hs
index 239488fff..c3fba1640 100644
--- a/test/User.hs
+++ b/test/User.hs
@@ -21,8 +21,9 @@ fakeUser adjUser = adjUser User{..}
     UserDefaultConf{..} = appUserDefaults compileTimeAppSettings
     
     userMatrikelnummer = Nothing
-    userAuthentication = AuthLDAP
+    userPasswordHash = Nothing
     userLastAuthentication = Nothing
+    userLastSync = Nothing
     userTokensIssuedAfter = Nothing
     userIdent = "dummy@example.invalid"
     userEmail = "dummy@example.invalid"
@@ -48,8 +49,6 @@ fakeUser adjUser = adjUser User{..}
     userShowSex = userDefaultShowSex
     userNotificationSettings = def
     userCreated = unsafePerformIO getCurrentTime
-    userLastLdapSynchronisation = Nothing
-    userLdapPrimaryKey = Nothing
     userMobile = Nothing 
     userTelephone = Nothing     
     userCompanyPersonalNumber = Nothing