fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'oauth2' into 'test'

Browse Source 
Implement OAuth2 (AzureADv2) support

See merge request fradrive/fradrive!29
This commit is contained in:
Sarah Vaupel 2024-03-21 16:00:37 +00:00
commit aa6406f949
87 changed files with 2896 additions and 1749 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

64
.ports/assign.hs Normal file
View File

@ -0,0 +1,64 @@
-- SPDX-FileCopyrightText: 2024 David Mosbach <david.mosbach@uniworx.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# Language OverloadedStrings, LambdaCase, TypeApplications #-}
import Data.Text (Text)
import qualified Data.Text as T
import System.Directory
import System.Environment
import System.IO
main :: IO ()
main = getArgs >>= \case
["--assign", offsetFile] -> parseOffsets offsetFile >>= uncurry nextOffset
["--remove", offset] -> removeOffset offset
_ -> fail "unsupported args"
parseOffsets :: FilePath -> IO (Int,Int)
parseOffsets offsetFile = do
user <- T.pack <$> getEnv "USER"
let pred x = "//" `T.isPrefixOf` x || T.null (T.strip x)
tokenise = map (filter (not . pred) . T.lines) . T.split (=='#')
extract = map tail . filter (\u -> not (null u) && user == (T.strip $ head u))
((extract . tokenise . T.pack) <$> readFile offsetFile) >>= \case
[[min,max]] -> return (read $ T.unpack min, read $ T.unpack max)
x -> print x >> fail "malformed offset file"
nextOffset :: Int -> Int -> IO ()
nextOffset min max
| min > max = nextOffset max min
| otherwise = do
home <- getEnv "HOME"
offset <- findFile [home] ".port-offsets" >>= \case
Nothing -> writeFile (home ++ "/.port-offsets") (show min) >> return min
Just path -> do
used <- (map (read @Int) . filter (not . null) . lines) <$> readFile path
o <- next min max used
appendFile path ('\n' : show o)
return o
print offset
where
next :: Int -> Int -> [Int] -> IO Int
next min max used
| min > max = fail "all offsets currently in use"
| min `elem` used = next (min+1) max used
| otherwise = return min
removeOffset :: String -> IO ()
removeOffset offset = do
home <- getEnv "HOME"
findFile [home] ".port-offsets" >>= \case
Nothing -> fail "offset file does not exist"
Just path -> do
remaining <- (filter (/= offset) . lines) <$> readFile path
run <- getEnv "XDG_RUNTIME_DIR"
(tempPath, fh) <- openTempFile run ".port-offsets"
let out = unlines remaining
hPutStr fh $ out
case T.null (T.strip $ T.pack out) of
True -> removeFile path
False -> writeFile path $ out
removeFile tempPath

24
.ports/offsets Normal file
View File

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

76
config/settings.yml
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -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"

6
messages/uniworx/categories/admin/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -128,6 +128,8 @@ InterfaceName: Schnittstelle
InterfaceLastSynch: Zuletzt
InterfaceSubtype: Betreffend
InterfaceWrite: Schreibend
AdminUserPassword: Passwort
InterfaceSuccess: Rückmeldung
InterfaceInfo: Nachricht
InterfaceFreshness: Prüfungszeitraum (h)
InterfaceFreshness: Prüfungszeitraum (h)

6
messages/uniworx/categories/admin/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -128,6 +128,8 @@ InterfaceName: Interface
InterfaceLastSynch: Last
InterfaceSubtype: Affecting
InterfaceWrite: Write
AdminUserPassword: Password
InterfaceSuccess: Returned
InterfaceInfo: Message
InterfaceFreshness: Check hours
InterfaceFreshness: Check hours

27
messages/uniworx/categories/authorization/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 David Mosbach <david.mosbach@uniworx.de>, Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -72,8 +72,8 @@ UnauthorizedTutorialTutorControl: Ausbilder:innen dürfen diesen Kurs nicht edit
UnauthorizedCourseTutor: Sie sind nicht Ausbilder:in für diese Kursart.
UnauthorizedTutor: Sie sind nicht Ausbilder:in.
UnauthorizedTutorialRegisterGroup: Sie sind bereits in einem Kurs mit derselben Registrierungs-Gruppe eingetragen.
UnauthorizedLDAP: Angegebener Nutzer/Angegebene Nutzerin meldet sich nicht mit Fraport Login an.
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

27
messages/uniworx/categories/authorization/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -72,8 +72,8 @@ UnauthorizedTutorialTutorControl: Instructors may not edit this course.
UnauthorizedCourseTutor: You are no instructor for this course.
UnauthorizedTutor: You are no instructor.
UnauthorizedTutorialRegisterGroup: You are already registered for a course with the same registration group.
UnauthorizedLDAP: Specified user does not log in with their Fraport password.
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

11
messages/uniworx/categories/send/send_notifications/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -75,11 +75,10 @@ NotPassed: Nicht bestanden
#userAuthModeUpdate.hs + templates
MailSubjectUserAuthModeUpdate: Ihr FRADrive-Login
UserAuthModeChangedToLDAP: Sie können sich nun mit Ihrer Fraport AG Kennung (Büko) in FRADrive einloggen.
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.

9
messages/uniworx/categories/send/send_notifications/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -75,10 +75,9 @@ NotPassed: Failed
#userAuthModeUpdate.hs + templates
MailSubjectUserAuthModeUpdate: Your FRADrive login
UserAuthModeChangedToLDAP: You can now log in to FRADrive using your Fraport AG account (Büko)
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.

6
messages/uniworx/categories/settings/auth_settings/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -45,8 +45,8 @@ AuthTagUserSubmissions: Abgaben erfolgen durch Kursartteilnehmer:innen
AuthTagCorrectorSubmissions: Abgaben erfolgen durch Korrektor:innen
AuthTagCorrectionAnonymous: Korrektur ist anonymisiert
AuthTagSelf: Nutzer:in greift nur auf eigene Daten zu
AuthTagIsLDAP: Nutzer:in meldet sich mit Fraport AG Kennung an
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

6
messages/uniworx/categories/settings/auth_settings/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -45,8 +45,8 @@ AuthTagUserSubmissions: Submissions are made by course type participants
AuthTagCorrectorSubmissions: Submissions are registered by correctors
AuthTagCorrectionAnonymous: Correction is anonymised
AuthTagSelf: User is only accessing their only data
AuthTagIsLDAP: User logs in using their Fraport AG account
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

17
messages/uniworx/categories/user/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -38,8 +38,8 @@ AuthPWHashConfigured: Nutzer:in meldet sich nun mit FRADrive spezifischer Kennun
UsersCourseSchool: Bereich
ActionNoUsersSelected: Keine Benutzer:innen ausgewählt
SynchroniseAvsUserQueued n@Int: AVS-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
SynchroniseLdapUserQueued n@Int: LDAP-Synchronisation von #{n} #{pluralDE n "Benutzer:in" "Benutzer:innen"} angestoßen
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

19
messages/uniworx/categories/user/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -38,8 +38,8 @@ AuthPWHashConfigured: User now logs in using their FRADrive specific account
UsersCourseSchool: Department
ActionNoUsersSelected: No users selected
SynchroniseAvsUserQueued n: Triggered AVS synchronisation of #{n} #{pluralEN n "user" "users"}.
SynchroniseLdapUserQueued n: Triggered LDAP synchronisation of #{n} #{pluralEN n "user" "users"}.
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"}.
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

5
messages/uniworx/utils/navigation/menu/de-de-formal.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -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

5
messages/uniworx/utils/navigation/menu/en-eu.msg
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -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

6
messages/uniworx/utils/utils/de-de-formal.msg
View File

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

6
messages/uniworx/utils/utils/en-eu.msg
View File

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

27
models/users.model
View File

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

1
package.yaml
View File

@ -6,6 +6,7 @@ dependencies:
- yesod-core
- yesod-persistent
- yesod-auth
- yesod-auth-oauth2
- yesod-static
- yesod-form
- yesod-persistent

37
routes
View File

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

38
shell.nix
View File

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

81
src/Application.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -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{..}

242
src/Auth/LDAP.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -7,11 +7,11 @@
module Auth.LDAP
( apLdap
, ADError(..), ADInvalidCredentials(..)
, campusLogin
, 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]

246
src/Auth/OAuth2.hs Normal file
View File

@ -0,0 +1,246 @@
-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Auth.OAuth2
( 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

11
src/Auth/PWHash.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Felix Hamann <felix.hamann@campus.lmu.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -68,12 +68,13 @@ hashLogin pwHashAlgo = AuthPlugin{..}
tp <- getRouteToParent
resp <- formResultMaybe loginRes $ \HashLogin{..} -> Just <$> do
user <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
user :: Maybe (Entity User) <- liftHandler . runDB . getBy $ UniqueAuthentication hashIdent
case user of
Just (Entity _ User{ userAuthentication = AuthPWHash{..}, userIdent = CI.original -> userIdent })
| 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

24
src/Foundation/Authorization.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -1521,7 +1521,7 @@ tagAccessPredicate AuthSelf = APDB $ \_ _ mAuthId route _ -> exceptT return retu
| uid == referencedUser -> return Authorized
Nothing -> return AuthenticationRequired
_other -> unauthorizedI MsgUnauthorizedSelf
tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $ do
tagAccessPredicate AuthIsExternal = APDB $ \_ _ _ route _ -> exceptT return return $ do
referencedUser <- case route of
AdminUserR cID -> return cID
AdminUserDeleteR cID -> return cID
@ -1529,13 +1529,17 @@ tagAccessPredicate AuthIsLDAP = APDB $ \_ _ _ route _ -> exceptT return return $
UserNotificationR cID -> return cID
UserPasswordR cID -> return cID
CourseR _ _ _ (CUserR cID) -> return cID
_other -> throwError =<< $unsupportedAuthPredicate AuthIsLDAP route
_other -> throwError =<< $unsupportedAuthPredicate AuthIsExternal route
referencedUser' <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSelf) (const True :: CryptoIDError -> Bool) $ decrypt referencedUser
maybeTMExceptT (unauthorizedI MsgUnauthorizedLDAP) $ do
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

2
src/Foundation/I18n.hs
View File

@ -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

34
src/Foundation/Instances.hs
View File

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

77
src/Foundation/Navigation.hs
View File

@ -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

2
src/Foundation/Routes.hs
View File

@ -9,7 +9,7 @@ module Foundation.Routes
( module Foundation.Routes.Definitions
, module Foundation.Routes
) where
import Import.NoFoundation
import Foundation.Type

4
src/Foundation/SiteLayout.hs
View File

@ -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

3
src/Foundation/Type.hs
View File

@ -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))

47
src/Foundation/Types.hs
View File

@ -1,23 +1,44 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
-- SPDX-FileCopyrightText: 2023-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Foundation.Types
( UpsertCampusUserMode(..)
, _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

537
src/Foundation/Yesod/Auth.hs
View File

@ -1,69 +1,66 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@cip.ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Foundation.Yesod.Auth
( authenticate
, 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<number@fraport.de` here, too strong! Make Email-Field optional!
| userEmail : _ <- mapMaybe (assertM (elem '@') . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail)
-> return $ CI.mk userEmail
-- | userEmail : _ <- mapMaybe (assertM validEmail . either (const Nothing) Just . Text.decodeUtf8') (lookupSome ldapMap $ toList ldapUserEmail) -- TOO STRONG, see above!
-- -> return $ CI.mk userEmail
| otherwise
-> throwM CampusUserInvalidEmail
userLdapPrimaryKey <- if
| [bs] <- ldapMap !!! ldapPrimaryKey
, Right userLdapPrimaryKey'' <- Text.decodeUtf8' bs
, Just userLdapPrimaryKey''' <- assertM' (not . Text.null) $ Text.strip userLdapPrimaryKey''
-> return $ Just userLdapPrimaryKey'''
| otherwise
-> return Nothing
-> 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

4
src/Handler/Admin.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -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

74
src/Handler/Admin/ExternalUser.hs Normal file
View File

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

69
src/Handler/Admin/Ldap.hs
View File

@ -1,69 +0,0 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
module Handler.Admin.Ldap
( getAdminLdapR
, postAdminLdapR
) where
import Import
-- import qualified Control.Monad.State.Class as State
-- import Data.Aeson (encode)
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
-- import qualified Data.Set as Set
import Foundation.Yesod.Auth (decodeUserTest,ldapLookupAndUpsert,campusUserFailoverMode,CampusUserConversionException())
import Handler.Utils
import qualified Ldap.Client as Ldap
import Auth.LDAP
getAdminLdapR, postAdminLdapR :: Handler Html
getAdminLdapR = postAdminLdapR
postAdminLdapR = do
((presult, pwidget), penctype) <- runFormPost $ identifyForm ("adminLdapLookup"::Text) $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
let procFormPerson :: Text -> Handler (Maybe (Ldap.AttrList []))
procFormPerson lid = do
ldapPool' <- getsYesod $ view _appLdapPool
case ldapPool' of
Nothing -> addMessage Error (text2Html "LDAP Configuration missing.") >> return Nothing
Just ldapPool -> do
addMessage Info $ text2Html "Input for LDAP test received."
ldapData <- campusUser'' ldapPool campusUserFailoverMode lid
decodedErr <- decodeUserTest (pure $ CI.mk lid) $ concat ldapData
whenIsLeft decodedErr $ addMessageI Error
return ldapData
mbLdapData <- formResultMaybe presult procFormPerson
((uresult, uwidget), uenctype) <- runFormPost $ identifyForm ("adminLdapUpsert"::Text) $ \html ->
flip (renderAForm FormStandard) html $ areq textField (fslI MsgAdminUserIdent) Nothing
let procFormUpsert :: Text -> Handler (Maybe (Either CampusUserConversionException (Entity User)))
procFormUpsert lid = pure <$> runDB (try $ ldapLookupAndUpsert lid)
mbLdapUpsert <- formResultMaybe uresult procFormUpsert
actionUrl <- fromMaybe AdminLdapR <$> getCurrentRoute
siteLayoutMsg MsgMenuLdap $ do
setTitleI MsgMenuLdap
let personForm = wrapForm pwidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = penctype
}
upsertForm = wrapForm uwidget def
{ formAction = Just $ SomeRoute actionUrl
, formEncoding = uenctype
}
presentUtf8 lv = Text.intercalate ", " (either tshow id . Text.decodeUtf8' <$> lv)
presentLatin1 lv = Text.intercalate ", " ( Text.decodeLatin1 <$> lv)
-- TODO: use i18nWidgetFile instead if this is to become permanent
$(widgetFile "ldap")

6
src/Handler/Admin/Test.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -321,8 +321,8 @@ postAdminTestR = do
<dl .deflist>
<dt .deflist__dt> appJobCronInterval
<dd .deflist__dd>#{tshow appJobCronInterval}
<dt .deflist__dt> appSynchroniseLdapUsersWithin
<dd .deflist__dd>#{tshow appSynchroniseLdapUsersWithin}
<dt .deflist__dt> appUserSyncWithin
<dd .deflist__dd>#{tshow appUserSyncWithin}
<dt .deflist__dt> appSynchroniseAvsUsersWithin
<dd .deflist__dd>#{tshow appSynchroniseAvsUsersWithin}
|]

6
src/Handler/Course/Users.hs
View File

@ -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)

7
src/Handler/Exam/Users.hs
View File

@ -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

9
src/Handler/LMS/Fake.hs
View File

@ -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

2
src/Handler/Profile.hs
View File

@ -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

25
src/Handler/SAP.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -17,11 +17,9 @@ import Handler.Utils.Csv
import Handler.Utils.Profile
import qualified Data.Text as Text (intercalate)
-- import qualified Data.CaseInsensitive as CI
import qualified Data.Csv as Csv
import Database.Esqueleto.Experimental ((:&)(..))
import qualified Database.Esqueleto.Experimental as E -- needs TypeApplications Lang-Pragma
-- import qualified Database.Esqueleto.Legacy as E
import qualified Database.Esqueleto.PostgreSQL as E
import qualified Database.Esqueleto.Utils as E
@ -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

31
src/Handler/SingleSignOut.hs Normal file
View File

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

113
src/Handler/Users.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Winnie Ros <winnie.ros@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -11,14 +11,11 @@ module Handler.Users
import Import
import Jobs
-- import Data.Text
import Handler.Utils
import Handler.Utils.Users
import Handler.Utils.Invitations
import Handler.Utils.Avs
import qualified Auth.LDAP as Auth
import qualified Data.CaseInsensitive as CI
import qualified Data.Set as Set
@ -35,8 +32,6 @@ import qualified Data.ByteString.Base64 as Base64
import Data.Aeson hiding (Result(..))
-- import Handler.Users.Add as Handler.Users
import qualified Data.Conduit.List as C
import qualified Data.HashSet as HashSet
@ -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}|] $

12
src/Handler/Users/Add.hs
View File

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

35
src/Handler/Utils/Avs.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -35,8 +35,7 @@ import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI
-- import Auth.LDAP (ldapUserPrincipalName)
import Foundation.Yesod.Auth (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

40
src/Handler/Utils/Users.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Steffen Jost <s.jost@fraport.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -24,8 +24,7 @@ module Handler.Utils.Users
) where
import Import
import Auth.LDAP (campusUserMatr')
import Foundation.Yesod.Auth (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))

1
src/Import/NoModel.hs
View File

@ -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)

4
src/Jobs.hs
View File

@ -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

15
src/Jobs/Crontab.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-2023 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, David Mosbach <david.mosbach@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -310,15 +310,14 @@ determineCrontab = execWriterT $ do
return (nextEpoch, nextInterval, nextIntervalTime, numIntervals)
if
| is _Just appLdapConf
, Just syncWithin <- 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 ()

2
src/Jobs/Handler/SendNotification/UserAuthModeUpdate.hs
View File

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

4
src/Jobs/Handler/SendPasswordReset.hs
View File

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

64
src/Jobs/Handler/SynchroniseLdap.hs
View File

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

48
src/Jobs/Handler/SynchroniseUser.hs Normal file
View File

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

20
src/Jobs/HealthReport.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -107,23 +107,31 @@ dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _
getsYesod $ (== clusterId) . appClusterID
-- TODO: generalize health check
dispatchHealthCheckLDAPAdmins :: Handler HealthReport
dispatchHealthCheckLDAPAdmins = fmap HealthLDAPAdmins . yesodTimeout (^. _appHealthCheckLDAPAdminsTimeout) (Just 0) $ do
ldapPool' <- getsYesod appLdapPool
reTestAfter <- getsYesod $ view _appLdapReTestFailover
userAuthConf <- getsYesod $ view _appUserAuthConf
case ldapPool' of
Just ldapPool -> do
let currentLdapSources = case userAuthConf of
UserAuthConfSingleSource (AuthSourceConfLdap LdapConf{..})
-> singleton $ AuthSourceIdLdap ldapConfSourceId
_other -> mempty
ldapAdminUsers' <- fmap (map E.unValue) . runDB . E.select . E.from $ \(user `E.InnerJoin` userFunction) -> E.distinctOnOrderBy [E.asc $ user E.^. UserId] $ do
E.on $ user E.^. UserId E.==. userFunction E.^. UserFunctionUser
E.where_ $ userFunction E.^. UserFunctionFunction E.==. E.val SchoolAdmin
E.where_ $ user E.^. UserAuthentication E.==. E.val AuthLDAP
E.where_ . E.exists . E.from $ \externalUser -> E.where_ $
externalUser E.^. ExternalUserUser E.==. user E.^. UserIdent
E.&&. externalUser E.^. ExternalUserSource `E.in_` E.valList currentLdapSources
return $ user E.^. UserIdent
for (assertM' (not . null) ldapAdminUsers') $ \ldapAdminUsers -> do
let numAdmins = genericLength ldapAdminUsers
Sum numResolved <- fmap fold . forM ldapAdminUsers $ \(CI.original -> adminIdent) ->
let hCampusExc :: CampusUserException -> Handler (Sum Integer)
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

10
src/Jobs/Types.hs
View File

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

48
src/Ldap/Client/Instances.hs
View File

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

2
src/Ldap/Client/Pool.hs
View File

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

22
src/Model/Migration/Definitions.hs
View File

@ -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

2
src/Model/Types.hs
View File

@ -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

116
src/Model/Types/Security.hs → src/Model/Types/Auth.hs
View File

@ -1,75 +1,103 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Sarah Vaupel <vaupel.sarah@campus.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-|
Module: Model.Types.Security
Module: Model.Types.Auth
Description: Types for authentication and authorisation
-}
module Model.Types.Security
( module Model.Types.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

2
src/Model/Types/Exam.hs
View File

@ -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) #-}

5
src/Model/Types/User.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>, Sarah Vaupel <sarah.vaupel@ifi.lmu.de>, Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -8,9 +8,6 @@ import Import.NoModel
import Model.Types.TH.PathPiece
type UserEduPersonPrincipalName = Text
data SystemFunction
= SystemExamOffice
| SystemFaculty

838
src/Settings.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,David Mosbach <david.mosbach@uniworx.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -13,10 +13,13 @@
module Settings
( module Settings
, module Settings.Cluster
, module Settings.Mime
, module Settings.Cookies
, module Settings.Ldap
, module Settings.Log
, module Settings.Locale
, module Settings.Mime
, module Settings.OAuth2
, module Settings.ResourcePool
) where
import Import.NoModel
@ -41,12 +44,8 @@ import Language.Haskell.TH.Syntax (Exp, Q)
import qualified Yesod.Auth.Util.PasswordStore as PWStore
import qualified Data.Scientific as Scientific
import Data.Word (Word16)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Ldap.Client as Ldap
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
import qualified Network.Socket as HaskellNet
@ -56,11 +55,15 @@ import Network.Mail.Mime.Instances ()
import qualified Database.Memcached.Binary.Types as Memcached
import Model
import Settings.Cluster
import Settings.Mime
import Settings.Cookies
import Settings.Ldap
import Settings.Log
import Settings.Locale
import Settings.Mime
import Settings.OAuth2
import Settings.ResourcePool
import qualified System.FilePath as FilePath
@ -73,8 +76,6 @@ import qualified Web.ServerSession.Core as ServerSession
import Text.Show (showParen, showString)
import qualified Data.List.PointedList as P
import qualified Network.Minio as Minio
import Data.Conduit.Algorithms.FastCDC
@ -84,6 +85,361 @@ import Utils.Lens.TH
import qualified Data.Set as Set
data JobMode = JobsLocal { jobsAcceptOffload :: Bool }
| JobsOffload
| JobsDrop
{ jobsAcceptOffload :: Bool
, jobsWriteFakeLastExec :: Bool
}
deriving (Eq, Ord, Read, Show, Generic)
deriving anyclass (Hashable)
data ApprootScope = ApprootUserGenerated | ApprootDefault
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
deriving anyclass (Universe, Finite, Hashable)
newtype ServerSessionSettings
= ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
instance Show ServerSessionSettings where
showsPrec d _ = showParen (d > 10) $ showString "ServerSessionSettings _"
data UserDefaultConf = UserDefaultConf
{ userDefaultTheme :: Theme
, userDefaultMaxFavourites, userDefaultMaxFavouriteTerms :: Int
, userDefaultDateTimeFormat, userDefaultDateFormat, userDefaultTimeFormat :: DateTimeFormat
, userDefaultDownloadFiles :: Bool
, userDefaultWarningDays :: NominalDiffTime
, userDefaultShowSex :: Bool
, userDefaultExamOfficeGetSynced :: Bool
, userDefaultExamOfficeGetLabels :: Bool
, userDefaultPrefersPostal :: Bool
} deriving (Show)
data PWHashConf = PWHashConf
{ pwHashAlgorithm :: PWHashAlgorithm
, pwHashStrength :: Int
}
instance Show PWHashConf where
show PWHashConf{..} = "PWHashConf { pwHashStrength = " <> show pwHashStrength <> ", .. }"
instance FromJSON PWHashConf where
parseJSON = withObject "PWHashConf" $ \o -> do
pwHashAlgorithm' <- o .: "algorithm" :: Aeson.Parser Text
pwHashAlgorithm <- if
| pwHashAlgorithm' == "pbkdf1" -> return PWStore.pbkdf1
| pwHashAlgorithm' == "pbkdf2" -> return PWStore.pbkdf2
| otherwise -> fail "Unsupported hash algorithm"
pwHashStrength <- o .: "strength"
return PWHashConf{..}
data AuthSourceConf = AuthSourceConfLdap LdapConf | AuthSourceConfAzureAdV2 AzureConf
deriving (Show)
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

63
src/Settings/Ldap.hs Normal file
View File

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

32
src/Settings/OAuth2.hs Normal file
View File

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

30
src/Settings/ResourcePool.hs Normal file
View File

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

23
src/Utils/Form.hs
View File

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

4
src/Utils/Icon.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022-23 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>
-- SPDX-FileCopyrightText: 2022-24 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>,Steffen Jost <s.jost@fraport.de>,David Mosbach <david.mosbach@uniworx.de>
--
-- 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"

2
src/Utils/Lens.hs
View File

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

3
src/Utils/Session.hs
View File

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

37
src/Utils/Users.hs
View File

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

2
src/Yesod/Servant.hs
View File

@ -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(..)

33
stack.yaml
View File

@ -1,4 +1,4 @@
# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
# SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
#
# SPDX-License-Identifier: AGPL-3.0-or-later
@ -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

551
stack.yaml.lock
View File

@ -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

46
templates/admin/external-user.hamlet Normal file
View File

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

33
templates/ldap.hamlet
View File

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

21
templates/login.hamlet
View File

@ -1,20 +1,33 @@
$newline never
$# SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
$# SPDX-FileCopyrightText: 2022-2024 Gregor Kleen <gregor.kleen@ifi.lmu.de>, David Mosbach <david.mosbach@uniworx.de>
$#
$# SPDX-License-Identifier: AGPL-3.0-or-later
$forall AuthPlugin{apName, apLogin} <- plugins
$if apName == "LDAP"
$if apName == apAzure
<section>
<h2>Azure
^{apLogin toParent}
$elseif apName == apAzureMock
<section>
<h2>_{MsgDummyLoginTitle}
^{apLogin toParent}
$elseif apName == apLdap
<section>
<h2>_{MsgLDAPLoginTitle}
^{apLogin toParent}
$elseif apName == "PWHash"
$elseif apName == apHash
<section>
<h2>_{MsgPWHashLoginTitle}
<p>_{MsgPWHashLoginNote}
^{apLogin toParent}
$elseif apName == "dummy"
$elseif apName == apDummy
<section>
<h2>_{MsgDummyLoginTitle}
^{apLogin toParent}
$maybe port <- mPort
<section>
<h2>SSO Dev Test
<a href=http://localhost:#{port}/test-sso>Test login via single sign-on

20
templates/mail/userAuthModeUpdate.hamlet
View File

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

37
templates/profileData.hamlet
View File

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

58
test/Database/Fill.hs
View File

@ -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

231
test/Database/test-users.yaml Normal file
View File

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

1
test/Handler/Utils/SubmissionSpec.hs
View File

@ -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

19
test/Model/TypesSpec.hs
View File

@ -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)

25
test/ModelSpec.hs
View File

@ -1,4 +1,4 @@
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
-- SPDX-FileCopyrightText: 2022-2024 Sarah Vaupel <sarah.vaupel@uniworx.de>, Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later
@ -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

5
test/User.hs
View File

@ -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