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