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

Merged
savau merged 29 commits from 140-admin-handler-fur-oauth-response-inspection into oauth2 2024-02-15 17:22:14 +01:00
54 changed files with 908 additions and 113 deletions

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

2
package-lock.json generated
View File

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

View File

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

View File

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

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

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

View File

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

View File

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

View File

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

View File

@ -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 ":("

View File

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

View File

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

View File

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

View File

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

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

View 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")

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

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)

View File

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

View File

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

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